{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -Wno-warnings-deprecations #-}

module Web.Spock.Internal.Wire where

import Control.Applicative
import Control.Arrow ((***))
import Control.Concurrent.MVar
import Control.Concurrent.STM
import Control.Exception
import Control.Monad.Base
import Control.Monad (forM_, guard)
#if MIN_VERSION_mtl(2,2,0)
import Control.Monad.Except
#else
import Control.Monad.Error
#endif

#if MIN_VERSION_base(4,6,0)
import Prelude
#else
import Prelude hiding (catch)
#endif

import qualified Control.Monad.Morph as MM
import Control.Monad.RWS.Strict hiding ((<>))
import Control.Monad.Reader.Class ()
import Control.Monad.Trans.Control
import Control.Monad.Trans.Resource
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as BSLC
import qualified Data.CaseInsensitive as CI
import qualified Data.HashMap.Strict as HM
import Data.Hashable
import Data.IORef
import Data.Maybe
import Data.Semigroup
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import Data.Typeable
import qualified Data.Vault.Lazy as V
import Data.Word
import GHC.Generics
import Network.HTTP.Types.Header (ResponseHeaders)
import Network.HTTP.Types.Method
import Network.HTTP.Types.Status
import qualified Network.Wai as Wai
import qualified Network.Wai.Parse as P
import System.IO
import Web.Routing.Router
import Web.Routing.SafeRouting (SlashPolicy (..))
import Web.Spock.Logging

newtype HttpMethod = HttpMethod {HttpMethod -> StdMethod
unHttpMethod :: StdMethod}
  deriving (Int -> HttpMethod -> ShowS
[HttpMethod] -> ShowS
HttpMethod -> String
(Int -> HttpMethod -> ShowS)
-> (HttpMethod -> String)
-> ([HttpMethod] -> ShowS)
-> Show HttpMethod
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HttpMethod -> ShowS
showsPrec :: Int -> HttpMethod -> ShowS
$cshow :: HttpMethod -> String
show :: HttpMethod -> String
$cshowList :: [HttpMethod] -> ShowS
showList :: [HttpMethod] -> ShowS
Show, HttpMethod -> HttpMethod -> Bool
(HttpMethod -> HttpMethod -> Bool)
-> (HttpMethod -> HttpMethod -> Bool) -> Eq HttpMethod
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HttpMethod -> HttpMethod -> Bool
== :: HttpMethod -> HttpMethod -> Bool
$c/= :: HttpMethod -> HttpMethod -> Bool
/= :: HttpMethod -> HttpMethod -> Bool
Eq, HttpMethod
HttpMethod -> HttpMethod -> Bounded HttpMethod
forall a. a -> a -> Bounded a
$cminBound :: HttpMethod
minBound :: HttpMethod
$cmaxBound :: HttpMethod
maxBound :: HttpMethod
Bounded, Int -> HttpMethod
HttpMethod -> Int
HttpMethod -> [HttpMethod]
HttpMethod -> HttpMethod
HttpMethod -> HttpMethod -> [HttpMethod]
HttpMethod -> HttpMethod -> HttpMethod -> [HttpMethod]
(HttpMethod -> HttpMethod)
-> (HttpMethod -> HttpMethod)
-> (Int -> HttpMethod)
-> (HttpMethod -> Int)
-> (HttpMethod -> [HttpMethod])
-> (HttpMethod -> HttpMethod -> [HttpMethod])
-> (HttpMethod -> HttpMethod -> [HttpMethod])
-> (HttpMethod -> HttpMethod -> HttpMethod -> [HttpMethod])
-> Enum HttpMethod
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: HttpMethod -> HttpMethod
succ :: HttpMethod -> HttpMethod
$cpred :: HttpMethod -> HttpMethod
pred :: HttpMethod -> HttpMethod
$ctoEnum :: Int -> HttpMethod
toEnum :: Int -> HttpMethod
$cfromEnum :: HttpMethod -> Int
fromEnum :: HttpMethod -> Int
$cenumFrom :: HttpMethod -> [HttpMethod]
enumFrom :: HttpMethod -> [HttpMethod]
$cenumFromThen :: HttpMethod -> HttpMethod -> [HttpMethod]
enumFromThen :: HttpMethod -> HttpMethod -> [HttpMethod]
$cenumFromTo :: HttpMethod -> HttpMethod -> [HttpMethod]
enumFromTo :: HttpMethod -> HttpMethod -> [HttpMethod]
$cenumFromThenTo :: HttpMethod -> HttpMethod -> HttpMethod -> [HttpMethod]
enumFromThenTo :: HttpMethod -> HttpMethod -> HttpMethod -> [HttpMethod]
Enum, (forall x. HttpMethod -> Rep HttpMethod x)
-> (forall x. Rep HttpMethod x -> HttpMethod) -> Generic HttpMethod
forall x. Rep HttpMethod x -> HttpMethod
forall x. HttpMethod -> Rep HttpMethod x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. HttpMethod -> Rep HttpMethod x
from :: forall x. HttpMethod -> Rep HttpMethod x
$cto :: forall x. Rep HttpMethod x -> HttpMethod
to :: forall x. Rep HttpMethod x -> HttpMethod
Generic)

instance Hashable HttpMethod where
  hashWithSalt :: Int -> HttpMethod -> Int
hashWithSalt = (HttpMethod -> Int) -> Int -> HttpMethod -> Int
forall b a. Hashable b => (a -> b) -> Int -> a -> Int
hashUsing (StdMethod -> Int
forall a. Enum a => a -> Int
fromEnum (StdMethod -> Int)
-> (HttpMethod -> StdMethod) -> HttpMethod -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpMethod -> StdMethod
unHttpMethod)

-- | The 'SpockMethod' allows safe use of http verbs via the 'MethodStandard'
-- constructor and 'StdMethod', and custom verbs via the 'MethodCustom' constructor.
data SpockMethod
  = -- | Standard HTTP Verbs from 'StdMethod'
    MethodStandard !HttpMethod
  | -- | Custom HTTP verbs represented as @Text@.
    MethodCustom !T.Text
  | -- | Match any HTTP verb
    MethodAny
  deriving (SpockMethod -> SpockMethod -> Bool
(SpockMethod -> SpockMethod -> Bool)
-> (SpockMethod -> SpockMethod -> Bool) -> Eq SpockMethod
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SpockMethod -> SpockMethod -> Bool
== :: SpockMethod -> SpockMethod -> Bool
$c/= :: SpockMethod -> SpockMethod -> Bool
/= :: SpockMethod -> SpockMethod -> Bool
Eq, (forall x. SpockMethod -> Rep SpockMethod x)
-> (forall x. Rep SpockMethod x -> SpockMethod)
-> Generic SpockMethod
forall x. Rep SpockMethod x -> SpockMethod
forall x. SpockMethod -> Rep SpockMethod x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SpockMethod -> Rep SpockMethod x
from :: forall x. SpockMethod -> Rep SpockMethod x
$cto :: forall x. Rep SpockMethod x -> SpockMethod
to :: forall x. Rep SpockMethod x -> SpockMethod
Generic)

instance Hashable SpockMethod

data UploadedFile = UploadedFile
  { UploadedFile -> Text
uf_name :: !T.Text,
    UploadedFile -> Text
uf_contentType :: !T.Text,
    UploadedFile -> String
uf_tempLocation :: !FilePath
  }
  deriving (Int -> UploadedFile -> ShowS
[UploadedFile] -> ShowS
UploadedFile -> String
(Int -> UploadedFile -> ShowS)
-> (UploadedFile -> String)
-> ([UploadedFile] -> ShowS)
-> Show UploadedFile
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UploadedFile -> ShowS
showsPrec :: Int -> UploadedFile -> ShowS
$cshow :: UploadedFile -> String
show :: UploadedFile -> String
$cshowList :: [UploadedFile] -> ShowS
showList :: [UploadedFile] -> ShowS
Show)

data VaultIf = VaultIf
  { VaultIf -> (Vault -> Vault) -> IO ()
vi_modifyVault :: (V.Vault -> V.Vault) -> IO (),
    VaultIf -> forall a. Key a -> IO (Maybe a)
vi_lookupKey :: forall a. V.Key a -> IO (Maybe a)
  }

data CacheVar v = forall r.
  CacheVar
  { forall v. CacheVar v -> MVar ()
cv_lock :: !(MVar ()),
    ()
cv_makeVal :: !(IO r),
    ()
cv_value :: !(IORef (Maybe r)),
    ()
cv_read :: r -> v
  }

instance Functor CacheVar where
  fmap :: forall a b. (a -> b) -> CacheVar a -> CacheVar b
fmap a -> b
f (CacheVar MVar ()
lock IO r
makeVal IORef (Maybe r)
valRef r -> a
readV) =
    CacheVar
      { cv_lock :: MVar ()
cv_lock = MVar ()
lock,
        cv_makeVal :: IO r
cv_makeVal = IO r
makeVal,
        cv_value :: IORef (Maybe r)
cv_value = IORef (Maybe r)
valRef,
        cv_read :: r -> b
cv_read = a -> b
f (a -> b) -> (r -> a) -> r -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> a
readV
      }

newCacheVar :: IO v -> IO (CacheVar v)
newCacheVar :: forall v. IO v -> IO (CacheVar v)
newCacheVar IO v
makeVal =
  do
    lock <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
    valueR <- newIORef Nothing
    return (CacheVar lock makeVal valueR id)

loadCacheVarOpt :: CacheVar v -> IO (Maybe v)
loadCacheVarOpt :: forall v. CacheVar v -> IO (Maybe v)
loadCacheVarOpt (CacheVar MVar ()
lock IO r
_ IORef (Maybe r)
valRef r -> v
readV) =
  IO () -> IO () -> IO (Maybe v) -> IO (Maybe v)
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
lock ()) (MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
lock) (IO (Maybe v) -> IO (Maybe v)) -> IO (Maybe v) -> IO (Maybe v)
forall a b. (a -> b) -> a -> b
$
    (r -> v) -> Maybe r -> Maybe v
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap r -> v
readV (Maybe r -> Maybe v) -> IO (Maybe r) -> IO (Maybe v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Maybe r) -> IO (Maybe r)
forall a. IORef a -> IO a
readIORef IORef (Maybe r)
valRef

