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
|
{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-}
-- An example of embedding a custom monad into
-- Scotty's transformer stack, using ReaderT to provide access
-- to a TVar containing global state.
--
-- Note: this example is somewhat simple, as our top level
-- is IO itself. The types of 'scottyT' and 'scottyAppT' are
-- general enough to allow a Scotty application to be
-- embedded into any MonadIO monad.
module Main (main) where
import Control.Concurrent.STM
import Control.Monad.IO.Unlift (MonadUnliftIO(..))
import Control.Monad.Reader
import Data.String
import Network.Wai.Middleware.RequestLogger
import Web.Scotty.Trans
newtype AppState = AppState { tickCount :: Int }
defaultAppState :: AppState
defaultAppState = AppState 0
-- Why 'ReaderT (TVar AppState)' rather than 'StateT AppState'?
-- With a state transformer, 'runActionToIO' (below) would have
-- to provide the state to _every action_, and save the resulting
-- state, using an MVar. This means actions would be blocking,
-- effectively meaning only one request could be serviced at a time.
-- The 'ReaderT' solution means only actions that actually modify
-- the state need to block/retry.
--
-- Also note: your monad must be an instance of 'MonadIO' for
-- Scotty to use it.
newtype WebM a = WebM { runWebM :: ReaderT (TVar AppState) IO a }
deriving (Applicative, Functor, Monad, MonadIO, MonadReader (TVar AppState), MonadUnliftIO)
-- Scotty's monads are layered on top of our custom monad.
-- We define this synonym for lift in order to be explicit
-- about when we are operating at the 'WebM' layer.
webM :: MonadTrans t => WebM a -> t WebM a
webM = lift
-- Some helpers to make this feel more like a state monad.
gets :: (AppState -> b) -> WebM b
gets f = ask >>= liftIO . readTVarIO >>= return . f
modify :: (AppState -> AppState) -> WebM ()
modify f = ask >>= liftIO . atomically . flip modifyTVar' f
main :: IO ()
main = do
sync <- newTVarIO defaultAppState
-- 'runActionToIO' is called once per action.
let runActionToIO m = runReaderT (runWebM m) sync
scottyT 3000 runActionToIO app
-- This app doesn't use raise/rescue, so the exception
-- type is ambiguous. We can fix it by putting a type
-- annotation just about anywhere. In this case, we'll
-- just do it on the entire app.
app :: ScottyT WebM ()
app = do
middleware logStdoutDev
get "/" $ do
c <- webM $ gets tickCount
text $ fromString $ show c
get "/plusone" $ do
webM $ modify $ \ st -> st { tickCount = tickCount st + 1 }
redirect "/"
get "/plustwo" $ do
webM $ modify $ \ st -> st { tickCount = tickCount st + 2 }
redirect "/"
|
