Can retrieve first challenge when registered

2 files changed, 70 insertions, 19 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")