loadCacheVar :: CacheVar v -> IO v
loadCacheVar :: forall v. CacheVar v -> IO v
loadCacheVar (CacheVar MVar ()
lock IO r
makeVal IORef (Maybe r)
valRef r -> v
readV) =
  IO () -> IO () -> IO v -> IO v
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
lock ()) (MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
lock) (IO v -> IO v) -> IO v -> IO v
forall a b. (a -> b) -> a -> b
$
    do
      val <- IORef (Maybe r) -> IO (Maybe r)
forall a. IORef a -> IO a
readIORef IORef (Maybe r)
valRef
      case val of
        Just r
v -> v -> IO v
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (r -> v
readV r
v)
        Maybe r
Nothing ->
          do
            v <- IO r
makeVal
            writeIORef valRef (Just v)
            return (readV v)

data RequestBody = RequestBody
  { RequestBody -> CacheVar ByteString
rb_value :: CacheVar BS.ByteString,
    RequestBody -> CacheVar [(Text, Text)]
rb_postParams :: CacheVar [(T.Text, T.Text)],
    RequestBody -> CacheVar (HashMap Text [UploadedFile])
rb_files :: CacheVar (HM.HashMap T.Text [UploadedFile])
  }

data RequestInfo ctx = RequestInfo
  { forall ctx. RequestInfo ctx -> SpockMethod
ri_method :: !SpockMethod,
    forall ctx. RequestInfo ctx -> Request
ri_request :: !Wai.Request,
    forall ctx. RequestInfo ctx -> [(Text, Text)]
ri_getParams :: ![(T.Text, T.Text)],
    forall ctx. RequestInfo ctx -> RequestBody
ri_reqBody :: !RequestBody,
    forall ctx. RequestInfo ctx -> VaultIf
ri_vaultIf :: !VaultIf,
    forall ctx. RequestInfo ctx -> ctx
ri_context :: !ctx,
    forall ctx.
RequestInfo ctx -> Maybe (RequestContext, LogEventType -> IO ())
ri_requestLogger :: Maybe (RequestContext, LogEventType -> IO ())
  }

newtype ResponseBody = ResponseBody (Status -> ResponseHeaders -> Wai.Response)

data MultiHeader
  = MultiHeaderCacheControl
  | MultiHeaderConnection
  | MultiHeaderContentEncoding
  | MultiHeaderContentLanguage
  | MultiHeaderPragma
  | MultiHeaderProxyAuthenticate
  | MultiHeaderTrailer
  | MultiHeaderTransferEncoding
  | MultiHeaderUpgrade
  | MultiHeaderVia
  | MultiHeaderWarning
  | MultiHeaderWWWAuth
  | MultiHeaderSetCookie
  deriving (Int -> MultiHeader -> ShowS
[MultiHeader] -> ShowS
MultiHeader -> String
(Int -> MultiHeader -> ShowS)
-> (MultiHeader -> String)
-> ([MultiHeader] -> ShowS)
-> Show MultiHeader
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MultiHeader -> ShowS
showsPrec :: Int -> MultiHeader -> ShowS
$cshow :: MultiHeader -> String
show :: MultiHeader -> String
$cshowList :: [MultiHeader] -> ShowS
showList :: [MultiHeader] -> ShowS
Show, MultiHeader -> MultiHeader -> Bool
(MultiHeader -> MultiHeader -> Bool)
-> (MultiHeader -> MultiHeader -> Bool) -> Eq MultiHeader
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MultiHeader -> MultiHeader -> Bool
== :: MultiHeader -> MultiHeader -> Bool
$c/= :: MultiHeader -> MultiHeader -> Bool
/= :: MultiHeader -> MultiHeader -> Bool
Eq, Int -> MultiHeader
MultiHeader -> Int
MultiHeader -> [MultiHeader]
MultiHeader -> MultiHeader
MultiHeader -> MultiHeader -> [MultiHeader]
MultiHeader -> MultiHeader -> MultiHeader -> [MultiHeader]
(MultiHeader -> MultiHeader)
-> (MultiHeader -> MultiHeader)
-> (Int -> MultiHeader)
-> (MultiHeader -> Int)
-> (MultiHeader -> [MultiHeader])
-> (MultiHeader -> MultiHeader -> [MultiHeader])
-> (MultiHeader -> MultiHeader -> [MultiHeader])
-> (MultiHeader -> MultiHeader -> MultiHeader -> [MultiHeader])
-> Enum MultiHeader
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: MultiHeader -> MultiHeader
succ :: MultiHeader -> MultiHeader
$cpred :: MultiHeader -> MultiHeader
pred :: MultiHeader -> MultiHeader
$ctoEnum :: Int -> MultiHeader
toEnum :: Int -> MultiHeader
$cfromEnum :: MultiHeader -> Int
fromEnum :: MultiHeader -> Int
$cenumFrom :: MultiHeader -> [MultiHeader]
enumFrom :: MultiHeader -> [MultiHeader]
$cenumFromThen :: MultiHeader -> MultiHeader -> [MultiHeader]
enumFromThen :: MultiHeader -> MultiHeader -> [MultiHeader]
$cenumFromTo :: MultiHeader -> MultiHeader -> [MultiHeader]
enumFromTo :: MultiHeader -> MultiHeader -> [MultiHeader]
$cenumFromThenTo :: MultiHeader -> MultiHeader -> MultiHeader -> [MultiHeader]
enumFromThenTo :: MultiHeader -> MultiHeader -> MultiHeader -> [MultiHeader]
Enum, MultiHeader
MultiHeader -> MultiHeader -> Bounded MultiHeader
forall a. a -> a -> Bounded a
$cminBound :: MultiHeader
minBound :: MultiHeader
$cmaxBound :: MultiHeader
maxBound :: MultiHeader
Bounded, (forall x. MultiHeader -> Rep MultiHeader x)
-> (forall x. Rep MultiHeader x -> MultiHeader)
-> Generic MultiHeader
forall x. Rep MultiHeader x -> MultiHeader
forall x. MultiHeader -> Rep MultiHeader x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. MultiHeader -> Rep MultiHeader x
from :: forall x. MultiHeader -> Rep MultiHeader x
$cto :: forall x. Rep MultiHeader x -> MultiHeader
to :: forall x. Rep MultiHeader x -> MultiHeader
Generic)

instance Hashable MultiHeader

multiHeaderCI :: MultiHeader -> CI.CI BS.ByteString
multiHeaderCI :: MultiHeader -> CI ByteString
multiHeaderCI MultiHeader
mh =
  case MultiHeader
mh of
    MultiHeader
MultiHeaderCacheControl -> CI ByteString
"Cache-Control"
    MultiHeader
MultiHeaderConnection -> CI ByteString
"Connection"
    MultiHeader
MultiHeaderContentEncoding -> CI ByteString
"Content-Encoding"
    MultiHeader
MultiHeaderContentLanguage -> CI ByteString
"Content-Language"
    MultiHeader
MultiHeaderPragma -> CI ByteString
"Pragma"
    MultiHeader
MultiHeaderProxyAuthenticate -> CI ByteString
"Proxy-Authenticate"
    MultiHeader
MultiHeaderTrailer -> CI ByteString
"Trailer"
    MultiHeader
MultiHeaderTransferEncoding -> CI ByteString
"Transfer-Encoding"
    MultiHeader
MultiHeaderUpgrade -> CI ByteString
"Upgrade"
    MultiHeader
MultiHeaderVia -> CI ByteString
"Via"
    MultiHeader
MultiHeaderWarning -> CI ByteString
"Warning"
    MultiHeader
MultiHeaderWWWAuth -> CI ByteString
"WWW-Authenticate"
    MultiHeader
MultiHeaderSetCookie -> CI ByteString
"Set-Cookie"

multiHeaderMap :: HM.HashMap (CI.CI BS.ByteString) MultiHeader
multiHeaderMap :: HashMap (CI ByteString) MultiHeader
multiHeaderMap =
  [(CI ByteString, MultiHeader)]
-> HashMap (CI ByteString) MultiHeader
forall k v. Hashable k => [(k, v)] -> HashMap k v
HM.fromList ([(CI ByteString, MultiHeader)]
 -> HashMap (CI ByteString) MultiHeader)
-> [(CI ByteString, MultiHeader)]
-> HashMap (CI ByteString) MultiHeader
forall a b. (a -> b) -> a -> b
$
    ((MultiHeader -> (CI ByteString, MultiHeader))
 -> [MultiHeader] -> [(CI ByteString, MultiHeader)])
