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
|
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
module Minilang.App where
import Control.Concurrent.STM (TVar, atomically, newTVarIO, readTVar, writeTVar)
import Control.Exception (try)
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.Base64 as Base64
import qualified Data.ByteString.Lazy as LBS
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Time (getCurrentTime)
import Minilang.API (LambdaAPI, Score (..), Token (..), User (..), newToken)
import Network.Wai.Application.Static (defaultFileServerSettings, staticApp)
import Servant (ServerT, err400, errBody, (:<|>) (..))
import Servant.Server (Application, Handler (..), Server, Tagged (..))
import System.Random (StdGen)
data Env = Env
{ gen :: TVar StdGen,
users :: TVar (Map Text Score)
}
makeEnv :: StdGen -> IO Env
makeEnv gen =
Env
<$> newTVarIO gen
<*> newTVarIO mempty
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
:<|> Tagged staticResources
registerUser :: (MonadReader Env m, MonadIO m) => User -> m Token
registerUser user@(User name) = do
asks users
>>= liftIO . atomically . \tvar -> do
usersMap <- readTVar tvar
case Map.lookup name usersMap of
Just _ -> throwM $ err400 {errBody = "User already registered"}
Nothing -> do
let score = Score user 0 Nothing
let updatedMap = Map.insert name score usersMap
writeTVar tvar updatedMap
bytes <- generateToken
let tokenText = bytes
pure $ Token tokenText
generateToken :: (MonadReader Env m, MonadIO m) => m Text
generateToken =
asks gen
>>= liftIO . atomically . \tvar -> do
genVal <- readTVar tvar
let (tokenBytes, newGen) = newToken genVal
writeTVar tvar newGen
pure $ decodeUtf8 $ Base64.encode $ LBS.toStrict tokenBytes
getLeaderboard :: (MonadIO m) => m [Score]
getLeaderboard = do
now <- liftIO getCurrentTime
pure [Score (User "Alice") 95 (Just now), Score (User "Bob") 88 (Just now)]
-- | Serve static resources under `public/` directory
staticResources :: Application
staticResources = staticApp (defaultFileServerSettings "public")
|
