{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Web.Spock.Core
(
runSpock, runSpockNoBanner, spockAsApp
, spockT, spockConfigT, SpockT, SpockCtxT
, Path, root, Var, var, static, (<//>), wildcard
, renderRoute
, prehook
, get, post, getpost, head, put, delete, patch, hookRoute, hookRouteCustom, hookAny, hookAnyCustom
, hookRouteAll
, hookAnyAll
, 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 Network.HTTP.Types.Method
import Prelude hiding (head, uncurry, curry)
import System.IO
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
wireAny m action =
SpockCtxT $
do hookLift <- lift $ asks unLiftHooked
case m of
MethodAny ->
do forM_ allStdMethods $ \mReg ->
AR.hookAny mReg (hookLift . action)
AR.hookAnyMethod (hookLift . action)
_ -> 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)
case m of
MethodAny ->
do forM_ allStdMethods $ \mReg ->
AR.hookRoute mReg (toInternalPath path) (HVectElim' $ curry $ actionPacker action)
AR.hookRouteAnyMethod (toInternalPath path) (HVectElim' $ curry $ actionPacker action)
_ -> AR.hookRoute m (toInternalPath path) (HVectElim' $ curry $ actionPacker action)
allStdMethods :: [SpockMethod]
allStdMethods = MethodStandard <$> [minBound .. maxBound]
runSpock :: Warp.Port -> IO Wai.Middleware -> IO ()
runSpock port mw =
do hPutStrLn stderr ("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 = fmap W.middlewareToApp
spockT :: (MonadIO m)
=> (forall a. m a -> IO a)
-> SpockT m ()
-> IO Wai.Middleware
spockT = spockConfigT defaultSpockConfig
spockConfigT :: forall m .MonadIO m
=> SpockConfig
-> (forall a. m a -> IO a)
-> SpockT m ()
-> IO Wai.Middleware
spockConfigT (SpockConfig maxRequestSize errorAction logError) liftFun app =
W.buildMiddleware internalConfig liftFun (baseAppHook app)
where
internalConfig = W.SpockConfigInternal maxRequestSize errorHandler logError
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
hookRouteAll :: (HasRep xs, RouteM t, Monad m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
hookRouteAll = hookRoute' MethodAny
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
hookAnyAll :: (RouteM t, Monad m) => ([T.Text] -> ActionCtxT ctx m ()) -> t ctx m ()
hookAnyAll = hookAny' MethodAny
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
middleware :: (RouteM t, Monad m) => Wai.Middleware -> t ctx m ()
middleware = addMiddleware
(<//>) :: Path as 'Open -> Path bs ps -> Path (Append as bs) ps
(<//>) = (</>)
renderRoute :: AllHave ToHttpApiData as => Path as 'Open -> HVectElim as T.Text
renderRoute route = curryExpl (pathToRep route) (T.cons '/' . COMB.renderRoute route)