-> [MultiHeader]
-> (MultiHeader -> (CI ByteString, MultiHeader))
-> [(CI ByteString, MultiHeader)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (MultiHeader -> (CI ByteString, MultiHeader))
-> [MultiHeader] -> [(CI ByteString, MultiHeader)]
forall a b. (a -> b) -> [a] -> [b]
map [MultiHeader]
allHeaders ((MultiHeader -> (CI ByteString, MultiHeader))
 -> [(CI ByteString, MultiHeader)])
-> (MultiHeader -> (CI ByteString, MultiHeader))
-> [(CI ByteString, MultiHeader)]
forall a b. (a -> b) -> a -> b
$ \MultiHeader
mh ->
      (MultiHeader -> CI ByteString
multiHeaderCI MultiHeader
mh, MultiHeader
mh)
  where
    -- this is a nasty hack until we know more about the origin of uncaught
    -- exception: ErrorCall (toEnum{MultiHeader}: tag (-12565) is outside of
    -- enumeration's range (0,12)) see:
    -- https://ghc.haskell.org/trac/ghc/ticket/10792 and
    -- https://github.com/agrafix/Spock/issues/44
    allHeaders :: [MultiHeader]
allHeaders =
      [ MultiHeader
MultiHeaderCacheControl,
        MultiHeader
MultiHeaderConnection,
        MultiHeader
MultiHeaderContentEncoding,
        MultiHeader
MultiHeaderContentLanguage,
        MultiHeader
MultiHeaderPragma,
        MultiHeader
MultiHeaderProxyAuthenticate,
        MultiHeader
MultiHeaderTrailer,
        MultiHeader
MultiHeaderTransferEncoding,
        MultiHeader
MultiHeaderUpgrade,
        MultiHeader
MultiHeaderVia,
        MultiHeader
MultiHeaderWarning,
        MultiHeader
MultiHeaderWWWAuth,
        MultiHeader
MultiHeaderSetCookie
      ]

data ResponseVal
  = ResponseValState !ResponseState
  | ResponseHandler !(IO Wai.Application)

data ResponseState = ResponseState
  { ResponseState -> HashMap (CI ByteString) ByteString
rs_responseHeaders :: !(HM.HashMap (CI.CI BS.ByteString) BS.ByteString),
    ResponseState -> HashMap MultiHeader [ByteString]
rs_multiResponseHeaders :: !(HM.HashMap MultiHeader [BS.ByteString]),
    ResponseState -> Status
rs_status :: !Status,
    ResponseState -> ResponseBody
rs_responseBody :: !ResponseBody
  }

data ActionInterupt
  = ActionRedirect !T.Text
  | ActionTryNext
  | ActionError String
  | ActionDone
  | ActionMiddlewarePass
  | ActionMiddleware !(IO Wai.Middleware)
  | ActionApplication !(IO Wai.Application)
  deriving (Typeable)

instance Semigroup ActionInterupt where
  ActionInterupt
_ <> :: ActionInterupt -> ActionInterupt -> ActionInterupt
<> ActionInterupt
a = ActionInterupt
a

instance Monoid ActionInterupt where
  mempty :: ActionInterupt
mempty = ActionInterupt
ActionDone
  mappend :: ActionInterupt -> ActionInterupt -> ActionInterupt
mappend = ActionInterupt -> ActionInterupt -> ActionInterupt
forall a. Semigroup a => a -> a -> a
(<>)

#if MIN_VERSION_mtl(2,2,0)
type ErrorT = ExceptT

runErrorT :: ExceptT e m a -> m (Either e a)
runErrorT :: forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runErrorT = ExceptT e m a -> m (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT

toErrorT :: m (Either e a) -> ErrorT e m a
toErrorT :: forall (m :: * -> *) e a. m (Either e a) -> ErrorT e m a
toErrorT = m (Either e a) -> ExceptT e m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT
#else
toErrorT :: m (Either e a) -> ErrorT e m a
toErrorT = ErrorT

instance Error ActionInterupt where
    noMsg = ActionError "Unkown Internal Action Error"
    strMsg = ActionError
#endif

-- | A request action with context @()@. @m@ supplies the application's base
-- effects and @a@ is the result. For a core application @m@ can be @IO@ or a
-- custom transformer stack; full Spock uses its @WebStateM@ base monad.
type ActionT = ActionCtxT ()

-- | A per-request computation: it reads the request and typed hook context
-- @ctx@, accumulates response metadata, and can finish with a response or
-- continue routing. @m@ is the base monad and @a@ is the result.
--
-- @getContext@ reads the value supplied by a prehook. @lift@ runs a computation
-- in @m@; @liftIO@ runs IO when @m@ supports it. Neither changes the hook
-- context. Response helpers finish the action, so statements after @text@,
-- @json@, or another response helper are not executed.
newtype ActionCtxT ctx m a = ActionCtxT
  {forall ctx (m :: * -> *) a.
ActionCtxT ctx m a
-> ErrorT
     ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a
runActionCtxT :: ErrorT ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a}
  deriving
    ( Applicative (ActionCtxT ctx m)
Applicative (ActionCtxT ctx m) =>
(forall a b.
 ActionCtxT ctx m a
 -> (a -> ActionCtxT ctx m b) -> ActionCtxT ctx m b)
-> (forall a b.
    ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m b)
-> (forall a. a -> ActionCtxT ctx m a)
-> Monad (ActionCtxT ctx m)
forall a. a -> ActionCtxT ctx m a
forall a b.
ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m b
forall a b.
ActionCtxT ctx m a
-> (a -> ActionCtxT ctx m b) -> ActionCtxT ctx m b
forall ctx (m :: * -> *). Monad m => Applicative (ActionCtxT ctx m)
forall ctx (m :: * -> *) a. Monad m => a -> ActionCtxT ctx m a
forall ctx (m :: * -> *) a b.
Monad m =>
ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m b
forall ctx (m :: * -> *) a b.
Monad m =>
ActionCtxT ctx m a
-> (a -> ActionCtxT ctx m b) -> ActionCtxT ctx m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall ctx (m :: * -> *) a b.
Monad m =>
ActionCtxT ctx m a
-> (a -> ActionCtxT ctx m b) -> ActionCtxT ctx m b
>>= :: forall a b.
ActionCtxT ctx m a
-> (a -> ActionCtxT ctx m b) -> ActionCtxT ctx m b
$c>> :: forall ctx (m :: * -> *) a b.
Monad m =>
ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m b
>> :: forall a b.
ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m b
$creturn :: forall ctx (m :: * -> *) a. Monad m => a -> ActionCtxT ctx m a
return :: forall a. a -> ActionCtxT ctx m a
Monad,
      (forall a b. (a -> b) -> ActionCtxT ctx m a -> ActionCtxT ctx m b)
-> (forall a b. a -> ActionCtxT ctx m b -> ActionCtxT ctx m a)
-> Functor (ActionCtxT ctx m)
forall a b. a -> ActionCtxT ctx m b -> ActionCtxT ctx m a
forall a b. (a -> b) -> ActionCtxT ctx m a -> ActionCtxT ctx m b
forall ctx (m :: * -> *) a b.
Functor m =>
a -> ActionCtxT ctx m b -> ActionCtxT ctx m a
forall ctx (m :: * -> *) a b.
Functor m =>
(a -> b) -> ActionCtxT ctx m a -> ActionCtxT ctx m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall ctx (m :: * -> *) a b.
Functor m =>
(a -> b) -> ActionCtxT ctx m a -> ActionCtxT ctx m b
fmap :: forall a b. (a -> b) -> ActionCtxT ctx m a -> ActionCtxT ctx m b
$c<$ :: forall ctx (m :: * -> *) a b.
Functor m =>
a -> ActionCtxT ctx m b -> ActionCtxT ctx m a
<$ :: forall a b. a -> ActionCtxT ctx m b -> ActionCtxT ctx m a
Functor,
      Functor (ActionCtxT ctx m)
Functor (ActionCtxT ctx m) =>
(forall a. a -> ActionCtxT ctx m a)
-> (forall a b.
    ActionCtxT ctx m (a -> b)
    -> ActionCtxT ctx m a -> ActionCtxT ctx m b)
-> (forall a b c.
    (a -> b -> c)
    -> ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m c)
-> (forall a b.
    ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m b)
-> (forall a b.
    ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m a)
-> Applicative (ActionCtxT ctx m)
forall a. a -> ActionCtxT ctx m a
forall a b.
ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m a
forall a b.
ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m b
forall a b.
ActionCtxT ctx m (a -> b)
-> ActionCtxT ctx m a -> ActionCtxT ctx m b
forall a b c.
(a -> b -> c)
-> ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m c
forall ctx (m :: * -> *). Monad m => Functor (ActionCtxT ctx m)
forall ctx (m :: * -> *) a. Monad m => a -> ActionCtxT ctx m a
forall ctx (m :: * -> *) a b.
Monad m =>
ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m a
forall ctx (m :: * -> *) a b.
Monad m =>
ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m b
forall ctx (m :: * -> *) a b.
Monad m =>
ActionCtxT ctx m (a -> b)
-> ActionCtxT ctx m a -> ActionCtxT ctx m b
forall ctx (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall ctx (m :: * -> *) a. Monad m => a -> ActionCtxT ctx m a
pure :: forall a. a -> ActionCtxT ctx m a
$c<*> :: forall ctx (m :: * -> *) a b.
Monad m =>
ActionCtxT ctx m (a -> b)
-> ActionCtxT ctx m a -> ActionCtxT ctx m b
<*> :: forall a b.
ActionCtxT ctx m (a -> b)
-> ActionCtxT ctx m a -> ActionCtxT ctx m b
$cliftA2 :: forall ctx (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m c
liftA2 :: forall a b c.
(a -> b -> c)
-> ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m c
$c*> :: forall ctx (m :: * -> *) a b.
Monad m =>
ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m b
*> :: forall a b.
ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m b
$c<* :: forall ctx (m :: * -> *) a b.
Monad m =>
ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m a
<* :: forall a b.
ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m a
Applicative,
      Applicative (ActionCtxT ctx m)
Applicative (ActionCtxT ctx m) =>
(forall a. ActionCtxT ctx m a)
-> (forall a.
    ActionCtxT ctx m a -> ActionCtxT ctx m a -> ActionCtxT ctx m a)
-> (forall a. ActionCtxT ctx m a -> ActionCtxT ctx m [a])
-> (forall a. ActionCtxT ctx m a -> ActionCtxT ctx m [a])
-> Alternative (ActionCtxT ctx m)
forall a. ActionCtxT ctx m a
forall a. ActionCtxT ctx m a -> ActionCtxT ctx m [a]
forall a.
ActionCtxT ctx m a -> ActionCtxT ctx m a -> ActionCtxT ctx m a
forall ctx (m :: * -> *). Monad m => Applicative (ActionCtxT ctx m)
forall ctx (m :: * -> *) a. Monad m => ActionCtxT ctx m a
forall ctx (m :: * -> *) a.
Monad m =>
ActionCtxT ctx m a -> ActionCtxT ctx m [a]
forall ctx (m :: * -> *) a.
Monad m =>
ActionCtxT ctx m a -> ActionCtxT ctx m a -> ActionCtxT ctx m a
forall (f :: * -> *).
Applicative f =>
(forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
$cempty :: forall ctx (m :: * -> *) a. Monad m => ActionCtxT ctx m a
empty :: forall a. ActionCtxT ctx m a
$c<|> :: forall ctx (m :: * -> *) a.
Monad m =>
ActionCtxT ctx m a -> ActionCtxT ctx m a -> ActionCtxT ctx m a
<|> :: forall a.
ActionCtxT ctx m a -> ActionCtxT ctx m a -> ActionCtxT ctx m a
$csome :: forall ctx (m :: * -> *) a.
Monad m =>
ActionCtxT ctx m a -> ActionCtxT ctx m [a]
some :: forall a. ActionCtxT ctx m a -> ActionCtxT ctx m [a]
$cmany :: forall ctx (m :: * -> *) a.
Monad m =>
ActionCtxT ctx m a -> ActionCtxT ctx m [a]
many :: forall a. ActionCtxT ctx m a -> ActionCtxT ctx m [a]
Alternative,
      Monad (ActionCtxT ctx m)
Monad (ActionCtxT ctx m) =>
(forall a. IO a -> ActionCtxT ctx m a)
-> MonadIO (ActionCtxT ctx m)
forall a. IO a -> ActionCtxT ctx m a
forall ctx (m :: * -> *). MonadIO m => Monad (ActionCtxT ctx m)
forall ctx (m :: * -> *) a. MonadIO m => IO a -> ActionCtxT ctx m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall ctx (m :: * -> *) a. MonadIO m => IO a -> ActionCtxT ctx m a
liftIO :: forall a. IO a -> ActionCtxT ctx m a
MonadIO,
      MonadReader (RequestInfo ctx),
      MonadState ResponseState,
      MonadError ActionInterupt
    )

instance MonadTrans (ActionCtxT ctx) where
  lift :: forall (m :: * -> *) a. Monad m => m a -> ActionCtxT ctx m a
lift = ErrorT ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a
-> ActionCtxT ctx m a
forall ctx (m :: * -> *) a.
ErrorT ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a
-> ActionCtxT ctx m a
ActionCtxT (ErrorT
   ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a
 -> ActionCtxT ctx m a)
-> (m a
    -> ErrorT
         ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a)
-> m a
-> ActionCtxT ctx m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RWST (RequestInfo ctx) () ResponseState m a
-> ErrorT
     ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT ActionInterupt m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RWST (RequestInfo ctx) () ResponseState m a
 -> ErrorT
      ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a)
-> (m a -> RWST (RequestInfo ctx) () ResponseState m a)
-> m a
-> ErrorT
     ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> RWST (RequestInfo ctx) () ResponseState m a
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (RequestInfo ctx) () ResponseState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance MM.MFunctor (ActionCtxT ctx) where
  hoist :: forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> ActionCtxT ctx m b -> ActionCtxT ctx n b
hoist forall a. m a -> n a
f ActionCtxT ctx m b
m = ErrorT ActionInterupt (RWST (RequestInfo ctx) () ResponseState n) b
-> ActionCtxT ctx n b
forall ctx (m :: * -> *) a.
ErrorT ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a
-> ActionCtxT ctx m a
ActionCtxT ((forall a.
 RWST (RequestInfo ctx) () ResponseState m a
 -> RWST (RequestInfo ctx) () ResponseState n a)
-> ExceptT
     ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) b
-> ErrorT
     ActionInterupt (RWST (RequestInfo ctx) () ResponseState n) b
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a)
-> ExceptT ActionInterupt m b -> ExceptT ActionInterupt n b
MM.hoist ((forall a. m a -> n a)
-> RWST (RequestInfo ctx) () ResponseState m a
-> RWST (RequestInfo ctx) () ResponseState n a
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a)
-> RWST (RequestInfo ctx) () ResponseState m b
-> RWST (RequestInfo ctx) () ResponseState n b
MM.hoist m a -> n a
forall a. m a -> n a
f) (ActionCtxT ctx m b
-> ExceptT
     ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) b
forall ctx (m :: * -> *) a.
ActionCtxT ctx m a
-> ErrorT
     ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a
runActionCtxT ActionCtxT ctx m b
m))

instance MonadTransControl (ActionCtxT ctx) where
  type StT (ActionCtxT ctx) a = (Either ActionInterupt a, ResponseState, ())
  liftWith :: forall (m :: * -> *) a.
Monad m =>
(Run (ActionCtxT ctx) -> m a) -> ActionCtxT ctx m a
liftWith Run (ActionCtxT ctx) -> m a
f =
    ErrorT ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a
-> ActionCtxT ctx m a
forall ctx (m :: * -> *) a.
ErrorT ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a
-> ActionCtxT ctx m a
ActionCtxT (ErrorT
   ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a
 -> ActionCtxT ctx m a)
-> ((RequestInfo ctx
     -> ResponseState -> m (Either ActionInterupt a, ResponseState, ()))
    -> ErrorT
         ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a)
-> (RequestInfo ctx
    -> ResponseState -> m (Either ActionInterupt a, ResponseState, ()))
-> ActionCtxT ctx m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RWST (RequestInfo ctx) () ResponseState m (Either ActionInterupt a)
-> ErrorT
     ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a
forall (m :: * -> *) e a. m (Either e a) -> ErrorT e m a
toErrorT (RWST
   (RequestInfo ctx) () ResponseState m (Either ActionInterupt a)
 -> ErrorT
      ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a)
-> ((RequestInfo ctx
     -> ResponseState -> m (Either ActionInterupt a, ResponseState, ()))
    -> RWST
         (RequestInfo ctx) () ResponseState m (Either ActionInterupt a))
-> (RequestInfo ctx
    -> ResponseState -> m (Either ActionInterupt a, ResponseState, ()))
-> ErrorT
     ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RequestInfo ctx
 -> ResponseState -> m (Either ActionInterupt a, ResponseState, ()))
