post correct challenge response

1 files changed, 32 insertions, 3 deletions

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")