diff options
| -rw-r--r-- | lambda-calcul/haskell/src/Minilang/API.hs | 9 | ||||
| -rw-r--r-- | lambda-calcul/haskell/src/Minilang/App.hs | 40 | ||||
| -rw-r--r-- | lambda-calcul/haskell/src/Minilang/Server.hs | 16 | ||||
| -rw-r--r-- | lambda-calcul/haskell/test/Minilang/ServerSpec.hs | 36 |
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 |