Register user and return random token

5 files changed, 113 insertions, 22 deletions

diff --git a/lambda-calcul/haskell/minilang.cabal b/lambda-calcul/haskell/minilang.cabal
index 40c5d47..a809a8f 100644
--- a/lambda-calcul/haskell/minilang.cabal
+++ b/lambda-calcul/haskell/minilang.cabal
@@ -60,6 +60,7 @@ library
       aeson
     , async
     , base
+    , base64-bytestring
     , bytestring
     , cereal
     , containers
@@ -71,6 +72,7 @@ library
     , haskeline
     , megaparsec
     , mtl
+    , random
     , servant-server
     , stm
     , text
@@ -117,6 +119,7 @@ test-suite minilang-test
     , aeson
     , async
     , base
+    , base64-bytestring
     , bytestring
     , containers
     , data-default
@@ -130,6 +133,7 @@ test-suite minilang-test
     , http-types
     , minilang
     , mtl
+    , random
     , stm
     , text
     , unix
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
diff --git a/lambda-calcul/haskell/test/Minilang/ServerSpec.hs b/lambda-calcul/haskell/test/Minilang/ServerSpec.hs
index 962dcdc..6a3b6d5 100644
--- a/lambda-calcul/haskell/test/Minilang/ServerSpec.hs
+++ b/lambda-calcul/haskell/test/Minilang/ServerSpec.hs
@@ -3,18 +3,25 @@
 
 module Minilang.ServerSpec where
 
-import Data.Aeson (FromJSON, eitherDecode)
+import Control.Concurrent.STM (newTVarIO)
+import Data.Aeson (FromJSON, eitherDecode, encode)
 import Data.ByteString (isInfixOf, toStrict)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base64.Lazy as Base64
+import Data.ByteString.Lazy (ByteString)
 import Data.Data (Proxy (..))
-import Minilang.API (Score)
+import Minilang.API (Score, User (..), newToken)
+import Minilang.App (Env (..))
 import Minilang.Server (serveAPI)
 import Network.Wai (Application)
+import Network.Wai.Test (SResponse)
+import System.Random (StdGen, mkStdGen64)
 import Test.Hspec (Spec, it)
-import Test.Hspec.Wai (get, matchBody, shouldRespondWith, with)
+import Test.Hspec.Wai (WaiSession, get, matchBody, post, request, shouldRespondWith, with)
 import Test.Hspec.Wai.Matcher (MatchBody (..))
 
 spec :: Spec
-spec = with app $ do
+spec = with (app testSeed) $ do
   it "GET / returns 'index.html'" $ do
     get "/"
       `shouldRespondWith` 200
@@ -28,6 +35,21 @@ spec = with app $ do
     get "/api/leaderboard"
       `shouldRespondWith` 200 {matchBody = arrayOfLengthOf (Proxy @Score) 2}
 
+  it "POST /api/register returns registration token given user is not registered" $ do
+    let token = "{\"token\":\"" <> Base64.encode (fst $ newToken testSeed) <> "\"}"
+    let user = encode $ User "alice"
+    postJSON "/api/register" user
+      `shouldRespondWith` 201
+        { matchBody = MatchBody $ \_ t ->
+            if t == token
+              then
+                Nothing
+              else Just ("Expected token " ++ show token ++ ", but got " ++ show t)
+        }
+
+postJSON :: BS.ByteString -> ByteString -> WaiSession () SResponse
+postJSON url = request "POST" url [("Content-Type", "application/json")]
+
 arrayOfLengthOf :: forall elem proxy. (FromJSON elem) => proxy elem -> Int -> MatchBody
 arrayOfLengthOf _ len = MatchBody $ \_ actual ->
   case eitherDecode actual of
@@ -37,5 +59,10 @@ arrayOfLengthOf _ len = MatchBody $ \_ actual ->
         else Just $ "Expected array of length " ++ show len ++ ", but got " ++ show (length scores)
     Left err -> Just $ "Failed to decode JSON: " ++ err
 
-app :: IO Application
-app = pure serveAPI
+app :: StdGen -> IO Application
+app g = do
+  env <- Env <$> newTVarIO g
+  pure $ serveAPI env
+
+testSeed :: StdGen
+testSeed = mkStdGen64 42