From db4ecd7a93086585937b9b45970f4f4c4e1838a3 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Tue, 4 Nov 2025 21:52:15 +0100 Subject: Register user and return random token --- lambda-calcul/haskell/minilang.cabal | 4 ++ lambda-calcul/haskell/src/Minilang/API.hs | 24 ++++++++++- lambda-calcul/haskell/src/Minilang/App.hs | 50 +++++++++++++++++++---- lambda-calcul/haskell/src/Minilang/Server.hs | 18 ++++---- lambda-calcul/haskell/test/Minilang/ServerSpec.hs | 39 +++++++++++++++--- 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 -- cgit v1.3.1