commit - 167070c7b13dd2df2eb999ad87d65e18a1388083
commit + db9802659863b1d5349e3551bd884f6ba90e2bf7
blob - 14d4b8228fae0306870ac7648d6d13b81ba33521
blob + b9dc06cbe85014ef2cdefda323e04f51b58a1b07
--- README.md
+++ README.md
the manual/static import mechanism (via the `add-user` CLI). If a slug is defined in both
`users.json` and an approved registration, the `users.json` entry wins.
+The `/admin` page also lists registered users under **users**, each with a **remove**
+button (two-click confirm). Removing a user stops its sync fibers, drops it from the live
+set (no restart), **deletes its database file**, and marks the registration `revoked` — so
+it stays gone across restarts and the username frees up for re-registration. Removal only
+applies to self-registered users; root and `users.json`-defined users are managed manually.
+
### Per-user configuration
| Field | Default | Description |
blob - cd9ca27d6a27892bce6b75585170f0adee80ef9b
blob + 5072504ee5f318b9f9a6be0a99f57a93eec680f8
--- src/Api.elm
+++ src/Api.elm
-module Api exposing (approveRegistration, denyRegistration, fetchListens, fetchRegistrations, fetchSectionData, fetchSimilarTracks, fetchStats, httpErrorToString, listensDecoder, sectionEntriesDecoder, similarTracksDecoder, statsDecoder, statsUrl, submitRegistration)
+module Api exposing (approveRegistration, denyRegistration, fetchListens, fetchRegistrations, fetchSectionData, fetchSimilarTracks, fetchStats, fetchUsers, httpErrorToString, listensDecoder, removeUser, sectionEntriesDecoder, similarTracksDecoder, statsDecoder, statsUrl, submitRegistration)
import Http
import Json.Decode as D exposing (Decoder)
}
+fetchUsers : String -> Cmd Msg
+fetchUsers token =
+ Http.request
+ { method = "GET"
+ , headers = [ Http.header "Authorization" ("Bearer " ++ token) ]
+ , url = "/admin/users"
+ , body = Http.emptyBody
+ , expect = Http.expectJson GotUsers (D.list registrationDecoder)
+ , timeout = Nothing
+ , tracker = Nothing
+ }
+
+
+removeUser : String -> String -> Cmd Msg
+removeUser token id =
+ Http.request
+ { method = "POST"
+ , headers = [ Http.header "Authorization" ("Bearer " ++ token) ]
+ , url = "/admin/users/remove"
+ , body = Http.jsonBody (E.object [ ( "id", E.string id ) ])
+ , expect = expectWhateverWithError GotRemoveResult
+ , timeout = Nothing
+ , tracker = Nothing
+ }
+
+
httpErrorToString : Http.Error -> String
httpErrorToString err =
case err of
blob - 0fc67f2b9040442b0fb662ab9b25d7761414f18e
blob + 1531b8cb05d6cd703cb78cfa5747786140c603e2
--- src/Db.js
+++ src/Db.js
.catch((e) => cb(e)());
};
+export const closeConnectionImpl = (conn, cb) => () => {
+ try {
+ conn.closeSync();
+ cb(null)();
+ } catch (e) {
+ cb(e)();
+ }
+};
+
// DuckDB returns BIGINT as BigInt, which JSON.stringify doesn't support.
// Pure transformation: produce new row objects rather than mutating in place.
const convertBigInts = (row) =>
blob - bbe8974023df453cc393335987d4fea3f75c0342
blob + 6941a8ab8c6be926c7581418d19db45f7a7b535d
--- src/Db.purs
+++ src/Db.purs
foreign import runImpl :: Fn4 Connection String (Array Foreign) (Nullable Error -> Effect Unit) (Effect Unit)
foreign import allImpl :: Fn4 Connection String (Array Foreign) (Nullable Error -> Nullable (Array Json) -> Effect Unit) (Effect Unit)
foreign import checkpointImpl :: Fn2 Connection (Nullable Error -> Effect Unit) (Effect Unit)
+foreign import closeConnectionImpl :: Fn2 Connection (Nullable Error -> Effect Unit) (Effect Unit)
foreign import sha256 :: String -> String
connect :: String -> Aff Connection
Nothing -> cb (Right unit)
pure nonCanceler
+-- Closes the underlying DuckDB connection, releasing its file lock so the
+-- database file can be deleted.
+closeConnection :: Connection -> Aff Unit
+closeConnection conn = makeAff \cb -> do
+ runFn2 closeConnectionImpl conn \err ->
+ case toMaybe err of
+ Just e -> cb (Left e)
+ Nothing -> cb (Right unit)
+ pure nonCanceler
+
dbBaseName :: String -> String
dbBaseName path =
let
blob - 85fa100ac44baaa29d9033f4d37b959f5b530fda
blob + fa4250e86cb91b61f1403c67598d0f928f29971f
--- src/Main.purs
+++ src/Main.purs
import Data.String.Regex (Regex, regex, replace, parseFlags)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..), fst)
-import Db (Connection, backupDb, connect, fromString, getOrCreateToken, getScrobbles, getStats, getTokenUser, initDb, initReleaseMetadata, ping, upsertScrobble, withTransaction)
+import Db (Connection, backupDb, closeConnection, connect, fromString, getOrCreateToken, getScrobbles, getStats, getTokenUser, initDb, initReleaseMetadata, ping, upsertScrobble, withTransaction)
import Effect (Effect)
import Effect.Aff (Aff, Fiber, forkAff, joinFiber, killFiber, launchAff_, try)
import Effect.Aff.AVar (AVar)
launchAff_ $ withAdmin env req res (serveDeny env req res)
else
serveBadRequest res "Method not allowed"
+ "/admin/users" ->
+ if IM.method req == "GET" then
+ launchAff_ $ withAdmin env req res (serveListUsers env res)
+ else
+ serveBadRequest res "Method not allowed"
+ "/admin/users/remove" ->
+ if IM.method req == "POST" then
+ launchAff_ $ withAdmin env req res (serveRemoveUser env req res)
+ else
+ serveBadRequest res "Method not allowed"
"/metrics" ->
if env.appConfig.metricsEnabled then serveMetrics res
else do
notifyDenied env reg
liftEffect $ respond "application/json" 200 """{"status":"denied"}""" res
+-- Lists the currently-registered (approved) users.
+serveListUsers :: ServerEnv -> Response -> Aff Unit
+serveListUsers env res = do
+ regs <- Reg.listByStatus env.regConn "approved"
+ liftEffect $ respond "application/json" 200 (stringify $ encodeJson (map regToJson regs)) res
+
+serveRemoveUser :: ServerEnv -> Request -> Response -> Aff Unit
+serveRemoveUser env req res = do
+ body <- readableToStringUtf8 (IM.toReadable req)
+ case parseJson body >>= decodeJson of
+ Left _ ->
+ liftEffect $ serveBadRequest res "Invalid JSON"
+ Right ({ id } :: { id :: String }) -> do
+ mReg <- Reg.getById env.regConn id
+ case mReg of
+ Nothing ->
+ liftEffect $ serveNotFound res
+ Just reg ->
+ if reg.status /= "approved" then
+ liftEffect $ serveBadRequest res "User is not active"
+ else do
+ removeUser env reg
+ liftEffect $ respond "application/json" 200 """{"status":"removed"}""" res
+
+-- Removes an approved user: stops its fibers, drops it from the live set,
+-- deletes its database file, and marks the registration 'revoked' (so it stays
+-- gone across restarts and the slug frees up for re-registration).
+removeUser :: ServerEnv -> Reg.Registration -> Aff Unit
+removeUser env reg = do
+ contexts <- liftEffect $ Ref.read env.contextsRef
+ for_ (find (\c -> c.slug == reg.slug) contexts) \ctx -> do
+ cleanupUser ctx
+ liftEffect $ Ref.modify_ (Data.Array.filter (\c -> c.slug /= reg.slug)) env.contextsRef
+ void $ try $ closeConnection ctx.conn
+ void $ try $ FSA.unlink ctx.config.databaseFile
+ Reg.setStatus env.regConn env.regLock reg.id "revoked"
+
-- Builds a runnable UserEntry from an approved registration (users.json is not touched).
registrationUserEntry :: Reg.Registration -> Aff UserEntry
registrationUserEntry reg = do
blob - a9c78fc0100f3b5d476251cc6b434c1bd24f97cd
blob + 1f99cfd0d81d875b4ed6319d26fca553ed0891cd
--- src/State.elm
+++ src/State.elm
module State exposing (init, subscriptions, update)
-import Api exposing (approveRegistration, denyRegistration, fetchListens, fetchRegistrations, fetchSectionData, fetchSimilarTracks, fetchStats, httpErrorToString, submitRegistration)
+import Api exposing (approveRegistration, denyRegistration, fetchListens, fetchRegistrations, fetchSectionData, fetchSimilarTracks, fetchStats, fetchUsers, httpErrorToString, removeUser, submitRegistration)
import Browser
import Browser.Navigation as Nav
import Dict
, adminToken = flags.adminToken
, adminTokenInput = flags.adminToken
, registrations = []
+ , users = []
+ , confirmingRemoval = Nothing
, adminError = Nothing
, approvedToken = Nothing
}
Cmd.none
else
- fetchRegistrations flags.adminToken
+ Cmd.batch [ fetchRegistrations flags.adminToken, fetchUsers flags.adminToken ]
]
RegisterPage ->
( { model | page = RegisterPage }, Cmd.none )
AdminPage ->
- ( { model | page = AdminPage, approvedToken = Nothing }
+ ( { model | page = AdminPage, approvedToken = Nothing, confirmingRemoval = Nothing }
, if String.isEmpty model.adminToken then
Cmd.none
else
- fetchRegistrations model.adminToken
+ Cmd.batch [ fetchRegistrations model.adminToken, fetchUsers model.adminToken ]
)
MainPage ->
Cmd.none
else
- fetchRegistrations token
+ Cmd.batch [ fetchRegistrations token, fetchUsers token ]
]
)
Cmd.none
else
- fetchRegistrations model.adminToken
+ Cmd.batch [ fetchRegistrations model.adminToken, fetchUsers model.adminToken ]
)
Err err ->
Err msg_ ->
( { model | adminError = Just msg_ }, Cmd.none )
+ FetchUsers ->
+ ( { model | adminError = Nothing }
+ , if String.isEmpty model.adminToken then
+ Cmd.none
+ else
+ fetchUsers model.adminToken
+ )
+
+ GotUsers result ->
+ case result of
+ Ok users ->
+ ( { model | users = users, adminError = Nothing }, Cmd.none )
+
+ Err err ->
+ ( { model | adminError = Just (httpErrorToString err) }, Cmd.none )
+
+ RequestRemoveUser id ->
+ ( { model | confirmingRemoval = Just id }, Cmd.none )
+
+ CancelRemoveUser ->
+ ( { model | confirmingRemoval = Nothing }, Cmd.none )
+
+ RemoveUser id ->
+ ( { model | confirmingRemoval = Nothing }, removeUser model.adminToken id )
+
+ GotRemoveResult result ->
+ case result of
+ Ok () ->
+ ( model
+ , if String.isEmpty model.adminToken then
+ Cmd.none
+
+ else
+ fetchUsers model.adminToken
+ )
+
+ Err msg_ ->
+ ( { model | adminError = Just msg_ }, Cmd.none )
+
+
patchStatSection : String -> List StatsEntry -> Stats -> Stats
patchStatSection section entries stats =
case section of
blob - e5bf94c992d2350a657c28cf2277a6dfc34496eb
blob + 7b4a00c9d4f0fec9c01568dbfaa534371735cc84
--- src/Types.elm
+++ src/Types.elm
, adminToken : String
, adminTokenInput : String
, registrations : List Registration
+ , users : List Registration
+ , confirmingRemoval : Maybe String
, adminError : Maybe String
, approvedToken : Maybe String
}
| DenyRegistration String
| GotApproveResult (Result Http.Error ApproveResponse)
| GotDenyResult (Result String ())
+ | FetchUsers
+ | GotUsers (Result Http.Error (List Registration))
+ | RequestRemoveUser String
+ | CancelRemoveUser
+ | RemoveUser String
+ | GotRemoveResult (Result String ())
| UrlRequested Browser.UrlRequest
| UrlChanged Url.Url
blob - b5bde15141bbf08f944fb45cab62dc3bec178549
blob + 5feee1cbe00edb8995bcfb811a9346a83c4e798c
--- src/View.elm
+++ src/View.elm
]
AboutTab ->
- renderAboutView model.registrationEnabled model.userSlug model.allUsers
+ renderAboutView model.userSlug model.allUsers
]
"unknown time"
-renderAboutView : Bool -> String -> List UserInfo -> Html Msg
-renderAboutView registrationEnabled currentSlug allUsers =
+renderAboutView : String -> List UserInfo -> Html Msg
+renderAboutView currentSlug allUsers =
let
otherUsers =
List.filter (\u -> u.slug /= currentSlug) allUsers
, text " and "
, extLink "https://www.last.fm" "Last.fm."
]
- , if registrationEnabled then
- p [] [ a [ href "/register", class "about-link" ] [ text "request an account" ] ]
-
- else
- text ""
, if List.isEmpty otherUsers then
text ""
, if String.isEmpty model.adminToken then
text ""
- else if List.isEmpty model.registrations then
- p [] [ text "No pending registrations." ]
-
else
- ul [ class "admin-list" ]
- (List.map renderRegistrationItem model.registrations)
+ div []
+ [ h2 [] [ text "pending" ]
+ , if List.isEmpty model.registrations then
+ p [] [ text "No pending registrations." ]
+
+ else
+ ul [ class "admin-list" ]
+ (List.map renderRegistrationItem model.registrations)
+ , h2 [] [ text "users" ]
+ , if List.isEmpty model.users then
+ p [] [ text "No registered users." ]
+
+ else
+ ul [ class "admin-list" ]
+ (List.map (renderUserItem model.confirmingRemoval) model.users)
+ ]
]
]
+renderUserItem : Maybe String -> Registration -> Html Msg
+renderUserItem confirmingRemoval reg =
+ li [ class "admin-item" ]
+ [ div [ class "admin-item-meta" ]
+ [ div [ class "admin-item-slug" ] [ text reg.slug ]
+ , div [ class "admin-item-sub" ] [ text (reg.name ++ " · " ++ reg.email) ]
+ , div [ class "admin-item-sub" ] [ text (regSources reg) ]
+ ]
+ , if confirmingRemoval == Just reg.id then
+ div [ class "admin-actions" ]
+ [ span [ class "admin-item-sub" ] [ text "delete this account and its data?" ]
+ , button [ class "deny-btn", onClick (RemoveUser reg.id) ] [ text "confirm" ]
+ , button [ class "approve-btn", onClick CancelRemoveUser ] [ text "cancel" ]
+ ]
+
+ else
+ div [ class "admin-actions" ]
+ [ button [ class "deny-btn", onClick (RequestRemoveUser reg.id) ] [ text "remove" ] ]
+ ]
+
+
regSources : Registration -> String
regSources reg =
let
