diff options
Diffstat (limited to 'lambda-calcul/haskell/src/Minilang/App.hs')
| -rw-r--r-- | lambda-calcul/haskell/src/Minilang/App.hs | 68 |
1 files changed, 34 insertions, 34 deletions
diff --git a/lambda-calcul/haskell/src/Minilang/App.hs b/lambda-calcul/haskell/src/Minilang/App.hs index 0174547..4340708 100644 --- a/lambda-calcul/haskell/src/Minilang/App.hs +++ b/lambda-calcul/haskell/src/Minilang/App.hs @@ -20,19 +20,19 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Time (getCurrentTime) import Minilang.API (Challenge (..), LambdaAPI, Score (..), Token (..), User (..), newToken) import Minilang.Lambda.Parser (pretty) -import Minilang.REPL (withInputs, replEnvWith) +import Minilang.REPL (replEnvWith, withInputs) import Minilang.REPL.Purer (PurerEnv (..)) -import Minilang.REPL.Types (Command (..), Content (..), Evaluator (..), In (..), Out (..), initialREPL) +import Minilang.REPL.Types (Command (..), Content (..), Evaluator (..), In (..), Out (..)) import Network.Wai.Application.Static (defaultFileServerSettings, staticApp) -import Servant (ServerT, err400, err500, errBody, (:<|>) (..), err404) +import Servant (ServerT, err400, err404, err500, errBody, (:<|>) (..)) import Servant.Server (Application, Handler (..), Tagged (..)) import System.Random (StdGen) data Env = Env - { gen :: TVar StdGen, - users :: TVar (Map Token Score), - challenges :: [Challenge], - evaluator :: Evaluator + { gen :: TVar StdGen + , users :: TVar (Map Token Score) + , challenges :: [Challenge] + , evaluator :: Evaluator } makeEnv :: StdGen -> [Challenge] -> Evaluator -> IO Env @@ -72,7 +72,7 @@ registerUser user@(User name) = do pure token unregisterUser :: (MonadReader Env m, MonadIO m) => Maybe Token -> m Score -unregisterUser Nothing = liftIO $ throwM $ err400 {errBody = "Missing token"} +unregisterUser Nothing = liftIO $ throwM $ err400{errBody = "Missing token"} unregisterUser (Just token) = do checkUserToken token score <- @@ -84,7 +84,7 @@ unregisterUser (Just token) = do writeTVar tvar updatedMap pure score case score of - Nothing -> liftIO $ throwM $ err400 {errBody = "User does not exist"} + Nothing -> liftIO $ throwM $ err400{errBody = "User does not exist"} Just s -> pure s checkDuplicateUser :: (MonadIO m, MonadReader Env m) => Text -> m () @@ -93,10 +93,10 @@ checkDuplicateUser name = usersMap <- readTVar user when (isUserRegistered name usersMap) $ throwM $ - err400 {errBody = "User already registered"} + err400{errBody = "User already registered"} isUserRegistered :: Text -> Map Token Score -> Bool -isUserRegistered name = Map.foldr (\Score {user = User {username}} acc -> username == name || acc) False +isUserRegistered name = Map.foldr (\Score{user = User{username}} acc -> username == name || acc) False generateToken :: (MonadReader Env m, MonadIO m) => m Token generateToken = @@ -116,11 +116,11 @@ 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 $ err404 {errBody = "User does not exist"} + Nothing -> liftIO $ throwM $ err404{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 Nothing = liftIO $ throwM $ err400{errBody = "Missing token"} getChallenge (Just token) = do checkUserToken token getCurrentChallenge token @@ -129,7 +129,7 @@ checkUserToken :: (MonadReader Env m, MonadIO m) => Token -> m () checkUserToken token = do usersMap <- asks users >>= liftIO . readTVarIO case Map.lookup token usersMap of - Nothing -> liftIO $ throwM $ err400 {errBody = "Token " <> LBS.fromStrict (encodeUtf8 (unToken token)) <> " does not exist"} + Nothing -> liftIO $ throwM $ err400{errBody = "Token " <> LBS.fromStrict (encodeUtf8 (unToken token)) <> " does not exist"} Just _ -> pure () updateUserLastTest :: (MonadIO m, MonadReader Env m) => Token -> TestResult -> m () @@ -138,28 +138,28 @@ updateUserLastTest token result = 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"} + Nothing -> throwM $ err400{errBody = "Cannot update last test: Invalid token"} Just score -> do - let updatedScore = score {lastTest = Just time, lastResult = Just (isSuccess result)} + let updatedScore = score{lastTest = Just time, lastResult = Just (isSuccess result)} 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 +postAnswer Nothing _ = liftIO $ throwM $ err400{errBody = "Missing token"} +postAnswer (Just token) answer = do checkUserToken token - Challenge {expr} <- getCurrentChallenge token + Challenge{level, expr} <- getCurrentChallenge token ev <- asks evaluator - let PurerEnv {outputs} = withInputs (replEnvWith ev) [Com (Load (Data expr))] - result = evaluateOutputs outputs expected + let PurerEnv{outputs} = withInputs (replEnvWith ev) [Com (Load (Data expr))] + result = evaluateAnswer level outputs answer updateUserLastTest token result case result of TestSucceeded -> upgradeUserChallenge token TestFailed msg -> - liftIO $ throwM $ err400 {errBody = "Test failed: " <> LBS.fromStrict (encodeUtf8 msg)} + liftIO $ throwM $ err400{errBody = "Test failed: " <> LBS.fromStrict (encodeUtf8 msg)} TestErrored msg -> - liftIO $ throwM $ err500 {errBody = "Error evaluating answer: " <> LBS.fromStrict (encodeUtf8 msg)} + liftIO $ throwM $ err500{errBody = "Error evaluating answer: " <> LBS.fromStrict (encodeUtf8 msg)} data TestResult = TestSucceeded | TestFailed Text | TestErrored Text @@ -167,17 +167,17 @@ isSuccess :: TestResult -> Bool isSuccess TestSucceeded = True isSuccess _ = False -evaluateOutputs :: [Out] -> Text -> TestResult -evaluateOutputs outputs expected = +evaluateAnswer :: Int -> [Out] -> Text -> TestResult +evaluateAnswer grade outputs answer = case outputs of [Bye, Evaluated ast _ _] -> - if pretty ast /= expected - then TestFailed "Incorrect result" + if pretty ast /= answer + then TestFailed $ "Incorrect result for question " <> pack (show grade) <> " got " <> answer <> ", try again" else TestSucceeded [Bye] -> - if expected == "" + if answer == "" then TestSucceeded - else TestFailed "Incorrect result" + else TestFailed $ "Incorrect result for question " <> pack (show grade) <> " got " <> answer <> ", try again" [Bye, Msg msg] -> TestFailed msg _ -> TestErrored $ pack $ show outputs @@ -186,20 +186,20 @@ 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"} + Nothing -> throwM $ err400{errBody = "Cannot update last test: Invalid token"} Just score -> do - let updatedScore = score {grade = succ (grade score)} + 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 + 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} -> + Nothing -> throwM $ err400{errBody = "Cannot find challenge: Invalid token"} + Just Score{grade} -> pure $ challenges !! grade -- | Serve static resources under `public/` directory |