-> RWST
     (RequestInfo ctx) () ResponseState m (Either ActionInterupt a)
forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
RWST ((RequestInfo ctx
  -> ResponseState -> m (Either ActionInterupt a, ResponseState, ()))
 -> ActionCtxT ctx m a)
-> (RequestInfo ctx
    -> ResponseState -> m (Either ActionInterupt a, ResponseState, ()))
-> ActionCtxT ctx m a
forall a b. (a -> b) -> a -> b
$ \RequestInfo ctx
requestInfo ResponseState
responseState ->
      (a -> (Either ActionInterupt a, ResponseState, ()))
-> m a -> m (Either ActionInterupt a, ResponseState, ())
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        (\a
x -> (a -> Either ActionInterupt a
forall a. a -> Either ActionInterupt a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x, ResponseState
responseState, ()))
        (Run (ActionCtxT ctx) -> m a
f (Run (ActionCtxT ctx) -> m a) -> Run (ActionCtxT ctx) -> m a
forall a b. (a -> b) -> a -> b
$ \(ActionCtxT ErrorT ActionInterupt (RWST (RequestInfo ctx) () ResponseState n) b
lala) -> RWST (RequestInfo ctx) () ResponseState n (Either ActionInterupt b)
-> RequestInfo ctx
-> ResponseState
-> n (Either ActionInterupt b, ResponseState, ())
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST (ErrorT ActionInterupt (RWST (RequestInfo ctx) () ResponseState n) b
-> RWST
     (RequestInfo ctx) () ResponseState n (Either ActionInterupt b)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runErrorT ErrorT ActionInterupt (RWST (RequestInfo ctx) () ResponseState n) b
lala) RequestInfo ctx
requestInfo ResponseState
responseState)
  restoreT :: forall (m :: * -> *) a.
Monad m =>
m (StT (ActionCtxT ctx) a) -> ActionCtxT ctx m a
restoreT m (StT (ActionCtxT ctx) a)
mSt = ErrorT ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a
-> ActionCtxT ctx m a
forall ctx (m :: * -> *) a.
ErrorT ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a
-> ActionCtxT ctx m a
ActionCtxT (ErrorT
   ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a
 -> ActionCtxT ctx m a)
-> (RWST
      (RequestInfo ctx) () ResponseState m (Either ActionInterupt a)
    -> ErrorT
         ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a)
-> RWST
     (RequestInfo ctx) () ResponseState m (Either ActionInterupt a)
-> ActionCtxT ctx m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RWST (RequestInfo ctx) () ResponseState m (Either ActionInterupt a)
-> ErrorT
     ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a
forall (m :: * -> *) e a. m (Either e a) -> ErrorT e m a
toErrorT (RWST
   (RequestInfo ctx) () ResponseState m (Either ActionInterupt a)
 -> ActionCtxT ctx m a)
-> RWST
     (RequestInfo ctx) () ResponseState m (Either ActionInterupt a)
