3 files changed, 52 insertions, 11 deletions
diff --git a/lambda-calcul/haskell/src/Minilang/API.hs b/lambda-calcul/haskell/src/Minilang/API.hs
index c9cde53..04eda7b 100644
--- a/lambda-calcul/haskell/src/Minilang/API.hs
+++ b/lambda-calcul/haskell/src/Minilang/API.hs
@@ -16,9 +16,16 @@ 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, (:<|>), (:>))
+import Servant (FromHttpApiData, Get, JSON, QueryParam, Raw, ReqBody, StdMethod (POST), ToHttpApiData, Verb, parseUrlPiece, toUrlPiece, (:<|>), (:>), Post)
 import System.Random (StdGen, uniformList)
 
+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
+    :<|> "api" :> "challenge" :> QueryParam "token" Token :> ReqBody '[JSON] Text :> Post '[JSON] ()
+    :<|> Raw
+
 data Score = Score
   { user :: User,
     grade :: Int,
@@ -46,9 +53,3 @@ data Challenge = Challenge
     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 9d20260..908e090 100644
--- a/lambda-calcul/haskell/src/Minilang/App.hs
+++ b/lambda-calcul/haskell/src/Minilang/App.hs
@@ -15,13 +15,17 @@ import qualified Data.ByteString.Base64 as Base64
 import qualified Data.ByteString.Lazy as LBS
 import Data.Map (Map)
 import qualified Data.Map as Map
-import Data.Text (Text)
+import Data.Text (Text, pack)
 import Data.Text.Encoding (decodeUtf8, encodeUtf8)
 import qualified Data.Text.Lazy.Encoding as LT
 import Data.Time (UTCTime, getCurrentTime)
 import Minilang.API (Challenge (..), LambdaAPI, Score (..), Token (..), User (..), newToken)
+import Minilang.Lambda.Parser (pretty)
+import Minilang.REPL (withInputs)
+import Minilang.REPL.Purer (PurerEnv (..))
+import Minilang.REPL.Types (In (..), Out (..), initialREPL)
 import Network.Wai.Application.Static (defaultFileServerSettings, staticApp)
-import Servant (ServerT, err400, errBody, (:<|>) (..))
+import Servant (ServerT, err400, err500, errBody, (:<|>) (..))
 import Servant.Server (Application, Handler (..), Tagged (..))
 import System.Random (StdGen)
 
@@ -47,6 +51,7 @@ lambdaApp =
   registerUser
     :<|> getLeaderboard
     :<|> getChallenge
+    :<|> postAnswer
     :<|> Tagged staticResources
 
 registerUser :: (MonadReader Env m, MonadIO m) => User -> m Token
@@ -92,7 +97,7 @@ getChallenge (Just token) = do
   checkUserToken token
   now <- liftIO getCurrentTime
   updateUserLastTest token now
-  pure $ Challenge 1 "x"
+  pure $ Challenge 0 "x"
 
 checkUserToken :: (MonadReader Env m, MonadIO m) => Token -> m ()
 checkUserToken token = do
@@ -112,6 +117,30 @@ updateUserLastTest token time =
             updatedMap = Map.insert token updatedScore usersMap
         writeTVar user updatedMap
 
+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
+  Challenge {expr} <- getCurrentChallenge token
+  let PurerEnv {outputs} = withInputs initialREPL [In expr]
+  case outputs of
+    [Bye, Evaluated ast _ _] ->
+      when (pretty ast /= expected) $
+        liftIO $
+          throwM $
+            err400 {errBody = "Incorrect answer"}
+    [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 =
+  asks users >>= \user -> liftIO $ atomically $ do
+    usersMap <- readTVar user
+    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
+
 -- | 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 a7926d3..544d0b7 100644
--- a/lambda-calcul/haskell/test/Minilang/ServerSpec.hs
+++ b/lambda-calcul/haskell/test/Minilang/ServerSpec.hs
@@ -57,7 +57,7 @@ spec = with (app testSeed) $ do
       `shouldRespondWith` 400
 
   it "GET /api/challenge returns next challenge given user is registered" $ do
-    let expected = encode $ Challenge {level = 1, expr = "x"}
+    let expected = encode $ Challenge {level = 0, expr = "x"}
     postJSON "/api/register" alice
       `shouldRespondWith` 201
 
@@ -70,6 +70,17 @@ spec = with (app testSeed) $ do
               else Just ("Expected challenge " ++ show expected ++ ", but got " ++ show b)
         }
 
+  it "GET /api/challenge returns 400 given user is not registered" $
+    get ("/api/challenge?token=" <> LBS.toStrict token)
+      `shouldRespondWith` 400
+
+  it "POST /api/challenge returns 200 given challenge response is correct" $ do
+    let response = "\"x\""
+    void $ postJSON "/api/register" alice
+
+    postJSON ("/api/challenge?token=" <> LBS.toStrict token) response
+      `shouldRespondWith` 200
+
 postJSON :: BS.ByteString -> ByteString -> WaiSession () SResponse
 postJSON url = request "POST" url [("Content-Type", "application/json")]