LANGUAGE FlexibleInstances MultiParamTypeClasse -- Controller is monad

  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
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
-- | Controller is a monad, superset of IO.
-- All application controllers are executed in this monad.
-- Controller type has three type parameters. First is type of configuration
-- for controller (usually it will be @ActionConfig@ or @StaticConfig@). Second and
-- third are types of possible results of controller.
--
-- There are three possible ways to combine Controller actions. First, you can
-- execute actions one by one, just as in IO monad. Secondly, if you decide
-- that you already have a result, you can return that result with @returnNow@
-- function -- all subsequent computations will not be executed. Third, you can
-- at any moment reject all the computation (in application controller, this
-- will mean `I do not want process this URL!').
module Framework.Controller
(-- * Data types
Controller, AController,
HttpController, StaticController,
ContextProcessor,
RequestExcHandler, ControllerExcHandler,
-- * Controller-monad specific functions
MonadIO (..),
returnNow, reject,
concatC, changeR, changeS,
assertC,
evalController
) where
import Control.Monad.Reader.Class
import Control.Monad.State.Class
import Control.Monad.Trans
import Framework.Types
import Framework.TEngine.Types
---------------------------------------------------------------------------------------
-- * Data types
-- | Controller may reject url, return a value for further processing,
-- or return a value right now to avoid succeding computations
data ControllerResult r a = Reject -- ^ `No, I wann't process this URL!'
| RightNow r -- ^ `Return this response and do not look what is writen below!'
| Result a -- ^ `I return this value; use it in following computations.'
-- | Controller itself
newtype Controller s r a = Controller {
runController :: s -> IO (ControllerResult r a, s)
}
-- | Type of application-level controllers
type HttpController = Controller ActionConfig HttpResponse HttpResponse
-- | Type of application-level controllers, that use StaticConfig
type StaticController = Controller StaticConfig HttpResponse HttpResponse
-- | Most common type of controllers
type AController a = Controller ActionConfig HttpResponse a
-------------------------------------------------------------------------------------------
type ContextProcessor = Controller ActionConfig Context Context
type RequestExcHandler = HttpRequest -> Int -> String -> Controller StaticConfig HttpResponse ()
type ControllerExcHandler = HttpRequest -> Int -> String -> AController ()
-------------------------------------------------------------------------------------------
instance Monad (Controller s r) where
-- return :: a -> Controller s a
return v = Controller $ \s -> return (Result v, s)
-- (>>=) :: Controller s a -> (a -> Controller s b) -> Controller s b
Controller cmd >>= f =
Controller $ \s -> do -- `do` in IO
(res, s') <- cmd s
case res of
Reject -> return (Reject, s)
RightNow resp -> return (RightNow resp, s)
Result res' -> (runController . f) res' s'
instance MonadState s (Controller s r) where
get = Controller $ \s -> return (Result s, s)
put s = Controller $ \_ -> return (Result (), s)
instance MonadReader s (Controller s r) where
ask = Controller $ \s -> return (Result s, s)
local f m = Controller $ runController m . f
instance MonadIO (Controller s r) where
-- liftIO :: IO a -> Controller s r a
-- | `Lift' an IO action into Controller
liftIO act = Controller $ \s -> do
res <- act
return (Result res, s)
---------------------------------------------------------------------------------------------
-- * Controller-monad specific functions
-- | Run all controllers in list in given environment, and concatenate results
concatC :: [Controller b [a] [a]] -- ^ List of controllers
-> Controller b r [a]
concatC cs = do
s <- ask
rs <- liftIO $ mapM (flip runController s) cs
return $ process $ map fst rs
where
process [] = []
process (Reject:_) = []
process ((RightNow x):_) = x
process ((Result x):xs) = x++process xs
-- | Run a controller, but reject if it returns RightNow t.
changeR :: Controller s r a -> Controller s q a
changeR m = do
s <- ask
r <- liftIO $ runController m s
case fst r of
Reject -> reject
RightNow _ -> reject
Result x -> return x
-- | Run a controller in changed environment
changeS :: (s -> s1) -> Controller s1 r a -> Controller s r a
changeS f m = Controller $ \s -> do
(res,_) <- runController m (f s)
return (res, s)
-- | Assert that condition is satisfied. Otherwise, reject URL.
assertC :: Bool -> Controller s r ()
assertC b =
if b
then return ()
else reject
-- | Return given value and do not evaluate following computations
returnNow :: r -> Controller s r a
returnNow v = Controller $ \s -> return (RightNow v, s)
-- | Reject this computation
reject :: Controller s r a
reject = Controller $ \s -> return (Reject, s)
-- | Evaluate controller with given configuration
evalController :: Controller s a a -- ^ Controller
-> s -- ^ Configuration for controller
-> IO (Maybe a)
evalController m s = do
(res, _) <- runController m s
return $ anyResult res
where
-- | Convert any result to Maybe HttpResponse
anyResult :: ControllerResult a a -> Maybe a
anyResult Reject = Nothing
anyResult (RightNow r) = Just r
anyResult (Result r) = Just r