1 files changed, 43 insertions, 7 deletions
diff --git a/lambda-calcul/haskell/src/Minilang/App.hs b/lambda-calcul/haskell/src/Minilang/App.hs
index 8c1fb2b..9b84d8a 100644
--- a/lambda-calcul/haskell/src/Minilang/App.hs
+++ b/lambda-calcul/haskell/src/Minilang/App.hs
@@ -1,16 +1,52 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE OverloadedStrings #-}
+
 module Minilang.App where
 
-import Control.Monad.IO.Class (liftIO)
+import Control.Concurrent.STM (TVar, atomically, readTVar, writeTVar)
+import Control.Exception (try)
+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.Text.Encoding (decodeUtf8, encodeUtf8)
 import Data.Time (getCurrentTime)
-import Minilang.API (LambdaAPI, Score (..))
+import Minilang.API (LambdaAPI, Score (..), Token (..), User (..), newToken)
 import Network.Wai.Application.Static (defaultFileServerSettings, staticApp)
-import Servant ((:<|>) (..))
-import Servant.Server (Application, Handler, Server, Tagged (..))
+import Servant (ServerT, (:<|>) (..))
+import Servant.Server (Application, Handler (..), Server, Tagged (..))
+import System.Random (StdGen)
+
+data Env = Env
+  { gen :: TVar StdGen
+  }
+
+newtype AppM a = AppM {runAppM :: ReaderT Env IO a}
+  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader Env)
+
+runApp :: Env -> AppM a -> Handler a
+runApp env = Handler . ExceptT . try . flip runReaderT env . runAppM
+
+lambdaApp :: (MonadIO m, MonadReader Env m) => ServerT LambdaAPI m
+lambdaApp =
+  registerUser
+    :<|> getLeaderboard
+    :<|> Tagged staticResources
 
-lambdaApp :: Server LambdaAPI
-lambdaApp = getLeaderboard :<|> 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
+  pure $ Token tokenText
 
-getLeaderboard :: Handler [Score]
+getLeaderboard :: (MonadIO m) => m [Score]
 getLeaderboard = do
   now <- liftIO getCurrentTime
   pure [Score "Alice" 95 now, Score "Bob" 88 now]