Can retrieve first challenge when registered

3 files changed, 97 insertions, 30 deletions

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
+      let score = Score user 0 Nothing
+          updatedMap = Map.insert token score usersMap
+      writeTVar tvar updatedMap
+  pure token
 
-generateToken :: (MonadReader Env m, MonadIO m) => m Text
+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")]