-> ActionCtxT ctx m a
forall a b. (a -> b) -> a -> b
$ (RequestInfo ctx
 -> ResponseState -> m (Either ActionInterupt a, ResponseState, ()))
-> RWST
     (RequestInfo ctx) () ResponseState m (Either ActionInterupt a)
forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
RWST (\RequestInfo ctx
_ ResponseState
_ -> m (Either ActionInterupt a, ResponseState, ())
m (StT (ActionCtxT ctx) a)
mSt)

instance MonadBase b m => MonadBase b (ActionCtxT ctx m) where
  liftBase :: forall α. b α -> ActionCtxT ctx m α
liftBase = b α -> ActionCtxT ctx m α
forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) α.
(MonadTrans t, MonadBase b m) =>
b α -> t m α
liftBaseDefault

instance MonadBaseControl b m => MonadBaseControl b (ActionCtxT ctx m) where
  type StM (ActionCtxT ctx m) a = ComposeSt (ActionCtxT ctx) m a
  liftBaseWith :: forall a.
(RunInBase (ActionCtxT ctx m) b -> b a) -> ActionCtxT ctx m a
liftBaseWith = (RunInBaseDefault (ActionCtxT ctx) m b -> b a)
-> ActionCtxT ctx m a
(RunInBase (ActionCtxT ctx m) b -> b a) -> ActionCtxT ctx m a
forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) a.
(MonadTransControl t, MonadBaseControl b m) =>
(RunInBaseDefault t m b -> b a) -> t m a
defaultLiftBaseWith
  restoreM :: forall a. StM (ActionCtxT ctx m) a -> ActionCtxT ctx m a
restoreM = ComposeSt (ActionCtxT ctx) m a -> ActionCtxT ctx m a
StM (ActionCtxT ctx m) a -> ActionCtxT ctx m a
forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) a.
(MonadTransControl t, MonadBaseControl b m) =>
ComposeSt t m a -> t m a
defaultRestoreM

data SpockConfigInternal = SpockConfigInternal
  { SpockConfigInternal -> Maybe Word64
sci_maxRequestSize :: Maybe Word64,
    SpockConfigInternal -> Status -> IO Application
sci_errorHandler :: Status -> IO Wai.Application,
    SpockConfigInternal -> Text -> IO ()
sci_logError :: T.Text -> IO (),
    SpockConfigInternal -> Maybe RequestLogger
sci_requestLogger :: Maybe RequestLogger,
    SpockConfigInternal -> SlashPolicy
sci_slashPolicy :: SlashPolicy
  }

defaultSpockConfigInternal :: SpockConfigInternal
defaultSpockConfigInternal :: SpockConfigInternal
defaultSpockConfigInternal =
  Maybe Word64
-> (Status -> IO Application)
-> (Text -> IO ())
-> Maybe RequestLogger
-> SlashPolicy
-> SpockConfigInternal
SpockConfigInternal Maybe Word64
forall a. Maybe a
Nothing Status -> IO Application
forall {m :: * -> *} {t} {t}.
Monad m =>
Status -> m (t -> (Response -> t) -> t)
defaultErrorHandler (Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr) Maybe RequestLogger
forall a. Maybe a
Nothing SlashPolicy
IgnoreSlashes
  where
    defaultErrorHandler :: Status -> m (t -> (Response -> t) -> t)
defaultErrorHandler Status
status = (t -> (Response -> t) -> t) -> m (t -> (Response -> t) -> t)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((t -> (Response -> t) -> t) -> m (t -> (Response -> t) -> t))
-> (t -> (Response -> t) -> t) -> m (t -> (Response -> t) -> t)
forall a b. (a -> b) -> a -> b
$ \t
_ Response -> t
respond ->
      do
        let errorMessage :: String
errorMessage =
              String
"Error handler failed with status code " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Status -> Int
statusCode Status
status)
        Response -> t
respond (Response -> t) -> Response -> t
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS Status
status500 [] (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BSLC.pack String
errorMessage

respStateToResponse :: ResponseVal -> Wai.Response
respStateToResponse :: ResponseVal -> Response
respStateToResponse (ResponseValState (ResponseState HashMap (CI ByteString) ByteString
headers HashMap MultiHeader [ByteString]
multiHeaders Status
status (ResponseBody Status -> ResponseHeaders -> Response
body))) =
  let mkMultiHeader :: (MultiHeader, [b]) -> [(CI ByteString, b)]
mkMultiHeader (MultiHeader
k, [b]
vals) =
        let kCi :: CI ByteString
kCi = MultiHeader -> CI ByteString
multiHeaderCI MultiHeader
k
         in (b -> (CI ByteString, b)) -> [b] -> [(CI ByteString, b)]
forall a b. (a -> b) -> [a] -> [b]
map (\b
v -> (CI ByteString
kCi, b
v)) [b]
vals
      outHeaders :: ResponseHeaders
outHeaders =
        HashMap (CI ByteString) ByteString -> ResponseHeaders
forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap (CI ByteString) ByteString
headers
          ResponseHeaders -> ResponseHeaders -> ResponseHeaders
forall a. [a] -> [a] -> [a]
++ (((MultiHeader, [ByteString]) -> ResponseHeaders)
-> [(MultiHeader, [ByteString])] -> ResponseHeaders
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (MultiHeader, [ByteString]) -> ResponseHeaders
forall {b}. (MultiHeader, [b]) -> [(CI ByteString, b)]
mkMultiHeader ([(MultiHeader, [ByteString])] -> ResponseHeaders)
-> [(MultiHeader, [ByteString])] -> ResponseHeaders
forall a b. (a -> b) -> a -> b
$ HashMap MultiHeader [ByteString] -> [(MultiHeader, [ByteString])]
forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap MultiHeader [ByteString]
multiHeaders)
   in Status -> ResponseHeaders -> Response
body Status
status ResponseHeaders
outHeaders
respStateToResponse ResponseVal
_ = String -> Response
forall a. HasCallStack => String -> a
error String
"ResponseState expected"

errorResponse :: Status -> BSL.ByteString -> ResponseVal
errorResponse :: Status -> ByteString -> ResponseVal
errorResponse Status
s ByteString
e =
  ResponseState -> ResponseVal
ResponseValState
    ResponseState
      { rs_responseHeaders :: HashMap (CI ByteString) ByteString
rs_responseHeaders =
          CI ByteString -> ByteString -> HashMap (CI ByteString) ByteString
forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton CI ByteString
"Content-Type" ByteString
"text/html",
        rs_multiResponseHeaders :: HashMap MultiHeader [ByteString]
rs_multiResponseHeaders =
          HashMap MultiHeader [ByteString]
forall k v. HashMap k v
HM.empty,
        rs_status :: Status
rs_status = Status
s,
        rs_responseBody :: ResponseBody
rs_responseBody = (Status -> ResponseHeaders -> Response) -> ResponseBody
ResponseBody ((Status -> ResponseHeaders -> Response) -> ResponseBody)
-> (Status -> ResponseHeaders -> Response) -> ResponseBody
forall a b. (a -> b) -> a -> b
$ \Status
status ResponseHeaders
headers ->
          Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS Status
status ResponseHeaders
headers (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$
            [ByteString] -> ByteString
BSL.concat
              [ ByteString
"<html><head><title>",
                ByteString
e,
                ByteString
"</title></head><body><h1>",
                ByteString
e,
                ByteString
"</h1></body></html>"
              ]
      }

defResponse :: ResponseState
defResponse :: ResponseState
defResponse =
  ResponseState
    { rs_responseHeaders :: HashMap (CI ByteString) ByteString
rs_responseHeaders =
        HashMap (CI ByteString) ByteString
forall k v. HashMap k v
HM.empty,
      rs_multiResponseHeaders :: HashMap MultiHeader [ByteString]
rs_multiResponseHeaders =
        HashMap MultiHeader [ByteString]
forall k v. HashMap k v
HM.empty,
      rs_status :: Status
rs_status = Status
status200,
      rs_responseBody :: ResponseBody
rs_responseBody = (Status -> ResponseHeaders -> Response) -> ResponseBody
ResponseBody ((Status -> ResponseHeaders -> Response) -> ResponseBody)
-> (Status -> ResponseHeaders -> Response) -> ResponseBody
forall a b. (a -> b) -> a -> b
$ \Status
status ResponseHeaders
headers ->
        Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS Status
status ResponseHeaders
headers (ByteString -> Response) -> ByteString -> Response
forall a b. (a -> b) -> a -> b
$
          ByteString
BSL.empty
    }

type SpockAllT n m a = RegistryT (ActionT n) () Wai.Middleware SpockMethod m a

middlewareToApp ::
  Wai.Middleware ->
  Wai.Application
middlewareToApp :: Middleware -> Application
middlewareToApp Middleware
mw =
  Middleware
mw Application
fallbackApp
  where
    fallbackApp :: Wai.Application
    fallbackApp :: Application
fallbackApp Request
_ Response -> IO ResponseReceived
respond = Response -> IO ResponseReceived
respond Response
notFound
    notFound :: Response
notFound = ResponseVal -> Response
respStateToResponse (ResponseVal -> Response) -> ResponseVal -> Response
forall a b. (a -> b) -> a -> b
$ Status -> ByteString -> ResponseVal
errorResponse Status
status404 ByteString
"404 - File not found"

makeActionEnvironment ::
  SpockConfigInternal -> InternalState -> SpockMethod -> Wai.Request -> IO (RequestInfo (), TVar V.Vault)
makeActionEnvironment :: SpockConfigInternal
-> InternalState
-> SpockMethod
-> Request
-> IO (RequestInfo (), TVar Vault)
makeActionEnvironment SpockConfigInternal
config InternalState
st SpockMethod
stdMethod Request
req =
  do
    vaultVar <- IO (TVar Vault) -> IO (TVar Vault)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar Vault) -> IO (TVar Vault))
