From 8a2727a05e0b61d300bb46e8e913c9e60ebd6328 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Tue, 4 Nov 2025 22:49:12 +0100 Subject: Can retrieve first challenge when registered --- lambda-calcul/haskell/src/Minilang/API.hs | 19 +++++- lambda-calcul/haskell/src/Minilang/App.hs | 72 +++++++++++++++++------ lambda-calcul/haskell/test/Minilang/ServerSpec.hs | 38 ++++++++---- 3 files changed, 98 insertions(+), 31 deletions(-) (limited to 'lambda-calcul/haskell') diff --git a/lambda-calcul/haskell/src/Minilang/API.hs b/lambda-calcul/haskell/src/Minilang/API.hs index e9eef6a..c9cde53 100644 --- a/lambda-calcul/haskell/src/Minilang/API.hs +++ b/lambda-calcul/haskell/src/Minilang/API.hs @@ -16,7 +16,7 @@ import qualified Data.ByteString.Lazy as LBS import Data.Text (Text) import Data.Time (UTCTime) import GHC.Generics (Generic) -import Servant (Get, JSON, Raw, ReqBody, StdMethod (POST), Verb, (:<|>), (:>)) +import Servant (FromHttpApiData, Get, JSON, QueryParam, Raw, ReqBody, StdMethod (POST), ToHttpApiData, Verb, parseUrlPiece, toUrlPiece, (:<|>), (:>)) import System.Random (StdGen, uniformList) data Score = Score @@ -29,13 +29,26 @@ data Score = Score newtype User = User {username :: Text} deriving newtype (Eq, Show, ToJSON, FromJSON) -data Token = Token {token :: Text} - deriving (Eq, Show, Generic, ToJSON, FromJSON) +newtype Token = Token {unToken :: Text} + deriving newtype (Eq, Ord, Show, ToJSON, FromJSON) + +instance ToHttpApiData Token where + toUrlPiece (Token t) = t + +instance FromHttpApiData Token where + parseUrlPiece t = Right (Token t) newToken :: StdGen -> (ByteString, StdGen) newToken = first LBS.pack . uniformList 16 +data Challenge = Challenge + { level :: Int, + expr :: Text + } + deriving (Eq, Show, Generic, ToJSON, FromJSON) + type LambdaAPI = "api" :> "register" :> ReqBody '[JSON] User :> Verb 'POST 201 '[JSON] Token :<|> "api" :> "leaderboard" :> Get '[JSON] [Score] + :<|> "api" :> "challenge" :> QueryParam "token" Token :> Get '[JSON] Challenge :<|> Raw diff --git a/lambda-calcul/haskell/src/Minilang/App.hs b/lambda-calcul/haskell/src/Minilang/App.hs index dae6b65..9d20260 100644 --- a/lambda-calcul/haskell/src/Minilang/App.hs +++ b/lambda-calcul/haskell/src/Minilang/App.hs @@ -1,10 +1,12 @@ {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Minilang.App where -import Control.Concurrent.STM (TVar, atomically, newTVarIO, readTVar, writeTVar) +import Control.Concurrent.STM (TVar, atomically, newTVarIO, readTVar, readTVarIO, writeTVar) import Control.Exception (try) +import Control.Monad (when) import Control.Monad.Catch (MonadThrow (throwM)) import Control.Monad.Except (ExceptT (..)) import Control.Monad.IO.Class (MonadIO, liftIO) @@ -15,16 +17,17 @@ 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 qualified Data.Text.Lazy.Encoding as LT +import Data.Time (UTCTime, getCurrentTime) +import Minilang.API (Challenge (..), LambdaAPI, Score (..), Token (..), User (..), newToken) import Network.Wai.Application.Static (defaultFileServerSettings, staticApp) import Servant (ServerT, err400, errBody, (:<|>) (..)) -import Servant.Server (Application, Handler (..), Server, Tagged (..)) +import Servant.Server (Application, Handler (..), Tagged (..)) import System.Random (StdGen) data Env = Env { gen :: TVar StdGen, - users :: TVar (Map Text Score) + users :: TVar (Map Token Score) } makeEnv :: StdGen -> IO Env @@ -43,37 +46,72 @@ lambdaApp :: (MonadIO m, MonadReader Env m) => ServerT LambdaAPI m lambdaApp = registerUser :<|> getLeaderboard + :<|> getChallenge :<|> Tagged staticResources registerUser :: (MonadReader Env m, MonadIO m) => User -> m Token registerUser user@(User name) = do + checkDuplicateUser name + token <- generateToken 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 + let score = Score user 0 Nothing + updatedMap = Map.insert token score usersMap + writeTVar tvar updatedMap + pure token + +checkDuplicateUser :: (MonadIO m, MonadReader Env m) => Text -> m () +checkDuplicateUser name = + asks users >>= \user -> liftIO $ atomically $ do + usersMap <- readTVar user + when (isUserRegistered name usersMap) $ + throwM $ + err400 {errBody = "User already registered"} + +isUserRegistered :: Text -> Map Token Score -> Bool +isUserRegistered name = Map.foldr (\Score {user = User {username}} acc -> username == name || acc) False + +generateToken :: (MonadReader Env m, MonadIO m) => m Token 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 + pure $ Token $ decodeUtf8 $ Base64.encode $ LBS.toStrict tokenBytes getLeaderboard :: (MonadIO m) => m [Score] getLeaderboard = do now <- liftIO getCurrentTime pure [Score (User "Alice") 95 (Just now), Score (User "Bob") 88 (Just now)] +getChallenge :: (MonadReader Env m, MonadIO m) => Maybe Token -> m Challenge +getChallenge Nothing = liftIO $ throwM $ err400 {errBody = "Missing token"} +getChallenge (Just token) = do + checkUserToken token + now <- liftIO getCurrentTime + updateUserLastTest token now + pure $ Challenge 1 "x" + +checkUserToken :: (MonadReader Env m, MonadIO m) => Token -> m () +checkUserToken token = do + usersMap <- asks users >>= liftIO . readTVarIO + case Map.lookup token usersMap of + Nothing -> liftIO $ throwM $ err400 {errBody = "Token " <> LBS.fromStrict (encodeUtf8 (unToken token)) <> " does not exist"} + Just _ -> pure () + +updateUserLastTest :: (MonadIO m, MonadReader Env m) => Token -> UTCTime -> m () +updateUserLastTest token time = + asks users >>= \user -> liftIO $ atomically $ do + usersMap <- readTVar user + case Map.lookup token usersMap of + Nothing -> throwM $ err400 {errBody = "Cannot update last test: Invalid token"} + Just score -> do + let updatedScore = score {lastTest = Just time} + updatedMap = Map.insert token updatedScore usersMap + writeTVar user updatedMap + -- | Serve static resources under `public/` directory staticResources :: Application staticResources = staticApp (defaultFileServerSettings "public") diff --git a/lambda-calcul/haskell/test/Minilang/ServerSpec.hs b/lambda-calcul/haskell/test/Minilang/ServerSpec.hs index 33fbd69..a7926d3 100644 --- a/lambda-calcul/haskell/test/Minilang/ServerSpec.hs +++ b/lambda-calcul/haskell/test/Minilang/ServerSpec.hs @@ -3,26 +3,30 @@ module Minilang.ServerSpec where -import Control.Concurrent.STM (newTVarIO) import Control.Monad (void) 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 qualified Data.ByteString.Lazy as LBS import Data.Data (Proxy (..)) -import Minilang.API (Score, User (..), newToken) -import Minilang.App (Env (..), makeEnv) +import Data.Text.Lazy.Encoding (decodeUtf8) +import Minilang.API (Challenge (..), Score, User (..), newToken) +import Minilang.App (makeEnv) 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 (WaiSession, get, matchBody, post, request, shouldRespondWith, with) +import Test.Hspec.Wai (WaiSession, get, matchBody, request, shouldRespondWith, with) import Test.Hspec.Wai.Matcher (MatchBody (..)) spec :: Spec spec = with (app testSeed) $ do + let token = Base64.encode (fst $ newToken testSeed) + alice = encode $ User "alice" + it "GET / returns 'index.html'" $ do get "/" `shouldRespondWith` 200 @@ -37,23 +41,35 @@ spec = with (app testSeed) $ do `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 + postJSON "/api/register" alice `shouldRespondWith` 201 { matchBody = MatchBody $ \_ t -> - if t == token + if t == encode (decodeUtf8 token) then Nothing else Just ("Expected token " ++ show token ++ ", but got " ++ show t) } it "POST /api/register returns 400 given user is already registered" $ do - let user = encode $ User "alice" - void $ postJSON "/api/register" user - postJSON "/api/register" user + void $ postJSON "/api/register" alice + + postJSON "/api/register" alice `shouldRespondWith` 400 + it "GET /api/challenge returns next challenge given user is registered" $ do + let expected = encode $ Challenge {level = 1, expr = "x"} + postJSON "/api/register" alice + `shouldRespondWith` 201 + + get ("/api/challenge?token=" <> LBS.toStrict token) + `shouldRespondWith` 200 + { matchBody = MatchBody $ \_ b -> + if b == expected + then + Nothing + else Just ("Expected challenge " ++ show expected ++ ", but got " ++ show b) + } + postJSON :: BS.ByteString -> ByteString -> WaiSession () SResponse postJSON url = request "POST" url [("Content-Type", "application/json")] -- cgit v1.3.1