increase grade with succesful answer

3 files changed, 49 insertions, 16 deletions

diff --git a/lambda-calcul/haskell/src/Minilang/API.hs b/lambda-calcul/haskell/src/Minilang/API.hs
index 04eda7b..fffee7f 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 (FromHttpApiData, Get, JSON, QueryParam, Raw, ReqBody, StdMethod (POST), ToHttpApiData, Verb, parseUrlPiece, toUrlPiece, (:<|>), (:>), Post)
+import Servant (FromHttpApiData, Get, JSON, Post, QueryParam, Raw, ReqBody, StdMethod (POST), ToHttpApiData, Verb, parseUrlPiece, toUrlPiece, (:<|>), (:>))
 import System.Random (StdGen, uniformList)
 
 type LambdaAPI =
@@ -53,3 +53,10 @@ data Challenge = Challenge
     expr :: Text
   }
   deriving (Eq, Show, Generic, ToJSON, FromJSON)
+
+defaultChallenges :: [Challenge]
+defaultChallenges =
+  [ Challenge 0 "x",
+    Challenge 1 "y",
+    Challenge 2 "(lam (x) x)"
+  ]
diff --git a/lambda-calcul/haskell/src/Minilang/App.hs b/lambda-calcul/haskell/src/Minilang/App.hs
index 908e090..57c1fd6 100644
--- a/lambda-calcul/haskell/src/Minilang/App.hs
+++ b/lambda-calcul/haskell/src/Minilang/App.hs
@@ -31,14 +31,16 @@ import System.Random (StdGen)
 
 data Env = Env
   { gen :: TVar StdGen,
-    users :: TVar (Map Token Score)
+    users :: TVar (Map Token Score),
+    challenges :: [Challenge]
   }
 
-makeEnv :: StdGen -> IO Env
-makeEnv gen =
+makeEnv :: StdGen -> [Challenge] -> IO Env
+makeEnv gen challenges =
   Env
     <$> newTVarIO gen
     <*> newTVarIO mempty
+    <*> pure challenges
 
 newtype AppM a = AppM {runAppM :: ReaderT Env IO a}
   deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader Env)
@@ -95,9 +97,7 @@ 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 0 "x"
+  getCurrentChallenge token
 
 checkUserToken :: (MonadReader Env m, MonadIO m) => Token -> m ()
 checkUserToken token = do
@@ -106,8 +106,9 @@ checkUserToken token = do
     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 =
+updateUserLastTest :: (MonadIO m, MonadReader Env m) => Token -> m ()
+updateUserLastTest token = do
+  time <- liftIO getCurrentTime
   asks users >>= \user -> liftIO $ atomically $ do
     usersMap <- readTVar user
     case Map.lookup token usersMap of
@@ -121,25 +122,40 @@ postAnswer :: (MonadReader Env m, MonadIO m) => Maybe Token -> Text -> m ()
 postAnswer Nothing _ = liftIO $ throwM $ err400 {errBody = "Missing token"}
 postAnswer (Just token) expected = do
   checkUserToken token
+  updateUserLastTest token
   Challenge {expr} <- getCurrentChallenge token
   let PurerEnv {outputs} = withInputs initialREPL [In expr]
   case outputs of
-    [Bye, Evaluated ast _ _] ->
+    [Bye, Evaluated ast _ _] -> do
       when (pretty ast /= expected) $
         liftIO $
           throwM $
             err400 {errBody = "Incorrect answer"}
+      upgradeUserChallenge token
     [Bye, Msg msg] -> liftIO $ throwM $ err400 {errBody = "Evaluation error: " <> LBS.fromStrict (encodeUtf8 msg)}
     _ -> liftIO $ throwM $ err500 {errBody = "Unexpected REPL output: " <> LBS.fromStrict (encodeUtf8 (pack $ show outputs))}
 
-getCurrentChallenge :: (MonadIO m, MonadReader Env m) => Token -> m Challenge
-getCurrentChallenge token =
+upgradeUserChallenge :: (MonadIO m, MonadReader Env m) => Token -> m ()
+upgradeUserChallenge token = do
   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 {grade = succ (grade score)}
+            updatedMap = Map.insert token updatedScore usersMap
+        writeTVar user updatedMap
+
+
+getCurrentChallenge :: (MonadIO m, MonadReader Env m) => Token -> m Challenge
+getCurrentChallenge token = do
+  Env{users, challenges} <- ask
+  liftIO $ atomically $ do
+    usersMap <- readTVar users
+    case Map.lookup token usersMap of
       Nothing -> throwM $ err400 {errBody = "Cannot find challenge: Invalid token"}
       Just Score {grade} ->
-        pure $ Challenge grade "x" -- TODO: Return actual challenge based on grade
+        pure $ challenges !! grade
 
 -- | Serve static resources under `public/` directory
 staticResources :: Application
diff --git a/lambda-calcul/haskell/src/Minilang/Server.hs b/lambda-calcul/haskell/src/Minilang/Server.hs
index 6f820ed..8dc8c17 100644
--- a/lambda-calcul/haskell/src/Minilang/Server.hs
+++ b/lambda-calcul/haskell/src/Minilang/Server.hs
@@ -1,4 +1,6 @@
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 -- | An HTTP server providing a basic REPL and text editor to work
 -- collaboratively on Minilang code.
@@ -10,13 +12,13 @@ import Data.Aeson
   ( Value,
     decode,
     object,
-    (.=),
+    (.=), eitherDecodeFileStrict,
   )
 import Data.ByteString.Lazy (fromStrict)
 import Data.Data (Proxy (..))
 import Data.Default
 import Data.Text (Text)
-import Minilang.API (LambdaAPI)
+import Minilang.API (LambdaAPI, Challenge, defaultChallenges)
 import Minilang.App (Env (..), lambdaApp, runApp, makeEnv)
 import Minilang.Log
 import Minilang.REPL.Net
@@ -28,6 +30,7 @@ import Servant (hoistServer)
 import Servant.Server (serve)
 import System.Log.FastLogger (fromLogStr)
 import System.Random (newStdGen)
+import Control.Exception (IOException, try)
 
 data Server = Server
   { -- | If the server is running, this will contain the underlying
@@ -44,7 +47,8 @@ startServer serverPort = do
   envs <- newTVarIO mempty
   logger <- newLog "minilang"
   loggerMiddleware <- runHTTPLog logger
-  env <- newStdGen >>= makeEnv
+  challenges <- readChallenges
+  env <- newStdGen >>= (`makeEnv` challenges)
   let app =
         loggerMiddleware $
           runNetREPL logger envs (serveAPI env)
@@ -65,6 +69,12 @@ startServer serverPort = do
             destination = Callback (\str -> logInfo logger (decode @Value $ fromStrict $ fromLogStr str))
           }
 
+readChallenges :: IO [Challenge]
+readChallenges = do
+  eitherDecodeFileStrict "challenges.json" >>= \case
+    Right challenges -> pure challenges
+    Left _ -> pure defaultChallenges
+
 serveAPI :: Env -> Application
 serveAPI env =
   serve apiProxy $