-> IO (TVar Vault) -> IO (TVar Vault)
forall a b. (a -> b) -> a -> b
$ Vault -> IO (TVar Vault)
forall a. a -> IO (TVar a)
newTVarIO (Request -> Vault
Wai.vault Request
req)
    let vaultIf =
          VaultIf
            { vi_modifyVault :: (Vault -> Vault) -> IO ()
vi_modifyVault = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> ((Vault -> Vault) -> STM ()) -> (Vault -> Vault) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar Vault -> (Vault -> Vault) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Vault
vaultVar,
              vi_lookupKey :: forall a. Key a -> IO (Maybe a)
vi_lookupKey = \Key a
k -> Key a -> Vault -> Maybe a
forall a. Key a -> Vault -> Maybe a
V.lookup Key a
k (Vault -> Maybe a) -> IO Vault -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM Vault -> IO Vault
forall a. STM a -> IO a
atomically (TVar Vault -> STM Vault
forall a. TVar a -> STM a
readTVar TVar Vault
vaultVar)
            }
        getParams =
          (QueryItem -> (Text, Text)) -> [QueryItem] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (\(ByteString
k, Maybe ByteString
mV) -> (ByteString -> Text
T.decodeUtf8 ByteString
k, ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
BS.empty Maybe ByteString
mV)) ([QueryItem] -> [(Text, Text)]) -> [QueryItem] -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ Request -> [QueryItem]
Wai.queryString Request
req
    rbValue <- newCacheVar $ BSL.toStrict <$> Wai.consumeRequestBodyStrict req
    bodyTuple <-
      newCacheVar $
        case P.getRequestBodyType req of
          Maybe RequestBodyType
Nothing -> ([(Text, Text)], HashMap Text [UploadedFile])
-> IO ([(Text, Text)], HashMap Text [UploadedFile])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], HashMap Text [UploadedFile]
forall k v. HashMap k v
HM.empty)
          Just RequestBodyType
rbt ->
            do
              bodyBs <- CacheVar ByteString -> IO ByteString
forall v. CacheVar v -> IO v
loadCacheVar CacheVar ByteString
rbValue
              bodyRef <- newIORef (Just bodyBs)
              let loader =
                    do
                      mb <- IORef (Maybe ByteString) -> IO (Maybe ByteString)
forall a. IORef a -> IO a
readIORef IORef (Maybe ByteString)
bodyRef
                      case mb of
                        Just ByteString
b -> IORef (Maybe ByteString) -> Maybe ByteString -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe ByteString)
bodyRef Maybe ByteString
forall a. Maybe a
Nothing IO () -> IO ByteString -> IO ByteString
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
b
                        Maybe ByteString
Nothing -> ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
BS.empty
              (bodyParams, bodyFiles) <-
                P.sinkRequestBody (P.tempFileBackEnd st) rbt loader
              let uploadedFiles =
                    (File String
 -> HashMap Text [UploadedFile] -> HashMap Text [UploadedFile])
-> HashMap Text [UploadedFile]
-> [File String]
-> HashMap Text [UploadedFile]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr File String
-> HashMap Text [UploadedFile] -> HashMap Text [UploadedFile]
addUpload HashMap Text [UploadedFile]
forall k v. HashMap k v
HM.empty [File String]
bodyFiles
                  addUpload (ByteString
k, FileInfo String
fileInfo) =
                    ([UploadedFile] -> [UploadedFile] -> [UploadedFile])
-> Text
-> [UploadedFile]
-> HashMap Text [UploadedFile]
-> HashMap Text [UploadedFile]
forall k v.
Hashable k =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
HM.insertWith [UploadedFile] -> [UploadedFile] -> [UploadedFile]
forall a. [a] -> [a] -> [a]
(++) (ByteString -> Text
T.decodeUtf8 ByteString
k)
                      [ Text -> Text -> String -> UploadedFile
UploadedFile
                          (ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ FileInfo String -> ByteString
forall c. FileInfo c -> ByteString
P.fileName FileInfo String
fileInfo)
                          (ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ FileInfo String -> ByteString
forall c. FileInfo c -> ByteString
P.fileContentType FileInfo String
fileInfo)
                          (FileInfo String -> String
forall c. FileInfo c -> c
P.fileContent FileInfo String
fileInfo)
                      ]
                  postParams =
                    (Param -> (Text, Text)) -> [Param] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> Text
T.decodeUtf8 (ByteString -> Text)
-> (ByteString -> Text) -> Param -> (Text, Text)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ByteString -> Text
T.decodeUtf8) [Param]
bodyParams
              return (postParams, uploadedFiles)
    let reqBody =
          RequestBody
            { rb_value :: CacheVar ByteString
rb_value = CacheVar ByteString
rbValue,
              rb_files :: CacheVar (HashMap Text [UploadedFile])
rb_files = (([(Text, Text)], HashMap Text [UploadedFile])
 -> HashMap Text [UploadedFile])
-> CacheVar ([(Text, Text)], HashMap Text [UploadedFile])
-> CacheVar (HashMap Text [UploadedFile])
forall a b. (a -> b) -> CacheVar a -> CacheVar b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(Text, Text)], HashMap Text [UploadedFile])
-> HashMap Text [UploadedFile]
forall a b. (a, b) -> b
snd CacheVar ([(Text, Text)], HashMap Text [UploadedFile])
bodyTuple,
              rb_postParams :: CacheVar [(Text, Text)]
rb_postParams = (([(Text, Text)], HashMap Text [UploadedFile]) -> [(Text, Text)])
-> CacheVar ([(Text, Text)], HashMap Text [UploadedFile])
-> CacheVar [(Text, Text)]
forall a b. (a -> b) -> CacheVar a -> CacheVar b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(Text, Text)], HashMap Text [UploadedFile]) -> [(Text, Text)]
forall a b. (a, b) -> a
fst CacheVar ([(Text, Text)], HashMap Text [UploadedFile])
bodyTuple
            }
    return
      ( RequestInfo
          { ri_method = stdMethod,
            ri_request = req,
            ri_getParams = getParams,
            ri_reqBody = reqBody,
            ri_vaultIf = vaultIf,
            ri_requestLogger = sci_requestLogger config >>= (\RequestLogger
logger -> RequestLogger
-> Request -> Maybe (RequestContext, LogEventType -> IO ())
lookupRequestLogger RequestLogger
logger Request
req),
            ri_context = ()
          },
        vaultVar
      )

applyAction ::
  MonadIO m =>
  SpockConfigInternal ->
  Wai.Request ->
  RequestInfo () ->
  [ActionT m ()] ->
  m (Maybe ResponseVal)
applyAction :: forall (m :: * -> *).
MonadIO m =>
SpockConfigInternal
-> Request
-> RequestInfo ()
-> [ActionT m ()]
-> m (Maybe ResponseVal)
applyAction SpockConfigInternal
config Request
_ RequestInfo ()
_ [] =
  Maybe ResponseVal -> m (Maybe ResponseVal)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ResponseVal -> m (Maybe ResponseVal))
-> Maybe ResponseVal -> m (Maybe ResponseVal)
forall a b. (a -> b) -> a -> b
$ ResponseVal -> Maybe ResponseVal
forall a. a -> Maybe a
Just (ResponseVal -> Maybe ResponseVal)
-> ResponseVal -> Maybe ResponseVal
forall a b. (a -> b) -> a -> b
$ SpockConfigInternal -> Status -> ResponseVal
getErrorHandler SpockConfigInternal
config Status
status404
applyAction SpockConfigInternal
config Request
req RequestInfo ()
env (ActionT m ()
selectedAction : [ActionT m ()]
xs) =
  do
    (r, respState, _) <-
      RWST (RequestInfo ()) () ResponseState m (Either ActionInterupt ())
-> RequestInfo ()
-> ResponseState
-> m (Either ActionInterupt (), ResponseState, ())
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST (ExceptT
  ActionInterupt (RWST (RequestInfo ()) () ResponseState m) ()
-> RWST
     (RequestInfo ()) () ResponseState m (Either ActionInterupt ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runErrorT (ExceptT
   ActionInterupt (RWST (RequestInfo ()) () ResponseState m) ()
 -> RWST
      (RequestInfo ()) () ResponseState m (Either ActionInterupt ()))
-> ExceptT
     ActionInterupt (RWST (RequestInfo ()) () ResponseState m) ()
-> RWST
     (RequestInfo ()) () ResponseState m (Either ActionInterupt ())
forall a b. (a -> b) -> a -> b
$ ActionT m ()
-> ExceptT
     ActionInterupt (RWST (RequestInfo ()) () ResponseState m) ()
forall ctx (m :: * -> *) a.
ActionCtxT ctx m a
-> ErrorT
     ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a
runActionCtxT ActionT m ()
selectedAction) RequestInfo ()
env ResponseState
defResponse
    case r of
      Left (ActionRedirect Text
loc) ->
        Maybe ResponseVal -> m (Maybe ResponseVal)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ResponseVal -> m (Maybe ResponseVal))
-> Maybe ResponseVal -> m (Maybe ResponseVal)
forall a b. (a -> b) -> a -> b
$
          ResponseVal -> Maybe ResponseVal
forall a. a -> Maybe a
Just (ResponseVal -> Maybe ResponseVal)
-> ResponseVal -> Maybe ResponseVal
forall a b. (a -> b) -> a -> b
$
            ResponseState -> ResponseVal
ResponseValState (ResponseState -> ResponseVal) -> ResponseState -> ResponseVal
forall a b. (a -> b) -> a -> b
$
              ResponseState
