module Web.Spock.Core
(
runSpock, runSpockNoBanner, spockAsApp
, spockT, spockLimT, spockConfigT, SpockT, SpockCtxT
, Path, root, Var, var, static, (<//>)
, renderRoute
, subcomponent, prehook
, get, post, getpost, head, put, delete, patch, hookRoute, hookRouteCustom, hookAny, hookAnyCustom
, Http.StdMethod (..)
, middleware
, module Web.Spock.Action
, SpockConfig (..), defaultSpockConfig
, hookRoute', hookAny', SpockMethod(..), W.HttpMethod(..)
)
where
import Web.Spock.Action
import Web.Spock.Internal.Wire (SpockMethod(..))
import Control.Applicative
import Control.Monad.Reader
import Data.HVect hiding (head)
import Data.Word
import Network.HTTP.Types.Method
import Prelude hiding (head, uncurry, curry)
import Web.Routing.Combinators hiding (renderRoute)
import Web.Routing.Router (swapMonad)
import Web.Routing.SafeRouting
import Web.Spock.Internal.Config
import qualified Data.Text as T
import qualified Network.HTTP.Types as Http
import qualified Network.Wai as Wai
import qualified Web.Routing.Combinators as COMB
import qualified Web.Routing.Router as AR
import qualified Web.Spock.Internal.Wire as W
import qualified Network.Wai.Handler.Warp as Warp
type SpockT = SpockCtxT ()
newtype LiftHooked ctx m =
LiftHooked { unLiftHooked :: forall a. ActionCtxT ctx m a -> ActionCtxT () m a }
injectHook :: LiftHooked ctx m -> (forall a. ActionCtxT ctx' m a -> ActionCtxT ctx m a) -> LiftHooked ctx' m
injectHook (LiftHooked baseHook) nextHook =
LiftHooked $ baseHook . nextHook
newtype SpockCtxT ctx m a
= SpockCtxT
{ runSpockT :: W.SpockAllT m (ReaderT (LiftHooked ctx m) m) a
} deriving (Monad, Functor, Applicative, MonadIO)
instance MonadTrans (SpockCtxT ctx) where
lift = SpockCtxT . lift . lift
runSpock :: Warp.Port -> IO Wai.Middleware -> IO ()
runSpock port mw =
do putStrLn ("Spock is running on port " ++ show port)
app <- spockAsApp mw
Warp.run port app
runSpockNoBanner :: Warp.Port -> IO Wai.Middleware -> IO ()
runSpockNoBanner port mw =
do app <- spockAsApp mw
Warp.run port app
spockAsApp :: IO Wai.Middleware -> IO Wai.Application
spockAsApp = liftM W.middlewareToApp
spockT :: (MonadIO m)
=> (forall a. m a -> IO a)
-> SpockT m ()
-> IO Wai.Middleware
spockT = spockConfigT defaultSpockConfig
spockLimT :: forall m .MonadIO m
=> Maybe Word64
-> (forall a. m a -> IO a)
-> SpockT m ()
-> IO Wai.Middleware
spockLimT mSizeLimit =
let spockConfigWithLimit = defaultSpockConfig { sc_maxRequestSize = mSizeLimit }
in spockConfigT spockConfigWithLimit
spockConfigT :: forall m .MonadIO m
=> SpockConfig
-> (forall a. m a -> IO a)
-> SpockT m ()
-> IO Wai.Middleware
spockConfigT (SpockConfig maxRequestSize errorAction) liftFun app =
W.buildMiddleware internalConfig liftFun (baseAppHook app)
where
internalConfig = W.SpockConfigInternal maxRequestSize errorHandler
errorHandler status = spockAsApp $ W.buildMiddleware W.defaultSpockConfigInternal id $ baseAppHook $ errorApp status
errorApp status = mapM_ (\method -> hookAny method $ \_ -> errorAction' status) [minBound .. maxBound]
errorAction' status = setStatus status >> errorAction status
baseAppHook :: forall m. MonadIO m => SpockT m () -> W.SpockAllT m m ()
baseAppHook app =
swapMonad lifter (runSpockT app)
where
lifter :: forall b. ReaderT (LiftHooked () m) m b -> m b
lifter action = runReaderT action (LiftHooked id)
get :: (HasRep xs, MonadIO m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()
get = hookRoute GET
post :: (HasRep xs, MonadIO m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()
post = hookRoute POST
getpost :: (HasRep xs, MonadIO m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()
getpost r a = hookRoute POST r a >> hookRoute GET r a
head :: (HasRep xs, MonadIO m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()
head = hookRoute HEAD
put :: (HasRep xs, MonadIO m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()
put = hookRoute PUT
delete :: (HasRep xs, MonadIO m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()
delete = hookRoute DELETE
patch :: (HasRep xs, MonadIO m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()
patch = hookRoute PATCH
prehook :: forall m ctx ctx'. MonadIO m => ActionCtxT ctx m ctx' -> SpockCtxT ctx' m () -> SpockCtxT ctx m ()
prehook hook (SpockCtxT hookBody) =
SpockCtxT $
do prevHook <- lift ask
let newHook :: ActionCtxT ctx' m a -> ActionCtxT ctx m a
newHook act =
do newCtx <- hook
runInContext newCtx act
hookLift :: forall a. ReaderT (LiftHooked ctx' m) m a -> ReaderT (LiftHooked ctx m) m a
hookLift a =
lift $ runReaderT a (injectHook prevHook newHook)
swapMonad hookLift hookBody
hookRoute :: forall xs ctx m ps. (HasRep xs, Monad m) => StdMethod -> Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()
hookRoute = hookRoute' . MethodStandard . W.HttpMethod
hookRouteCustom :: forall xs ctx m ps. (HasRep xs, Monad m) => T.Text -> Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()
hookRouteCustom = hookRoute' . MethodCustom
hookRoute' :: forall xs ctx m ps. (HasRep xs, Monad m) => SpockMethod -> Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()
hookRoute' m path action =
SpockCtxT $
do hookLift <- lift $ asks unLiftHooked
let actionPacker :: HVectElim xs (ActionCtxT ctx m ()) -> HVect xs -> ActionCtxT () m ()
actionPacker act captures = hookLift (uncurry act captures)
AR.hookRoute m (toInternalPath path) (HVectElim' $ curry $ actionPacker action)
hookAny :: Monad m => StdMethod -> ([T.Text] -> ActionCtxT ctx m ()) -> SpockCtxT ctx m ()
hookAny = hookAny' . MethodStandard . W.HttpMethod
hookAnyCustom :: Monad m => T.Text -> ([T.Text] -> ActionCtxT ctx m ()) -> SpockCtxT ctx m ()
hookAnyCustom = hookAny' . MethodCustom
hookAny' :: Monad m => SpockMethod -> ([T.Text] -> ActionCtxT ctx m ()) -> SpockCtxT ctx m ()
hookAny' m action =
SpockCtxT $
do hookLift <- lift $ asks unLiftHooked
AR.hookAny m (hookLift . action)
subcomponent :: Monad m => Path '[] 'Open -> SpockCtxT ctx m () -> SpockCtxT ctx m ()
subcomponent p (SpockCtxT subapp) = SpockCtxT $ AR.subcomponent (toInternalPath p) subapp
middleware :: Monad m => Wai.Middleware -> SpockCtxT ctx m ()
middleware = SpockCtxT . AR.middleware
(<//>) :: Path as 'Open -> Path bs ps -> Path (Append as bs) ps
(<//>) = (</>)
renderRoute :: Path as 'Open -> HVectElim as T.Text
renderRoute route = curryExpl (pathToRep route) (T.cons '/' . COMB.renderRoute route)