Register user and return random token

3 files changed, 76 insertions, 16 deletions

diff --git a/lambda-calcul/haskell/src/Minilang/API.hs b/lambda-calcul/haskell/src/Minilang/API.hs
index 2b8743f..0ae0784 100644
--- a/lambda-calcul/haskell/src/Minilang/API.hs
+++ b/lambda-calcul/haskell/src/Minilang/API.hs
@@ -1,13 +1,23 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+{-# HLINT ignore "Use newtype instead of data" #-}
 
 module Minilang.API where
 
 import Data.Aeson (FromJSON, ToJSON)
+import Data.Bifunctor (first)
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Lazy as LBS
+import Data.Text (Text)
 import Data.Time (UTCTime)
 import GHC.Generics (Generic)
-import Servant (Get, JSON, (:<|>), (:>), Raw)
+import Servant (Get, JSON, Raw, ReqBody, StdMethod (POST), Verb, (:<|>), (:>))
+import System.Random (StdGen, uniformList)
 
 data Score = Score
   { name :: String,
@@ -16,6 +26,16 @@ data Score = Score
   }
   deriving (Eq, Show, Generic, ToJSON, FromJSON)
 
+newtype User = User {username :: Text}
+  deriving newtype (Eq, Show, ToJSON, FromJSON)
+
+data Token = Token {token :: Text}
+  deriving (Eq, Show, Generic, ToJSON, FromJSON)
+
+newToken :: StdGen -> (ByteString, StdGen)
+newToken = first LBS.pack . uniformList 16
+
 type LambdaAPI =
-  "api" :> "leaderboard" :> Get '[JSON] [Score]
+  "api" :> "register" :> ReqBody '[JSON] User :> Verb 'POST 201 '[JSON] Token
+    :<|> "api" :> "leaderboard" :> Get '[JSON] [Score]
     :<|> Raw
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]
diff --git a/lambda-calcul/haskell/src/Minilang/Server.hs b/lambda-calcul/haskell/src/Minilang/Server.hs
index d627271..a8ab7ca 100644
--- a/lambda-calcul/haskell/src/Minilang/Server.hs
+++ b/lambda-calcul/haskell/src/Minilang/Server.hs
@@ -13,20 +13,21 @@ import Data.Aeson
     (.=),
   )
 import Data.ByteString.Lazy (fromStrict)
+import Data.Data (Proxy (..))
 import Data.Default
 import Data.Text (Text)
+import Minilang.API (LambdaAPI)
+import Minilang.App (Env (..), lambdaApp, runApp)
 import Minilang.Log
 import Minilang.REPL.Net
 import Network.Wai
 import Network.Wai.Handler.Warp as Warp
 import Network.Wai.Middleware.RequestLogger
 import Network.Wai.Middleware.RequestLogger.JSON
-import Network.Wai.Middleware.Static (addBase, defaultOptions, staticPolicyWithOptions)
+import Servant (hoistServer)
 import Servant.Server (serve)
 import System.Log.FastLogger (fromLogStr)
-import Data.Data (Proxy (..))
-import Minilang.API (LambdaAPI)
-import Minilang.App (lambdaApp)
+import System.Random (newStdGen)
 
 data Server = Server
   { -- | If the server is running, this will contain the underlying
@@ -43,9 +44,10 @@ startServer serverPort = do
   envs <- newTVarIO mempty
   logger <- newLog "minilang"
   loggerMiddleware <- runHTTPLog logger
+  env <- Env <$> (newStdGen >>= newTVarIO)
   let app =
         loggerMiddleware $
-          runNetREPL logger envs serveAPI
+          runNetREPL logger envs (serveAPI env)
   (port, action) <- startWarp serverPort app
   thread <- async action
   logInfo logger $ object ["action" .= ("Started" :: Text), "port" .= port]
@@ -63,8 +65,10 @@ startServer serverPort = do
             destination = Callback (\str -> logInfo logger (decode @Value $ fromStrict $ fromLogStr str))
           }
 
-serveAPI :: Application
-serveAPI = serve apiProxy lambdaApp
+serveAPI :: Env -> Application
+serveAPI env =
+  serve apiProxy $
+    hoistServer apiProxy (runApp env) lambdaApp
 
 apiProxy :: Proxy LambdaAPI
 apiProxy = Proxy