diff options
Diffstat (limited to 'lambda-calcul/haskell/src/Minilang')
| -rw-r--r-- | lambda-calcul/haskell/src/Minilang/API.hs | 4 | ||||
| -rw-r--r-- | lambda-calcul/haskell/src/Minilang/App.hs | 53 | ||||
| -rw-r--r-- | lambda-calcul/haskell/src/Minilang/Server.hs | 9 |
3 files changed, 44 insertions, 22 deletions
diff --git a/lambda-calcul/haskell/src/Minilang/API.hs b/lambda-calcul/haskell/src/Minilang/API.hs index fffee7f..8082ac8 100644 --- a/lambda-calcul/haskell/src/Minilang/API.hs +++ b/lambda-calcul/haskell/src/Minilang/API.hs @@ -22,6 +22,7 @@ import System.Random (StdGen, uniformList) type LambdaAPI = "api" :> "register" :> ReqBody '[JSON] User :> Verb 'POST 201 '[JSON] Token :<|> "api" :> "leaderboard" :> Get '[JSON] [Score] + :<|> "api" :> "score" :> QueryParam "token" Token :> Get '[JSON] Score :<|> "api" :> "challenge" :> QueryParam "token" Token :> Get '[JSON] Challenge :<|> "api" :> "challenge" :> QueryParam "token" Token :> ReqBody '[JSON] Text :> Post '[JSON] () :<|> Raw @@ -29,7 +30,8 @@ type LambdaAPI = data Score = Score { user :: User, grade :: Int, - lastTest :: Maybe UTCTime + lastTest :: Maybe UTCTime, + lastResult :: Maybe Bool } deriving (Eq, Show, Generic, ToJSON, FromJSON) diff --git a/lambda-calcul/haskell/src/Minilang/App.hs b/lambda-calcul/haskell/src/Minilang/App.hs index 175edcb..9086d27 100644 --- a/lambda-calcul/haskell/src/Minilang/App.hs +++ b/lambda-calcul/haskell/src/Minilang/App.hs @@ -17,8 +17,7 @@ import Data.Map (Map) import qualified Data.Map as Map 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 Data.Time (getCurrentTime) import Minilang.API (Challenge (..), LambdaAPI, Score (..), Token (..), User (..), newToken) import Minilang.Lambda.Parser (pretty) import Minilang.REPL (withInputs) @@ -52,6 +51,7 @@ lambdaApp :: (MonadIO m, MonadReader Env m) => ServerT LambdaAPI m lambdaApp = registerUser :<|> getLeaderboard + :<|> getUser :<|> getChallenge :<|> postAnswer :<|> Tagged staticResources @@ -63,7 +63,7 @@ registerUser user@(User name) = do asks users >>= liftIO . atomically . \tvar -> do usersMap <- readTVar tvar - let score = Score user 0 Nothing + let score = Score user 0 Nothing Nothing updatedMap = Map.insert token score usersMap writeTVar tvar updatedMap pure token @@ -93,6 +93,13 @@ getLeaderboard = do usersMap <- asks users >>= liftIO . readTVarIO pure $ Map.elems usersMap +getUser :: (MonadIO m, MonadReader Env m) => Maybe Token -> m Score +getUser mToken = do + usersMap <- asks users >>= liftIO . readTVarIO + case mToken >>= (`Map.lookup` usersMap) of + Nothing -> liftIO $ throwM $ err400 {errBody = "User does not exist"} + Just score -> pure score + getChallenge :: (MonadReader Env m, MonadIO m) => Maybe Token -> m Challenge getChallenge Nothing = liftIO $ throwM $ err400 {errBody = "Missing token"} getChallenge (Just token) = do @@ -106,15 +113,15 @@ 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 -> m () -updateUserLastTest token = do +updateUserLastTest :: (MonadIO m, MonadReader Env m) => Token -> TestResult -> m () +updateUserLastTest token result = do time <- liftIO getCurrentTime 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} + let updatedScore = score {lastTest = Just time, lastResult = Just (isSuccess result)} updatedMap = Map.insert token updatedScore usersMap writeTVar user updatedMap @@ -122,18 +129,33 @@ 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] + result = evaluateOutputs outputs expected + updateUserLastTest token result + case result of + TestSucceeded -> do + upgradeUserChallenge token + TestFailed msg -> + liftIO $ throwM $ err400 {errBody = "Test failed: " <> LBS.fromStrict (encodeUtf8 msg)} + TestErrored msg -> do + liftIO $ throwM $ err500 {errBody = "Error evaluating answer: " <> LBS.fromStrict (encodeUtf8 msg)} + +data TestResult = TestSucceeded | TestFailed Text | TestErrored Text + +isSuccess :: TestResult -> Bool +isSuccess TestSucceeded = True +isSuccess _ = False + +evaluateOutputs :: [Out] -> Text -> TestResult +evaluateOutputs outputs expected = case outputs of [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))} + if pretty ast /= expected + then TestFailed "Incorrect result" + else TestSucceeded + [Bye, Msg msg] -> TestFailed msg + _ -> TestErrored $ pack $ show outputs upgradeUserChallenge :: (MonadIO m, MonadReader Env m) => Token -> m () upgradeUserChallenge token = do @@ -146,10 +168,9 @@ upgradeUserChallenge token = do 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 + Env {users, challenges} <- ask liftIO $ atomically $ do usersMap <- readTVar users case Map.lookup token usersMap of diff --git a/lambda-calcul/haskell/src/Minilang/Server.hs b/lambda-calcul/haskell/src/Minilang/Server.hs index 7cf5718..67b321d 100644 --- a/lambda-calcul/haskell/src/Minilang/Server.hs +++ b/lambda-calcul/haskell/src/Minilang/Server.hs @@ -8,14 +8,16 @@ module Minilang.Server where import Control.Concurrent.Async import Control.Concurrent.STM.TVar +import Control.Exception (try) import Data.Aeson ( Value, decode, - eitherDecodeFileStrict, + eitherDecode, object, - (.=), eitherDecode, + (.=), ) import Data.ByteString.Lazy (fromStrict) +import qualified Data.ByteString.Lazy as LBS import Data.Data (Proxy (..)) import Data.Default import Data.Text (Text) @@ -31,8 +33,6 @@ import Servant (hoistServer) import Servant.Server (serve) import System.Log.FastLogger (fromLogStr) import System.Random (newStdGen) -import Control.Exception (try) -import qualified Data.ByteString.Lazy as LBS data Server = Server { -- | If the server is running, this will contain the underlying @@ -80,7 +80,6 @@ readChallenges = do Right challenges -> pure challenges Left _ -> pure defaultChallenges - serveAPI :: Env -> Application serveAPI env = serve apiProxy $ |