{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Web.Spock.Core
(
runSpock, runSpockNoBanner, spockAsApp
, spockT, spockLimT, spockConfigT, SpockT, SpockCtxT
, Path, root, Var, var, static, (<//>), wildcard
, 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 Web.Spock.Routing
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.HttpApiData
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 Network.Wai.Handler.Warp as Warp
import qualified Web.Routing.Combinators as COMB
import qualified Web.Routing.Router as AR
import qualified Web.Spock.Internal.Wire as W
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
instance RouteM SpockCtxT where
addMiddleware = SpockCtxT . AR.middleware
inSubcomponent p (SpockCtxT subapp) =
SpockCtxT $ AR.subcomponent (toInternalPath p) subapp
wireAny m action =
SpockCtxT $
do hookLift <- lift $ asks unLiftHooked
AR.hookAny m (hookLift . action)
withPrehook = withPrehookImpl
wireRoute = wireRouteImpl
withPrehookImpl :: forall m ctx ctx'. MonadIO m => ActionCtxT ctx m ctx' -> SpockCtxT ctx' m () -> SpockCtxT ctx m ()
withPrehookImpl 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
wireRouteImpl :: forall xs ctx m ps. (HasRep xs, Monad m) => SpockMethod -> Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()
wireRouteImpl 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)
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
{-# DEPRECATED spockLimT "Consider using spockConfigT instead" #-}
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, RouteM t, Monad m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
get = hookRoute GET
post :: (HasRep xs, RouteM t, Monad m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
post = hookRoute POST
getpost :: (HasRep xs, RouteM t, Monad m, Monad (t ctx m)) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
getpost r a = hookRoute POST r a >> hookRoute GET r a
head :: (HasRep xs, RouteM t, Monad m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
head = hookRoute HEAD
put :: (HasRep xs, RouteM t, Monad m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
put = hookRoute PUT
delete :: (HasRep xs, RouteM t, Monad m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
delete = hookRoute DELETE
patch :: (HasRep xs, RouteM t, Monad m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
patch = hookRoute PATCH
prehook :: (RouteM t, MonadIO m) => ActionCtxT ctx m ctx' -> t ctx' m () -> t ctx m ()
prehook = withPrehook
hookRoute :: (HasRep xs, RouteM t, Monad m) => StdMethod -> Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
hookRoute = hookRoute' . MethodStandard . W.HttpMethod
hookRouteCustom :: (HasRep xs, RouteM t, Monad m) => T.Text -> Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
hookRouteCustom = hookRoute' . MethodCustom
hookRoute' :: (HasRep xs, RouteM t, Monad m) => SpockMethod -> Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
hookRoute' = wireRoute
hookAny :: (RouteM t, Monad m) => StdMethod -> ([T.Text] -> ActionCtxT ctx m ()) -> t ctx m ()
hookAny = hookAny' . MethodStandard . W.HttpMethod
hookAnyCustom :: (RouteM t, Monad m) => T.Text -> ([T.Text] -> ActionCtxT ctx m ()) -> t ctx m ()
hookAnyCustom = hookAny' . MethodCustom
hookAny' :: (RouteM t, Monad m) => SpockMethod -> ([T.Text] -> ActionCtxT ctx m ()) -> t ctx m ()
hookAny' = wireAny
subcomponent :: (RouteM t, Monad m) => Path '[] 'Open -> t ctx m () -> t ctx m ()
subcomponent = inSubcomponent
{-# DEPRECATED subcomponent "Subcomponents will be removed in the next major release. They break route rendering and should not be used. Consider creating helper functions for reusable route components" #-}
-- | Hook wai middleware into Spock
middleware :: (RouteM t, Monad m) => Wai.Middleware -> t ctx m ()
middleware = addMiddleware
-- | Combine two path components
(<//>) :: Path as 'Open -> Path bs ps -> Path (Append as bs) ps
(<//>) = (</>)
-- | Render a route applying path pieces
renderRoute :: AllHave ToHttpApiData as => Path as 'Open -> HVectElim as T.Text
renderRoute route = curryExpl (pathToRep route) (T.cons '/' . COMB.renderRoute route)