module Web.Scottish (
Scottish, Scottish'
, ScottishM, ScottishActionM, ScottishM', ScottishActionM'
, scottish, scottishApp, scottishOpts
, scottish', scottishApp', scottishOpts', handleRaisedStatus
, getConfig, getGlobalState, getLocalState, (>$<)
, setLocalState, modifyLocalState
, setConfig, modifyConfig
, setGlobalState, modifyGlobalState
, module Trans
) where
import Control.Applicative
import Control.Lens
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans.Identity
import Data.Default
import Data.IORef
import qualified Data.Text.Lazy as T
import Network.HTTP.Types.Status
import Network.Wai
import Network.Wai.Handler.Warp (Port)
import Web.Scotty.Trans
import qualified Web.Scotty.Trans as Trans hiding (scottyAppT, scottyOptsT,
scottyT)
data ScottishState c s s' = ScottishState { _config :: c
, _globalState :: s
, _localState :: s'
}
$(makeLenses ''ScottishState)
instance (Default c, Default s, Default s')
=> Default (ScottishState c s s') where
def = ScottishState def def def
newtype Scottish config globalState localState a =
Scottish { unScottish :: StateT (ScottishState config globalState
localState) IO a }
deriving (Functor, Monad, Applicative, MonadIO,
MonadState (ScottishState config globalState localState))
type Scottish' c s' = Scottish c () s'
type ScottishM e c s s' = ScottyT e (Scottish c s s')
type ScottishActionM e c s s' = ActionT e (Scottish c s s')
instance ScottyError Status where
stringError = either (const badRequest400) id . (toEnum<$>) . readEither
. T.pack
showError = T.pack . show
type ScottishM' c s' = ScottyT Status (Scottish' c s')
type ScottishActionM' c s' = ActionT Status (Scottish' c s')
scottish :: (Default c, Default s, Default s')
=> Port
-> ScottishM e c s s' ()
-> IO ()
scottish p = (mkScottishRunners>>=) . flip (uncurry $ scottyT p)
scottishApp :: (Default c, Default s, Default s')
=> ScottishM e c s s' ()
-> IO Application
scottishApp = (mkScottishRunners>>=) . flip (uncurry scottyAppT)
scottishOpts :: (Default c, Default s, Default s')
=> Options -> ScottishM e c s s' () -> IO ()
scottishOpts opts = (mkScottishRunners>>=) . flip (uncurry $ scottyOptsT opts)
scottish' :: (Default c, Default s, Default s')
=> Port -> ScottishM Status c s s' () -> IO ()
scottish' p = (mkScottishRunners>>=) . flip (uncurry $ scottyT p)
. handleRaisedStatus
scottishApp' :: (Default c, Default s, Default s')
=> ScottishM Status c s s' () -> IO Application
scottishApp' = (mkScottishRunners>>=) . flip (uncurry scottyAppT)
. handleRaisedStatus
scottishOpts' :: (Default c, Default s, Default s')
=> Options -> ScottishM Status c s s' () -> IO ()
scottishOpts' opts = (mkScottishRunners>>=) . flip (uncurry $ scottyOptsT opts)
. handleRaisedStatus
mkScottishRunners :: (Default c, Default s, Default s', MonadIO n)
=> IO (forall a. Scottish c s s' a -> n a,
Scottish c s s' Response -> IO Response)
mkScottishRunners = do
shared <- newIORef undefined
let initializer m = liftIO $ do
(r, ss) <- runStateT (unScottish m) def
writeIORef shared ss
return r
actionRunner m = do
ss <- readIORef shared
evalStateT (unScottish m) $ set localState def ss
return (initializer, actionRunner)
getConfig :: (MonadTrans t) => t (Scottish c s s') c
getConfig = lift . use $ config
getGlobalState :: (MonadTrans t) => t (Scottish c s s') s
getGlobalState = lift . use $ globalState
setConfig :: c -> ScottishM e c s s' ()
setConfig = lift . assign config
modifyConfig :: (c -> c) -> ScottishM e c s s' ()
modifyConfig = lift . (config%=)
setGlobalState :: s -> ScottishM e c s s' ()
setGlobalState = lift . assign globalState
modifyGlobalState :: (s -> s) -> ScottishM e c s s' ()
modifyGlobalState = lift . (globalState%=)
getLocalState :: (ScottyError e) => ScottishActionM e c s s' s'
getLocalState = lift . use $ localState
setLocalState :: (ScottyError e) => s' -> ScottishActionM e c s s' ()
setLocalState = lift . assign localState
modifyLocalState:: (ScottyError e) => (s' -> s') -> ScottishActionM e c s s' ()
modifyLocalState = lift . (localState%=)
handleRaisedStatus :: ScottishM Status c s s' () -> ScottishM Status c s s' ()
handleRaisedStatus = ((defaultHandler $ \e -> status e)>>)
(>$<) :: MonadTrans t
=> (a -> Scottish c s s' b)
-> IdentityT (Scottish c s s') a
-> t (Scottish c s s') b
infixl 4 >$<
f >$< x = lift $ runIdentityT x >>= f