respState
                { rs_status = status302,
                  rs_responseBody =
                    ResponseBody $ \Status
status ResponseHeaders
headers ->
                      Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS Status
status ((CI ByteString
"Location", Text -> ByteString
T.encodeUtf8 Text
loc) Header -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: ResponseHeaders
headers) ByteString
BSL.empty
                }
      Left ActionInterupt
ActionTryNext ->
        SpockConfigInternal
-> Request
-> RequestInfo ()
-> [ActionT m ()]
-> m (Maybe ResponseVal)
forall (m :: * -> *).
MonadIO m =>
SpockConfigInternal
-> Request
-> RequestInfo ()
-> [ActionT m ()]
-> m (Maybe ResponseVal)
applyAction SpockConfigInternal
config Request
req RequestInfo ()
env [ActionT m ()]
xs
      Left (ActionError String
errorMsg) ->
        do
          IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
            SpockConfigInternal -> Request -> Text -> IO ()
logRequestError SpockConfigInternal
config Request
req (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
              String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
                String
"Spock Error while handling "
                  String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show (Request -> [Text]
Wai.pathInfo Request
req)
                  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": "
                  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
errorMsg
          Maybe ResponseVal -> m (Maybe ResponseVal)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ResponseVal -> m (Maybe ResponseVal))
-> Maybe ResponseVal -> m (Maybe ResponseVal)
forall a b. (a -> b) -> a -> b
$ ResponseVal -> Maybe ResponseVal
forall a. a -> Maybe a
Just (ResponseVal -> Maybe ResponseVal)
-> ResponseVal -> Maybe ResponseVal
forall a b. (a -> b) -> a -> b
$ SpockConfigInternal -> Status -> ResponseVal
getErrorHandler SpockConfigInternal
config Status
status500
      Left ActionInterupt
ActionDone ->
        Maybe ResponseVal -> m (Maybe ResponseVal)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ResponseVal -> m (Maybe ResponseVal))
-> Maybe ResponseVal -> m (Maybe ResponseVal)
forall a b. (a -> b) -> a -> b
$ ResponseVal -> Maybe ResponseVal
forall a. a -> Maybe a
Just (ResponseState -> ResponseVal
ResponseValState ResponseState
respState)
      Left ActionInterupt
ActionMiddlewarePass ->
        Maybe ResponseVal -> m (Maybe ResponseVal)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ResponseVal
forall a. Maybe a
Nothing
      Left (ActionApplication IO Application
app) ->
        Maybe ResponseVal -> m (Maybe ResponseVal)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ResponseVal -> m (Maybe ResponseVal))
-> Maybe ResponseVal -> m (Maybe ResponseVal)
forall a b. (a -> b) -> a -> b
$ ResponseVal -> Maybe ResponseVal
forall a. a -> Maybe a
Just (IO Application -> ResponseVal
ResponseHandler IO Application
app)
      Left (ActionMiddleware IO Middleware
getMiddleware) ->
        Maybe ResponseVal -> m (Maybe ResponseVal)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ResponseVal -> m (Maybe ResponseVal))
-> Maybe ResponseVal -> m (Maybe ResponseVal)
forall a b. (a -> b) -> a -> b
$
          ResponseVal -> Maybe ResponseVal
forall a. a -> Maybe a
Just (ResponseVal -> Maybe ResponseVal)
-> ResponseVal -> Maybe ResponseVal
forall a b. (a -> b) -> a -> b
$
            IO Application -> ResponseVal
ResponseHandler (IO Application -> ResponseVal) -> IO Application -> ResponseVal
forall a b. (a -> b) -> a -> b
$
              do
                errHandler <- SpockConfigInternal -> Status -> IO Application
sci_errorHandler SpockConfigInternal
config Status
status404
                mw <- getMiddleware
                return $ mw errHandler
      Right () ->
        Maybe ResponseVal -> m (Maybe ResponseVal)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ResponseVal -> m (Maybe ResponseVal))
-> Maybe ResponseVal -> m (Maybe ResponseVal)
forall a b. (a -> b) -> a -> b
$ ResponseVal -> Maybe ResponseVal
forall a. a -> Maybe a
Just (ResponseState -> ResponseVal
ResponseValState ResponseState
respState)

handleRequest ::
  MonadIO m =>
  SpockConfigInternal ->
  SpockMethod ->
  (forall a. m a -> IO a) ->
  [ActionT m ()] ->
  InternalState ->
  Wai.Application ->
  Wai.Application
handleRequest :: forall (m :: * -> *).
MonadIO m =>
SpockConfigInternal
-> SpockMethod
-> (forall a. m a -> IO a)
-> [ActionT m ()]
-> InternalState
-> Middleware
handleRequest SpockConfigInternal
config SpockMethod
stdMethod forall a. m a -> IO a
registryLift [ActionT m ()]
allActions InternalState
st Application
coreApp Request
req Response -> IO ResponseReceived
respond =
  do
    reqGo <-
      case SpockConfigInternal -> Maybe Word64
sci_maxRequestSize SpockConfigInternal
config of
        Maybe Word64
Nothing -> Request -> IO Request
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Request
req
        Just Word64
lim -> Word64 -> Request -> IO Request
requestSizeCheck Word64
lim Request
req
    handleRequest' config stdMethod registryLift allActions st coreApp reqGo respond

handleRequest' ::
  MonadIO m =>
  SpockConfigInternal ->
  SpockMethod ->
  (forall a. m a -> IO a) ->
  [ActionT m ()] ->
  InternalState ->
  Wai.Application ->
  Wai.Application
handleRequest' :: forall (m :: * -> *).
MonadIO m =>
SpockConfigInternal
-> SpockMethod
-> (forall a. m a -> IO a)
-> [ActionT m ()]
-> InternalState
-> Middleware
handleRequest' SpockConfigInternal
config SpockMethod
stdMethod forall a. m a -> IO a
registryLift [ActionT m ()]
allActions InternalState
st Application
coreApp Request
req Response -> IO ResponseReceived
respond =
  do
    -- The environment only creates lazy body caches. SizeException can arise
    -- when an action consumes one of those caches, not during initialization.
    (mkEnv, vaultVar) <- SpockConfigInternal
-> InternalState
-> SpockMethod
-> Request
-> IO (RequestInfo (), TVar Vault)
makeActionEnvironment SpockConfigInternal
config InternalState
st SpockMethod
stdMethod Request
req
    mRespState <-
      registryLift (applyAction config req mkEnv allActions)
        `catches` [ Handler $ \(SizeException
_ :: SizeException) ->
                      Maybe ResponseVal -> IO (Maybe ResponseVal)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ResponseVal -> Maybe ResponseVal
forall a. a -> Maybe a
Just (ResponseVal -> Maybe ResponseVal)
-> ResponseVal -> Maybe ResponseVal
forall a b. (a -> b) -> a -> b
$ SpockConfigInternal -> Status -> ResponseVal
getErrorHandler SpockConfigInternal
config Status
status413),
                    Handler $ \(SomeException
e :: SomeException) ->
                      do
                        case SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e :: Maybe SomeAsyncException of
                          Just SomeAsyncException
_ -> SomeException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
e
                          Maybe SomeAsyncException
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                        SpockConfigInternal -> Request -> Text -> IO ()
logRequestError SpockConfigInternal
config Request
req (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
                          String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
                            String
"Spock Error while handling " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show (Request -> [Text]
Wai.pathInfo Request
req)
                              String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": "
                              String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
                        Maybe ResponseVal -> IO (Maybe ResponseVal)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ResponseVal -> IO (Maybe ResponseVal))
-> Maybe ResponseVal -> IO (Maybe ResponseVal)
forall a b. (a -> b) -> a -> b
$ ResponseVal -> Maybe ResponseVal
forall a. a -> Maybe a
Just (ResponseVal -> Maybe ResponseVal)
-> ResponseVal -> Maybe ResponseVal
forall a b. (a -> b) -> a -> b
$ SpockConfigInternal -> Status -> ResponseVal
getErrorHandler SpockConfigInternal
config Status
status500
                  ]
    case mRespState of
      Just (ResponseHandler IO Application
responseHandler) ->
        IO Application
responseHandler IO Application
-> (Application -> IO ResponseReceived) -> IO ResponseReceived
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Application
app -> Application
app Request
req Response -> IO ResponseReceived
respond
      Just ResponseVal
respState ->
        Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ ResponseVal -> Response
respStateToResponse ResponseVal
respState
      Maybe ResponseVal
Nothing ->
        do
          newVault <- STM Vault -> IO Vault
forall a. STM a -> IO a
atomically (STM Vault -> IO Vault) -> STM Vault -> IO Vault
forall a b. (a -> b) -> a -> b
$ TVar Vault -> STM Vault
forall a. TVar a -> STM a
readTVar TVar Vault
vaultVar
          let req' = Request
req {Wai.vault = V.union newVault (Wai.vault req)}
          coreApp req' respond

getErrorHandler :: SpockConfigInternal -> Status -> ResponseVal
getErrorHandler :: SpockConfigInternal -> Status -> ResponseVal
getErrorHandler SpockConfigInternal
config = IO Application -> ResponseVal
ResponseHandler (IO Application -> ResponseVal)
-> (Status -> IO Application) -> Status -> ResponseVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpockConfigInternal -> Status -> IO Application
sci_errorHandler SpockConfigInternal
config

logRequestError :: SpockConfigInternal -> Wai.Request -> T.Text -> IO ()
logRequestError :: SpockConfigInternal -> Request -> Text -> IO ()
logRequestError SpockConfigInternal
config Request
req Text
message = do
  Maybe (RequestContext, LogEventType -> IO ())
