1 files changed, 36 insertions, 13 deletions
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