commit db9802659863b1d5349e3551bd884f6ba90e2bf7 from: mtmn date: Tue Jul 14 12:05:18 2026 UTC feat: add user deletion to admin commit - 167070c7b13dd2df2eb999ad87d65e18a1388083 commit + db9802659863b1d5349e3551bd884f6ba90e2bf7 blob - 14d4b8228fae0306870ac7648d6d13b81ba33521 blob + b9dc06cbe85014ef2cdefda323e04f51b58a1b07 --- README.md +++ README.md @@ -118,6 +118,12 @@ re-loaded automatically at every startup — `users.js 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 @@ -1,4 +1,4 @@ -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) @@ -179,6 +179,32 @@ denyRegistration token id = } +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 @@ -26,6 +26,15 @@ export const checkpointImpl = (conn, cb) => () => { .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 @@ -65,6 +65,7 @@ foreign import connectImpl :: Fn2 String (Nullable Err 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 @@ -94,6 +95,16 @@ checkpoint conn = makeAff \cb -> do 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 @@ -16,7 +16,7 @@ import Data.String (Pattern(..), stripPrefix, trim) 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) @@ -132,6 +132,16 @@ routeRequest env contexts req url path allUsers res = 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 @@ -387,6 +397,43 @@ serveDeny env req res = 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 @@ -1,6 +1,6 @@ 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 @@ -63,6 +63,8 @@ init flags url navKey = , adminToken = flags.adminToken , adminTokenInput = flags.adminToken , registrations = [] + , users = [] + , confirmingRemoval = Nothing , adminError = Nothing , approvedToken = Nothing } @@ -74,7 +76,7 @@ init flags url navKey = Cmd.none else - fetchRegistrations flags.adminToken + Cmd.batch [ fetchRegistrations flags.adminToken, fetchUsers flags.adminToken ] ] RegisterPage -> @@ -136,12 +138,12 @@ update msg model = ( { 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 -> @@ -593,7 +595,7 @@ update msg model = Cmd.none else - fetchRegistrations token + Cmd.batch [ fetchRegistrations token, fetchUsers token ] ] ) @@ -628,7 +630,7 @@ update msg model = Cmd.none else - fetchRegistrations model.adminToken + Cmd.batch [ fetchRegistrations model.adminToken, fetchUsers model.adminToken ] ) Err err -> @@ -648,7 +650,47 @@ update msg model = 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 @@ -168,6 +168,8 @@ type alias Model = , adminToken : String , adminTokenInput : String , registrations : List Registration + , users : List Registration + , confirmingRemoval : Maybe String , adminError : Maybe String , approvedToken : Maybe String } @@ -211,6 +213,12 @@ type Msg | 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 @@ -154,7 +154,7 @@ renderMain model = ] AboutTab -> - renderAboutView model.registrationEnabled model.userSlug model.allUsers + renderAboutView model.userSlug model.allUsers ] @@ -665,8 +665,8 @@ timeAgo mNow mTimestamp = "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 @@ -693,11 +693,6 @@ renderAboutView registrationEnabled currentSlug allUse , 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 "" @@ -811,12 +806,23 @@ renderAdmin model = , 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) + ] ] @@ -835,6 +841,27 @@ renderRegistrationItem reg = ] +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