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
|
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
module Minilang.App where
import Control.Concurrent.STM (TVar, atomically, readTVar, writeTVar)
import Control.Exception (try)
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.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, (:<|>) (..))
import Servant.Server (Application, Handler (..), Server, Tagged (..))
import System.Random (StdGen)
data Env = Env
{ gen :: TVar StdGen
}
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 _name) = do
bytes <-
asks gen
>>= liftIO . atomically . \tvar -> do
genVal <- readTVar tvar
let (tokenBytes, newGen) = newToken genVal
writeTVar tvar newGen
pure $ LBS.toStrict tokenBytes
let tokenText = decodeUtf8 $ Base64.encode bytes
pure $ Token tokenText
getLeaderboard :: (MonadIO m) => m [Score]
getLeaderboard = do
now <- liftIO getCurrentTime
pure [Score "Alice" 95 now, Score "Bob" 88 now]
-- | Serve static resources under `public/` directory
staticResources :: Application
staticResources = staticApp (defaultFileServerSettings "public")
|