-> ((RequestContext, LogEventType -> IO ()) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (SpockConfigInternal -> Maybe RequestLogger
sci_requestLogger SpockConfigInternal
config Maybe RequestLogger
-> (RequestLogger -> Maybe (RequestContext, LogEventType -> IO ()))
-> Maybe (RequestContext, LogEventType -> IO ())
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\RequestLogger
logger -> RequestLogger
-> Request -> Maybe (RequestContext, LogEventType -> IO ())
lookupRequestLogger RequestLogger
logger Request
req)) (((RequestContext, LogEventType -> IO ()) -> IO ()) -> IO ())
-> ((RequestContext, LogEventType -> IO ()) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(RequestContext
_, LogEventType -> IO ()
emit) ->
    LogEventType -> IO ()
emit (Text -> LogEventType
ErrorLog Text
message)
  SpockConfigInternal -> Text -> IO ()
sci_logError SpockConfigInternal
config Text
message

data SizeException
  = SizeException
  deriving (Int -> SizeException -> ShowS
[SizeException] -> ShowS
SizeException -> String
(Int -> SizeException -> ShowS)
-> (SizeException -> String)
-> ([SizeException] -> ShowS)
-> Show SizeException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SizeException -> ShowS
showsPrec :: Int -> SizeException -> ShowS
$cshow :: SizeException -> String
show :: SizeException -> String
$cshowList :: [SizeException] -> ShowS
showList :: [SizeException] -> ShowS
Show, Typeable)

instance Exception SizeException

requestSizeCheck :: Word64 -> Wai.Request -> IO Wai.Request
requestSizeCheck :: Word64 -> Request -> IO Request
requestSizeCheck Word64
maxSize Request
req =
  do
    currentSize <- Word64 -> IO (IORef Word64)
forall a. a -> IO (IORef a)
newIORef Word64
0
    return $
      req
        { Wai.requestBody =
            do
              bs <- Wai.getRequestBodyChunk req
              total <-
                atomicModifyIORef currentSize $ \Word64
sz ->
                  let !nextSize :: Word64
nextSize = Word64
sz Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
bs)
                   in (Word64
nextSize, Word64
nextSize)
              if total > maxSize
                then throwIO SizeException
                else return bs
        }

buildMiddleware ::
  forall m.
  (MonadIO m) =>
  SpockConfigInternal ->
  (forall a. m a -> IO a) ->
  SpockAllT m m () ->
  IO Wai.Middleware
buildMiddleware :: forall (m :: * -> *).
MonadIO m =>
SpockConfigInternal
-> (forall a. m a -> IO a) -> SpockAllT m m () -> IO Middleware
buildMiddleware SpockConfigInternal
config forall a. m a -> IO a
registryLift SpockAllT m m ()
spockActions =
  do
    (_, getMatchingRoutes, middlewares) <-
      m ((), SpockMethod -> [Text] -> [ActionT m ()], [Middleware])
-> IO ((), SpockMethod -> [Text] -> [ActionT m ()], [Middleware])
forall a. m a -> IO a
registryLift (m ((), SpockMethod -> [Text] -> [ActionT m ()], [Middleware])
 -> IO ((), SpockMethod -> [Text] -> [ActionT m ()], [Middleware]))
-> m ((), SpockMethod -> [Text] -> [ActionT m ()], [Middleware])
-> IO ((), SpockMethod -> [Text] -> [ActionT m ()], [Middleware])
forall a b. (a -> b) -> a -> b
$ SlashPolicy
-> SpockAllT m m ()
-> m ((), SpockMethod -> [Text] -> [ActionT m ()], [Middleware])
forall (m :: * -> *) reqTypes (n :: * -> *) b middleware a.
(Monad m, Hashable reqTypes, Eq reqTypes) =>
SlashPolicy
-> RegistryT n b middleware reqTypes m a
-> m (a, reqTypes -> [Text] -> [n b], [middleware])
runRegistryWith (SpockConfigInternal -> SlashPolicy
sci_slashPolicy SpockConfigInternal
config) SpockAllT m m ()
spockActions
    let spockMiddleware = (Middleware -> Middleware -> Middleware)
-> Middleware -> [Middleware] -> Middleware
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Middleware -> Middleware -> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) Middleware
forall a. a -> a
id [Middleware]
middlewares
        app :: Wai.Application -> Wai.Application
        app Application
coreApp Request
req Response -> IO ResponseReceived
respond =
          ByteString
-> (SpockMethod -> IO ResponseReceived) -> IO ResponseReceived
forall t. ByteString -> (SpockMethod -> t) -> t
withSpockMethod (Request -> ByteString
Wai.requestMethod Request
req) ((SpockMethod -> IO ResponseReceived) -> IO ResponseReceived)
-> (SpockMethod -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$
            \SpockMethod
method ->
              do
                let allActions :: [ActionT m ()]
allActions = SpockMethod -> [Text] -> [ActionT m ()]
getMatchingRoutes SpockMethod
method (Request -> [Text]
Wai.pathInfo Request
req)
                    redirectTarget :: Maybe ByteString
redirectTarget = do
                      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (SpockConfigInternal -> SlashPolicy
sci_slashPolicy SpockConfigInternal
config SlashPolicy -> SlashPolicy -> Bool
forall a. Eq a => a -> a -> Bool
== SlashPolicy
RedirectTrailingSlashes Bool -> Bool -> Bool
&& [ActionT m ()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ActionT m ()]
allActions)
                      target <- ByteString -> Maybe ByteString
alternateSlashPath (Request -> ByteString
Wai.rawPathInfo Request
req)
                      let pieces = Request -> [Text]
Wai.pathInfo Request
req
                          alternate = if HasCallStack => ByteString -> Word8
ByteString -> Word8
BS.last (Request -> ByteString
Wai.rawPathInfo Request
req) Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
47
                            then Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
pieces Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Text]
pieces else [Text]
pieces [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
""]
                      guard (not $ null $ getMatchingRoutes method alternate)
                      pure (target <> Wai.rawQueryString req)
                case Maybe ByteString
redirectTarget of
                  Just ByteString
target -> Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
Wai.responseLBS Status
status308 [(CI ByteString
"Location", ByteString
target)] ByteString
""
                  Maybe ByteString
Nothing -> ResourceT IO ResponseReceived -> IO ResponseReceived
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO ResponseReceived -> IO ResponseReceived)
-> ResourceT IO ResponseReceived -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$
                    (InternalState -> IO ResponseReceived)
-> ResourceT IO ResponseReceived
forall (m :: * -> *) a. (InternalState -> m a) -> ResourceT m a
withInternalState ((InternalState -> IO ResponseReceived)
 -> ResourceT IO ResponseReceived)
-> (InternalState -> IO ResponseReceived)
-> ResourceT IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \InternalState
st ->
                      SpockConfigInternal
-> SpockMethod
-> (forall a. m a -> IO a)
-> [ActionT m ()]
-> InternalState
-> Middleware
forall (m :: * -> *).
MonadIO m =>
SpockConfigInternal
-> SpockMethod
-> (forall a. m a -> IO a)
-> [ActionT m ()]
-> InternalState
-> Middleware
handleRequest SpockConfigInternal
config SpockMethod
method m a -> IO a
forall a. m a -> IO a
registryLift [ActionT m ()]
allActions InternalState
st Application
coreApp Request
req Response -> IO ResponseReceived
respond
    let logging = Middleware
-> (RequestLogger -> Middleware)
-> Maybe RequestLogger
-> Middleware
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Middleware
forall a. a -> a
id RequestLogger -> Middleware
requestLoggingMiddleware (SpockConfigInternal -> Maybe RequestLogger
sci_requestLogger SpockConfigInternal
config)
    return $ logging . spockMiddleware . app

-- Keep the request's encoding verbatim and avoid network-path references or
-- browser backslash normalization. Root is never redirected to an empty URL.
alternateSlashPath :: BS.ByteString -> Maybe BS.ByteString
alternateSlashPath :: ByteString -> Maybe ByteString
alternateSlashPath ByteString
path
  | ByteString -> Bool
BS.null ByteString
path Bool -> Bool -> Bool
|| ByteString
path ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"/" Bool -> Bool -> Bool
|| Bool -> Bool
not (ByteString
"/" ByteString -> ByteString -> Bool
`BS.isPrefixOf` ByteString
path) = Maybe ByteString
forall a. Maybe a
Nothing
  | ByteString
"//" ByteString -> ByteString -> Bool
`BS.isPrefixOf` ByteString
path Bool -> Bool -> Bool
|| Word8 -> ByteString -> Bool
BS.elem Word8
92 ByteString
path = Maybe ByteString
forall a. Maybe a
Nothing
  | HasCallStack => ByteString -> Word8
ByteString -> Word8
BS.last ByteString
path Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
47 = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BS.init ByteString
path)
  | Bool
otherwise = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString
path ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/")

withSpockMethod :: forall t. Method -> (SpockMethod -> t) -> t
withSpockMethod :: forall t. ByteString -> (SpockMethod -> t) -> t
withSpockMethod ByteString
method SpockMethod -> t
cnt =
  case ByteString -> Either ByteString StdMethod
parseMethod ByteString
method of
    Left ByteString
_ ->
      SpockMethod -> t
cnt (Text -> SpockMethod
MethodCustom (Text -> SpockMethod) -> Text -> SpockMethod
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
method)
    Right StdMethod
stdMethod ->
      SpockMethod -> t
cnt (HttpMethod -> SpockMethod
MethodStandard (HttpMethod -> SpockMethod) -> HttpMethod -> SpockMethod
forall a b. (a -> b) -> a -> b
$ StdMethod -> HttpMethod
HttpMethod StdMethod
stdMethod)