From 246d370bd903edeb5570b6f016556528b8ca57fc Mon Sep 17 00:00:00 2001
From: Arnaud Bailly <arnaud@pankzsoft.com>
Date: Wed, 5 Nov 2025 08:24:05 +0100
Subject: can cleanup registered users

---
 lambda-calcul/haskell/src/Minilang/API.hs         | 19 ++++++++++++++++++-
 lambda-calcul/haskell/src/Minilang/App.hs         | 21 +++++++++++++++++++--
 lambda-calcul/haskell/test/Minilang/ServerSpec.hs | 13 +++++++++++--
 3 files changed, 48 insertions(+), 5 deletions(-)

(limited to 'lambda-calcul/haskell')

diff --git a/lambda-calcul/haskell/src/Minilang/API.hs b/lambda-calcul/haskell/src/Minilang/API.hs
index 8082ac8..94976d2 100644
--- a/lambda-calcul/haskell/src/Minilang/API.hs
+++ b/lambda-calcul/haskell/src/Minilang/API.hs
@@ -16,11 +16,28 @@ import qualified Data.ByteString.Lazy as LBS
 import Data.Text (Text)
 import Data.Time (UTCTime)
 import GHC.Generics (Generic)
-import Servant (FromHttpApiData, Get, JSON, Post, QueryParam, Raw, ReqBody, StdMethod (POST), ToHttpApiData, Verb, parseUrlPiece, toUrlPiece, (:<|>), (:>))
+import Servant
+  ( Delete,
+    FromHttpApiData,
+    Get,
+    JSON,
+    Post,
+    QueryParam,
+    Raw,
+    ReqBody,
+    StdMethod (POST),
+    ToHttpApiData,
+    Verb,
+    parseUrlPiece,
+    toUrlPiece,
+    (:<|>),
+    (:>),
+  )
 import System.Random (StdGen, uniformList)
 
 type LambdaAPI =
   "api" :> "register" :> ReqBody '[JSON] User :> Verb 'POST 201 '[JSON] Token
+    :<|> "api" :> "register" :> QueryParam "token" Token :> Delete '[JSON] Score
     :<|> "api" :> "leaderboard" :> Get '[JSON] [Score]
     :<|> "api" :> "score" :> QueryParam "token" Token :> Get '[JSON] Score
     :<|> "api" :> "challenge" :> QueryParam "token" Token :> Get '[JSON] Challenge
diff --git a/lambda-calcul/haskell/src/Minilang/App.hs b/lambda-calcul/haskell/src/Minilang/App.hs
index 9086d27..915f264 100644
--- a/lambda-calcul/haskell/src/Minilang/App.hs
+++ b/lambda-calcul/haskell/src/Minilang/App.hs
@@ -24,7 +24,7 @@ import Minilang.REPL (withInputs)
 import Minilang.REPL.Purer (PurerEnv (..))
 import Minilang.REPL.Types (In (..), Out (..), initialREPL)
 import Network.Wai.Application.Static (defaultFileServerSettings, staticApp)
-import Servant (ServerT, err400, err500, errBody, (:<|>) (..))
+import Servant (ServerT, err400, err500, errBody, (:<|>) (..), err404)
 import Servant.Server (Application, Handler (..), Tagged (..))
 import System.Random (StdGen)
 
@@ -50,6 +50,7 @@ runApp env = Handler . ExceptT . try . flip runReaderT env . runAppM
 lambdaApp :: (MonadIO m, MonadReader Env m) => ServerT LambdaAPI m
 lambdaApp =
   registerUser
+    :<|> unregisterUser
     :<|> getLeaderboard
     :<|> getUser
     :<|> getChallenge
@@ -68,6 +69,22 @@ registerUser user@(User name) = do
       writeTVar tvar updatedMap
   pure token
 
+unregisterUser :: (MonadReader Env m, MonadIO m) => Maybe Token -> m Score
+unregisterUser Nothing = liftIO $ throwM $ err400 {errBody = "Missing token"}
+unregisterUser (Just token) = do
+  checkUserToken token
+  score <-
+    asks users
+      >>= liftIO . atomically . \tvar -> do
+        usersMap <- readTVar tvar
+        let score = Map.lookup token usersMap
+            updatedMap = Map.delete token usersMap
+        writeTVar tvar updatedMap
+        pure score
+  case score of
+    Nothing -> liftIO $ throwM $ err400 {errBody = "User does not exist"}
+    Just s -> pure s
+
 checkDuplicateUser :: (MonadIO m, MonadReader Env m) => Text -> m ()
 checkDuplicateUser name =
   asks users >>= \user -> liftIO $ atomically $ do
@@ -97,7 +114,7 @@ getUser :: (MonadIO m, MonadReader Env m) => Maybe Token -> m Score
 getUser mToken = do
   usersMap <- asks users >>= liftIO . readTVarIO
   case mToken >>= (`Map.lookup` usersMap) of
-    Nothing -> liftIO $ throwM $ err400 {errBody = "User does not exist"}
+    Nothing -> liftIO $ throwM $ err404 {errBody = "User does not exist"}
     Just score -> pure score
 
 getChallenge :: (MonadReader Env m, MonadIO m) => Maybe Token -> m Challenge
diff --git a/lambda-calcul/haskell/test/Minilang/ServerSpec.hs b/lambda-calcul/haskell/test/Minilang/ServerSpec.hs
index e109977..a60c232 100644
--- a/lambda-calcul/haskell/test/Minilang/ServerSpec.hs
+++ b/lambda-calcul/haskell/test/Minilang/ServerSpec.hs
@@ -64,6 +64,15 @@ spec = with (app testSeed) $ do
     postJSON "/api/register" alice
       `shouldRespondWith` 400
 
+  it "DELETE /api/register returns 200 and deletes user score given user is registered" $ do
+    void $ postJSON "/api/register" alice
+
+    request "DELETE" ("/api/register?token=" <> LBS.toStrict token) [] ""
+      `shouldRespondWith` 200
+
+    get ("/api/score?token=" <> LBS.toStrict token)
+      `shouldRespondWith` 404
+
   it "GET /api/challenge returns next challenge given user is registered" $ do
     let expected = LT.unpack $ decodeUtf8 $ encode $ Challenge {level = 0, expr = "x"}
     postJSON "/api/register" alice
@@ -134,9 +143,9 @@ spec = with (app testSeed) $ do
               Left err -> Just $ "Failed to decode JSON: " ++ err
         }
 
-  it "GET /api/score returns 400 given token is not registered" $ do
+  it "GET /api/score returns 404 given token is not registered" $ do
     get ("/api/score?token=" <> LBS.toStrict token)
-      `shouldRespondWith` 400
+      `shouldRespondWith` 404
 
   it "GET /api/score returns score with success given last challenge succeeded" $ do
     void $ postJSON "/api/register" alice
-- 
cgit v1.3.1