1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
|
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Minilang.App where
import Control.Concurrent.STM (TVar, atomically, newTVarIO, readTVar, readTVarIO, writeTVar)
import Control.Exception (try)
import Control.Monad (when)
import Control.Monad.Catch (MonadThrow (throwM))
import Control.Monad.Except (ExceptT (..))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (MonadReader, ReaderT, ask, asks, runReaderT)
import qualified Data.ByteString.Base16 as Hex
import qualified Data.ByteString.Lazy as LBS
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text, pack)
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)
import Minilang.REPL.Purer (PurerEnv (..))
import Minilang.REPL.Types (In (..), Out (..), initialREPL)
import Network.Wai.Application.Static (defaultFileServerSettings, staticApp)
import Servant (ServerT, err400, 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]
}
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)
runApp :: Env -> AppM a -> Handler a
runApp env = Handler . ExceptT . try . flip runReaderT env . runAppM
lambdaApp :: (MonadIO m, MonadReader Env m) => ServerT LambdaAPI m
lambdaApp =
registerUser
:<|> getLeaderboard
:<|> getUser
:<|> getChallenge
:<|> postAnswer
:<|> Tagged staticResources
registerUser :: (MonadReader Env m, MonadIO m) => User -> m Token
registerUser user@(User name) = do
checkDuplicateUser name
token <- generateToken
asks users
>>= liftIO . atomically . \tvar -> do
usersMap <- readTVar tvar
let score = Score user 0 Nothing Nothing
updatedMap = Map.insert token score usersMap
writeTVar tvar updatedMap
pure token
checkDuplicateUser :: (MonadIO m, MonadReader Env m) => Text -> m ()
checkDuplicateUser name =
asks users >>= \user -> liftIO $ atomically $ do
usersMap <- readTVar user
when (isUserRegistered name usersMap) $
throwM $
err400 {errBody = "User already registered"}
isUserRegistered :: Text -> Map Token Score -> Bool
isUserRegistered name = Map.foldr (\Score {user = User {username}} acc -> username == name || acc) False
generateToken :: (MonadReader Env m, MonadIO m) => m Token
generateToken =
asks gen
>>= liftIO . atomically . \tvar -> do
genVal <- readTVar tvar
let (tokenBytes, newGen) = newToken genVal
writeTVar tvar newGen
pure $ Token $ decodeUtf8 $ Hex.encode $ LBS.toStrict tokenBytes
getLeaderboard :: (MonadIO m, MonadReader Env m) => m [Score]
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
checkUserToken token
getCurrentChallenge token
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"}
Just _ -> pure ()
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, 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
checkUserToken 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
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
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 $ challenges !! grade
-- | Serve static resources under `public/` directory
staticResources :: Application
staticResources = staticApp (defaultFileServerSettings "public")
|
