summaryrefslogtreecommitdiff
path: root/lambda-calcul/haskell
diff options
context:
space:
mode:
Diffstat (limited to 'lambda-calcul/haskell')
-rw-r--r--lambda-calcul/haskell/public/leaderboard.js8
-rw-r--r--lambda-calcul/haskell/src/Minilang/API.hs4
-rw-r--r--lambda-calcul/haskell/src/Minilang/App.hs53
-rw-r--r--lambda-calcul/haskell/src/Minilang/Server.hs9
-rw-r--r--lambda-calcul/haskell/test/Minilang/ServerSpec.hs49
5 files changed, 99 insertions, 24 deletions
diff --git a/lambda-calcul/haskell/public/leaderboard.js b/lambda-calcul/haskell/public/leaderboard.js
index 6162b4d..15b5b42 100644
--- a/lambda-calcul/haskell/public/leaderboard.js
+++ b/lambda-calcul/haskell/public/leaderboard.js
@@ -9,11 +9,17 @@ const updateLeaderboard = () => {
.then(response => response.json())
.then(data => {
const tbody = document.querySelector('table#leaderboard > tbody');
- data.sort((a, b) => a.grade - b.grade);
+ data.sort((a, b) => b.grade - a.grade);
data.forEach((entry, index) => {
const row = document.createElement('tr');
+ if(entry.lastResult) {
+ row.classList.add('success');
+ } else if (!entry.lastResult && entry.lastTest){
+ row.classList.add('fail');
+ }
+
const nameCell = document.createElement('td');
nameCell.textContent = entry.user;
row.appendChild(nameCell);
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 $
diff --git a/lambda-calcul/haskell/test/Minilang/ServerSpec.hs b/lambda-calcul/haskell/test/Minilang/ServerSpec.hs
index fdf1389..e109977 100644
--- a/lambda-calcul/haskell/test/Minilang/ServerSpec.hs
+++ b/lambda-calcul/haskell/test/Minilang/ServerSpec.hs
@@ -15,7 +15,7 @@ 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 (..), defaultChallenges, newToken)
+import Minilang.API (Challenge (..), Score (..), User (..), defaultChallenges, newToken)
import Minilang.App (makeEnv)
import Minilang.Server (serveAPI)
import Network.Wai (Application)
@@ -121,6 +121,53 @@ spec = with (app testSeed) $ do
get ("/api/challenge?token=" <> LBS.toStrict token)
`shouldRespondWith` fromString expected
+ it "GET /api/score returns user current score" $ do
+ void $ postJSON "/api/register" alice
+ get ("/api/score?token=" <> LBS.toStrict token)
+ `shouldRespondWith` 200
+ { matchBody = MatchBody $ \_ actual ->
+ case eitherDecode actual of
+ Right (score :: Score) ->
+ if score == Score {user = User "alice", grade = 0, lastTest = Nothing, lastResult = Nothing}
+ then Nothing
+ else Just $ "Expected score with grade 0, but got " ++ show score
+ Left err -> Just $ "Failed to decode JSON: " ++ err
+ }
+
+ it "GET /api/score returns 400 given token is not registered" $ do
+ get ("/api/score?token=" <> LBS.toStrict token)
+ `shouldRespondWith` 400
+
+ it "GET /api/score returns score with success given last challenge succeeded" $ do
+ void $ postJSON "/api/register" alice
+ void $ postJSON ("/api/challenge?token=" <> LBS.toStrict token) "\"x\""
+
+ get ("/api/score?token=" <> LBS.toStrict token)
+ `shouldRespondWith` 200
+ { matchBody = MatchBody $ \_ actual ->
+ case eitherDecode actual of
+ Right (score :: Score) ->
+ if lastResult score == Just True
+ then Nothing
+ else Just $ "Expected score with success, but got " ++ show score
+ Left err -> Just $ "Failed to decode JSON: " ++ err
+ }
+
+ it "GET /api/score returns score with failure given last challenge failed" $ do
+ void $ postJSON "/api/register" alice
+ void $ postJSON ("/api/challenge?token=" <> LBS.toStrict token) "\"y\""
+
+ get ("/api/score?token=" <> LBS.toStrict token)
+ `shouldRespondWith` 200
+ { matchBody = MatchBody $ \_ actual ->
+ case eitherDecode actual of
+ Right (score :: Score) ->
+ if lastResult score == Just False
+ then Nothing
+ else Just $ "Expected score with failure, but got " ++ show score
+ Left err -> Just $ "Failed to decode JSON: " ++ err
+ }
+
postJSON :: BS.ByteString -> ByteString -> WaiSession () SResponse
postJSON url = request "POST" url [("Content-Type", "application/json")]
generated by cgit v1.3.1 (git 2.54.0) at 2026-10-24 04:25:31 +0000