Keep registered users

4 files changed, 49 insertions, 19 deletions

diff --git a/lambda-calcul/haskell/src/Minilang/API.hs b/lambda-calcul/haskell/src/Minilang/API.hs
index 0ae0784..e9eef6a 100644
--- a/lambda-calcul/haskell/src/Minilang/API.hs
+++ b/lambda-calcul/haskell/src/Minilang/API.hs
@@ -20,9 +20,9 @@ import Servant (Get, JSON, Raw, ReqBody, StdMethod (POST), Verb, (:<|>), (:>))
 import System.Random (StdGen, uniformList)
 
 data Score = Score
-  { name :: String,
+  { user :: User,
     grade :: Int,
-    lastTest :: UTCTime
+    lastTest :: Maybe UTCTime
   }
   deriving (Eq, Show, Generic, ToJSON, FromJSON)
 
diff --git a/lambda-calcul/haskell/src/Minilang/App.hs b/lambda-calcul/haskell/src/Minilang/App.hs
index 9b84d8a..dae6b65 100644
--- a/lambda-calcul/haskell/src/Minilang/App.hs
+++ b/lambda-calcul/haskell/src/Minilang/App.hs
@@ -3,25 +3,36 @@
 
 module Minilang.App where
 
-import Control.Concurrent.STM (TVar, atomically, readTVar, writeTVar)
+import Control.Concurrent.STM (TVar, atomically, newTVarIO, readTVar, writeTVar)
 import Control.Exception (try)
+import Control.Monad.Catch (MonadThrow (throwM))
 import Control.Monad.Except (ExceptT (..))
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Control.Monad.Reader (MonadReader, ReaderT, ask, asks, runReaderT)
 import qualified Data.ByteString.Base64 as Base64
 import qualified Data.ByteString.Lazy as LBS
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Text (Text)
 import Data.Text.Encoding (decodeUtf8, encodeUtf8)
 import Data.Time (getCurrentTime)
 import Minilang.API (LambdaAPI, Score (..), Token (..), User (..), newToken)
 import Network.Wai.Application.Static (defaultFileServerSettings, staticApp)
-import Servant (ServerT, (:<|>) (..))
+import Servant (ServerT, err400, errBody, (:<|>) (..))
 import Servant.Server (Application, Handler (..), Server, Tagged (..))
 import System.Random (StdGen)
 
 data Env = Env
-  { gen :: TVar StdGen
+  { gen :: TVar StdGen,
+    users :: TVar (Map Text Score)
   }
 
+makeEnv :: StdGen -> IO Env
+makeEnv gen =
+  Env
+    <$> newTVarIO gen
+    <*> newTVarIO mempty
+
 newtype AppM a = AppM {runAppM :: ReaderT Env IO a}
   deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader Env)
 
@@ -35,21 +46,33 @@ lambdaApp =
     :<|> Tagged staticResources
 
 registerUser :: (MonadReader Env m, MonadIO m) => User -> m Token
-registerUser (User _name) = do
-  bytes <-
-    asks gen
-      >>= liftIO . atomically . \tvar -> do
-        genVal <- readTVar tvar
-        let (tokenBytes, newGen) = newToken genVal
-        writeTVar tvar newGen
-        pure $ LBS.toStrict tokenBytes
-  let tokenText = decodeUtf8 $ Base64.encode bytes
+registerUser user@(User name) = do
+  asks users
+    >>= liftIO . atomically . \tvar -> do
+      usersMap <- readTVar tvar
+      case Map.lookup name usersMap of
+        Just _ -> throwM $ err400 {errBody = "User already registered"}
+        Nothing -> do
+          let score = Score user 0 Nothing
+          let updatedMap = Map.insert name score usersMap
+          writeTVar tvar updatedMap
+  bytes <- generateToken
+  let tokenText = bytes
   pure $ Token tokenText
 
+generateToken :: (MonadReader Env m, MonadIO m) => m Text
+generateToken =
+  asks gen
+    >>= liftIO . atomically . \tvar -> do
+      genVal <- readTVar tvar
+      let (tokenBytes, newGen) = newToken genVal
+      writeTVar tvar newGen
+      pure $ decodeUtf8 $ Base64.encode $ LBS.toStrict tokenBytes
+
 getLeaderboard :: (MonadIO m) => m [Score]
 getLeaderboard = do
   now <- liftIO getCurrentTime
-  pure [Score "Alice" 95 now, Score "Bob" 88 now]
+  pure [Score (User "Alice") 95 (Just now), Score (User "Bob") 88 (Just now)]
 
 -- | Serve static resources under `public/` directory
 staticResources :: Application
diff --git a/lambda-calcul/haskell/src/Minilang/Server.hs b/lambda-calcul/haskell/src/Minilang/Server.hs
index a8ab7ca..6f820ed 100644
--- a/lambda-calcul/haskell/src/Minilang/Server.hs
+++ b/lambda-calcul/haskell/src/Minilang/Server.hs
@@ -17,7 +17,7 @@ import Data.Data (Proxy (..))
 import Data.Default
 import Data.Text (Text)
 import Minilang.API (LambdaAPI)
-import Minilang.App (Env (..), lambdaApp, runApp)
+import Minilang.App (Env (..), lambdaApp, runApp, makeEnv)
 import Minilang.Log
 import Minilang.REPL.Net
 import Network.Wai
@@ -44,7 +44,7 @@ startServer serverPort = do
   envs <- newTVarIO mempty
   logger <- newLog "minilang"
   loggerMiddleware <- runHTTPLog logger
-  env <- Env <$> (newStdGen >>= newTVarIO)
+  env <- newStdGen >>= makeEnv
   let app =
         loggerMiddleware $
           runNetREPL logger envs (serveAPI env)
diff --git a/lambda-calcul/haskell/test/Minilang/ServerSpec.hs b/lambda-calcul/haskell/test/Minilang/ServerSpec.hs
index 6a3b6d5..33fbd69 100644
--- a/lambda-calcul/haskell/test/Minilang/ServerSpec.hs
+++ b/lambda-calcul/haskell/test/Minilang/ServerSpec.hs
@@ -4,6 +4,7 @@
 module Minilang.ServerSpec where
 
 import Control.Concurrent.STM (newTVarIO)
+import Control.Monad (void)
 import Data.Aeson (FromJSON, eitherDecode, encode)
 import Data.ByteString (isInfixOf, toStrict)
 import qualified Data.ByteString as BS
@@ -11,7 +12,7 @@ import qualified Data.ByteString.Base64.Lazy as Base64
 import Data.ByteString.Lazy (ByteString)
 import Data.Data (Proxy (..))
 import Minilang.API (Score, User (..), newToken)
-import Minilang.App (Env (..))
+import Minilang.App (Env (..), makeEnv)
 import Minilang.Server (serveAPI)
 import Network.Wai (Application)
 import Network.Wai.Test (SResponse)
@@ -47,6 +48,12 @@ spec = with (app testSeed) $ do
               else Just ("Expected token " ++ show token ++ ", but got " ++ show t)
         }
 
+  it "POST /api/register returns 400 given user is already registered" $ do
+    let user = encode $ User "alice"
+    void $ postJSON "/api/register" user
+    postJSON "/api/register" user
+      `shouldRespondWith` 400
+
 postJSON :: BS.ByteString -> ByteString -> WaiSession () SResponse
 postJSON url = request "POST" url [("Content-Type", "application/json")]
 
@@ -61,7 +68,7 @@ arrayOfLengthOf _ len = MatchBody $ \_ actual ->
 
 app :: StdGen -> IO Application
 app g = do
-  env <- Env <$> newTVarIO g
+  env <- makeEnv g
   pure $ serveAPI env
 
 testSeed :: StdGen