increase grade with succesful answer

4 files changed, 74 insertions, 27 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 $
diff --git a/lambda-calcul/haskell/test/Minilang/ServerSpec.hs b/lambda-calcul/haskell/test/Minilang/ServerSpec.hs
index d2a95d1..50c1590 100644
--- a/lambda-calcul/haskell/test/Minilang/ServerSpec.hs
+++ b/lambda-calcul/haskell/test/Minilang/ServerSpec.hs
@@ -5,14 +5,17 @@ module Minilang.ServerSpec where
 
 import Control.Monad (void)
 import Data.Aeson (FromJSON, eitherDecode, encode)
+import Data.Bifunctor (first)
 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 Data.String (fromString)
+import qualified Data.Text.Lazy as LT
 import Data.Text.Lazy.Encoding (decodeUtf8)
-import Minilang.API (Challenge (..), Score, User (..), newToken)
+import Minilang.API (Challenge (..), Score, User (..), defaultChallenges, newToken)
 import Minilang.App (makeEnv)
 import Minilang.Server (serveAPI)
 import Network.Wai (Application)
@@ -21,7 +24,6 @@ import System.Random (StdGen, mkStdGen64)
 import Test.Hspec (Spec, it)
 import Test.Hspec.Wai (WaiSession, get, matchBody, request, shouldRespondWith, with)
 import Test.Hspec.Wai.Matcher (MatchBody (..))
-import Data.Bifunctor (first)
 
 spec :: Spec
 spec = with (app testSeed) $ do
@@ -58,18 +60,12 @@ spec = with (app testSeed) $ do
       `shouldRespondWith` 400
 
   it "GET /api/challenge returns next challenge given user is registered" $ do
-    let expected = encode $ Challenge {level = 0, expr = "x"}
+    let expected = LT.unpack $ decodeUtf8 $ encode $ Challenge {level = 0, 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)
-        }
+      `shouldRespondWith` fromString expected
 
   it "GET /api/challenge returns 400 given user is not registered" $
     get ("/api/challenge?token=" <> LBS.toStrict token)
@@ -102,6 +98,24 @@ spec = with (app testSeed) $ do
     postJSON ("/api/challenge?token=" <> LBS.toStrict otherToken) response
       `shouldRespondWith` 400
 
+  it "GET /api/challenge returns next level challenge after successful POST" $ do
+    let expected = LT.unpack $ decodeUtf8 $ encode $ Challenge {level = 1, expr = "y"}
+
+    void $ postJSON "/api/register" alice
+    void $ postJSON ("/api/challenge?token=" <> LBS.toStrict token) "\"x\""
+
+    get ("/api/challenge?token=" <> LBS.toStrict token)
+      `shouldRespondWith` fromString expected
+
+  it "GET /api/challenge returns same challenge after failed POST" $ do
+    let expected = LT.unpack $ decodeUtf8 $ encode $ head defaultChallenges
+
+    void $ postJSON "/api/register" alice
+    void $ postJSON ("/api/challenge?token=" <> LBS.toStrict token) "\"y\""
+
+    get ("/api/challenge?token=" <> LBS.toStrict token)
+      `shouldRespondWith` fromString expected
+
 postJSON :: BS.ByteString -> ByteString -> WaiSession () SResponse
 postJSON url = request "POST" url [("Content-Type", "application/json")]
 
@@ -116,7 +130,7 @@ arrayOfLengthOf _ len = MatchBody $ \_ actual ->
 
 app :: StdGen -> IO Application
 app g = do
-  env <- makeEnv g
+  env <- makeEnv g defaultChallenges
   pure $ serveAPI env
 
 testSeed :: StdGen