module Web.Spock.Safe
(
spock, SpockM, SpockCtxM
, spockT, spockLimT, SpockT, SpockCtxT
, Path, root, Var, var, static, (<//>)
, renderRoute
, subcomponent, prehook
, get, post, getpost, head, put, delete, patch, hookRoute, hookAny
, Http.StdMethod (..)
, middleware
, SafeAction (..)
, safeActionPath
, module Web.Spock.Shared
)
where
import Web.Spock.Shared
import Web.Spock.Internal.Types
import qualified Web.Spock.Internal.Core as C
import Control.Applicative
import Control.Monad.Reader
import Data.HVect hiding (head)
import Data.Monoid
import Data.Word
import Network.HTTP.Types.Method
import Prelude hiding (head, uncurry, curry)
import Web.Routing.AbstractRouter (swapMonad)
import Web.Routing.SafeRouting hiding (renderRoute)
import qualified Data.Text as T
import qualified Network.HTTP.Types as Http
import qualified Network.Wai as Wai
import qualified Web.Routing.SafeRouting as SR
type SpockM conn sess st = SpockCtxM () conn sess st
type SpockCtxM ctx conn sess st = SpockCtxT ctx (WebStateM conn sess st)
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 :: C.SpockAllT (SafeRouter (ActionT m) ()) (ReaderT (LiftHooked ctx m) m) a
} deriving (Monad, Functor, Applicative, MonadIO)
instance MonadTrans (SpockCtxT ctx) where
lift = SpockCtxT . lift . lift
spock :: SpockCfg conn sess st -> SpockM conn sess st () -> IO Wai.Middleware
spock spockCfg spockAppl =
C.spockAll SafeRouter spockCfg (baseAppHook spockAppl')
where
spockAppl' =
do hookSafeActions
spockAppl
spockT :: (MonadIO m)
=> (forall a. m a -> IO a)
-> SpockT m ()
-> IO Wai.Middleware
spockT = spockLimT Nothing
spockLimT :: forall m .MonadIO m
=> Maybe Word64
-> (forall a. m a -> IO a)
-> SpockT m ()
-> IO Wai.Middleware
spockLimT mSizeLimit liftFun app =
C.spockAllT mSizeLimit SafeRouter liftFun (baseAppHook app)
baseAppHook :: forall m. MonadIO m => SpockT m () -> C.SpockAllT (SafeRouter (ActionT 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 -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()
get = hookRoute GET
post :: (HasRep xs, MonadIO m) => Path xs -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()
post = hookRoute POST
getpost :: (HasRep xs, MonadIO m) => Path xs -> 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 -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()
head = hookRoute HEAD
put :: (HasRep xs, MonadIO m) => Path xs -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()
put = hookRoute PUT
delete :: (HasRep xs, MonadIO m) => Path xs -> HVectElim xs (ActionCtxT ctx m ()) -> SpockCtxT ctx m ()
delete = hookRoute DELETE
patch :: (HasRep xs, MonadIO m) => Path xs -> 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. (HasRep xs, Monad m) => StdMethod -> Path xs -> 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)
C.hookRoute m (SafeRouterPath path) (HVectElim' $ curry $ actionPacker action)
hookAny :: Monad m => StdMethod -> ([T.Text] -> ActionCtxT ctx m ()) -> SpockCtxT ctx m ()
hookAny m action =
SpockCtxT $
do hookLift <- lift $ asks unLiftHooked
C.hookAny m (hookLift . action)
subcomponent :: Monad m => Path '[] -> SpockCtxT ctx m () -> SpockCtxT ctx m ()
subcomponent p (SpockCtxT subapp) = SpockCtxT $ C.subcomponent (SafeRouterPath p) subapp
middleware :: Monad m => Wai.Middleware -> SpockCtxT ctx m ()
middleware = SpockCtxT . C.middleware
safeActionPath :: forall conn sess st a.
( SafeAction conn sess st a
, HasSpock(SpockAction conn sess st)
, SpockConn (SpockAction conn sess st) ~ conn
, SpockSession (SpockAction conn sess st) ~ sess
, SpockState (SpockAction conn sess st) ~ st)
=> a
-> SpockAction conn sess st T.Text
safeActionPath safeAction =
do mgr <- getSessMgr
hash <- sm_addSafeAction mgr (PackedSafeAction safeAction)
return $ "/h/" <> hash
hookSafeActions :: forall conn sess st.
( HasSpock (SpockAction conn sess st)
, SpockConn (SpockAction conn sess st) ~ conn
, SpockSession (SpockAction conn sess st) ~ sess
, SpockState (SpockAction conn sess st) ~ st)
=> SpockM conn sess st ()
hookSafeActions =
getpost (static "h" </> var) run
where
run h =
do mgr <- getSessMgr
mAction <- sm_lookupSafeAction mgr h
case mAction of
Nothing ->
do setStatus Http.status404
text "File not found"
Just p@(PackedSafeAction action) ->
do runSafeAction action
sm_removeSafeAction mgr p
(<//>) :: Path as -> Path bs -> Path (Append as bs)
(<//>) = (</>)
renderRoute :: Path as -> HVectElim as T.Text
renderRoute route = curryExpl (pathToRep route) (T.cons '/' . SR.renderRoute route)