{-# 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
#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.ByteString.SuperBuffer as SB
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

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
showList :: [HttpMethod] -> ShowS
$cshowList :: [HttpMethod] -> ShowS
show :: HttpMethod -> String
$cshow :: HttpMethod -> String
showsPrec :: Int -> HttpMethod -> ShowS
$cshowsPrec :: Int -> HttpMethod -> ShowS
Show, HttpMethod -> HttpMethod -> Bool
(HttpMethod -> HttpMethod -> Bool)
-> (HttpMethod -> HttpMethod -> Bool) -> Eq HttpMethod
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HttpMethod -> HttpMethod -> Bool
$c/= :: HttpMethod -> HttpMethod -> Bool
== :: HttpMethod -> HttpMethod -> Bool
$c== :: HttpMethod -> HttpMethod -> Bool
Eq, HttpMethod
HttpMethod -> HttpMethod -> Bounded HttpMethod
forall a. a -> a -> Bounded a
maxBound :: HttpMethod
$cmaxBound :: HttpMethod
minBound :: HttpMethod
$cminBound :: 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
enumFromThenTo :: HttpMethod -> HttpMethod -> HttpMethod -> [HttpMethod]
$cenumFromThenTo :: HttpMethod -> HttpMethod -> HttpMethod -> [HttpMethod]
enumFromTo :: HttpMethod -> HttpMethod -> [HttpMethod]
$cenumFromTo :: HttpMethod -> HttpMethod -> [HttpMethod]
enumFromThen :: HttpMethod -> HttpMethod -> [HttpMethod]
$cenumFromThen :: HttpMethod -> HttpMethod -> [HttpMethod]
enumFrom :: HttpMethod -> [HttpMethod]
$cenumFrom :: HttpMethod -> [HttpMethod]
fromEnum :: HttpMethod -> Int
$cfromEnum :: HttpMethod -> Int
toEnum :: Int -> HttpMethod
$ctoEnum :: Int -> HttpMethod
pred :: HttpMethod -> HttpMethod
$cpred :: HttpMethod -> HttpMethod
succ :: HttpMethod -> HttpMethod
$csucc :: 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
$cto :: forall x. Rep HttpMethod x -> HttpMethod
$cfrom :: forall x. HttpMethod -> Rep HttpMethod x
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 using 'T.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
/= :: SpockMethod -> SpockMethod -> Bool
$c/= :: SpockMethod -> SpockMethod -> Bool
== :: SpockMethod -> SpockMethod -> Bool
$c== :: 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
$cto :: forall x. Rep SpockMethod x -> SpockMethod
$cfrom :: forall x. SpockMethod -> Rep SpockMethod x
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
showList :: [UploadedFile] -> ShowS
$cshowList :: [UploadedFile] -> ShowS
show :: UploadedFile -> String
$cshow :: UploadedFile -> String
showsPrec :: Int -> UploadedFile -> ShowS
$cshowsPrec :: Int -> 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
  { CacheVar v -> MVar ()
cv_lock :: !(MVar ()),
    ()
cv_makeVal :: !(IO r),
    ()
cv_value :: !(IORef (Maybe r)),
    ()
cv_read :: r -> v
  }

instance Functor CacheVar where
  fmap :: (a -> b) -> CacheVar a -> CacheVar b
fmap a -> b
f (CacheVar MVar ()
lock IO r
makeVal IORef (Maybe r)
valRef r -> a
readV) =
    CacheVar :: forall v r.
MVar () -> IO r -> IORef (Maybe r) -> (r -> v) -> CacheVar v
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 :: IO v -> IO (CacheVar v)
newCacheVar IO v
makeVal =
  do
    MVar ()
lock <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
    IORef (Maybe v)
valueR <- Maybe v -> IO (IORef (Maybe v))
forall a. a -> IO (IORef a)
newIORef Maybe v
forall a. Maybe a
Nothing
    CacheVar v -> IO (CacheVar v)
forall (m :: * -> *) a. Monad m => a -> m a
return (MVar () -> IO v -> IORef (Maybe v) -> (v -> v) -> CacheVar v
forall v r.
MVar () -> IO r -> IORef (Maybe r) -> (r -> v) -> CacheVar v
CacheVar MVar ()
lock IO v
makeVal IORef (Maybe v)
valueR v -> v
forall a. a -> a
id)

loadCacheVarOpt :: CacheVar v -> IO (Maybe v)
loadCacheVarOpt :: 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 (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 :: 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
      Maybe r
val <- IORef (Maybe r) -> IO (Maybe r)
forall a. IORef a -> IO a
readIORef IORef (Maybe r)
valRef
      case Maybe r
val of
        Just r
v -> v -> IO v
forall (m :: * -> *) a. Monad m => a -> m a
return (r -> v
readV r
v)
        Maybe r
Nothing ->
          do
            r
v <- IO r
makeVal
            IORef (Maybe r) -> Maybe r -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe r)
valRef (r -> Maybe r
forall a. a -> Maybe a
Just r
v)
            v -> IO v
forall (m :: * -> *) a. Monad m => a -> m a
return (r -> v
readV r
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
  { RequestInfo ctx -> SpockMethod
ri_method :: !SpockMethod,
    RequestInfo ctx -> Request
ri_request :: !Wai.Request,
    RequestInfo ctx -> [(Text, Text)]
ri_getParams :: ![(T.Text, T.Text)],
    RequestInfo ctx -> RequestBody
ri_reqBody :: !RequestBody,
    RequestInfo ctx -> VaultIf
ri_vaultIf :: !VaultIf,
    RequestInfo ctx -> ctx
ri_context :: !ctx
  }

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
showList :: [MultiHeader] -> ShowS
$cshowList :: [MultiHeader] -> ShowS
show :: MultiHeader -> String
$cshow :: MultiHeader -> String
showsPrec :: Int -> MultiHeader -> ShowS
$cshowsPrec :: Int -> MultiHeader -> ShowS
Show, MultiHeader -> MultiHeader -> Bool
(MultiHeader -> MultiHeader -> Bool)
-> (MultiHeader -> MultiHeader -> Bool) -> Eq MultiHeader
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MultiHeader -> MultiHeader -> Bool
$c/= :: MultiHeader -> MultiHeader -> Bool
== :: MultiHeader -> MultiHeader -> Bool
$c== :: 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
enumFromThenTo :: MultiHeader -> MultiHeader -> MultiHeader -> [MultiHeader]
$cenumFromThenTo :: MultiHeader -> MultiHeader -> MultiHeader -> [MultiHeader]
enumFromTo :: MultiHeader -> MultiHeader -> [MultiHeader]
$cenumFromTo :: MultiHeader -> MultiHeader -> [MultiHeader]
enumFromThen :: MultiHeader -> MultiHeader -> [MultiHeader]
$cenumFromThen :: MultiHeader -> MultiHeader -> [MultiHeader]
enumFrom :: MultiHeader -> [MultiHeader]
$cenumFrom :: MultiHeader -> [MultiHeader]
fromEnum :: MultiHeader -> Int
$cfromEnum :: MultiHeader -> Int
toEnum :: Int -> MultiHeader
$ctoEnum :: Int -> MultiHeader
pred :: MultiHeader -> MultiHeader
$cpred :: MultiHeader -> MultiHeader
succ :: MultiHeader -> MultiHeader
$csucc :: MultiHeader -> MultiHeader
Enum, MultiHeader
MultiHeader -> MultiHeader -> Bounded MultiHeader
forall a. a -> a -> Bounded a
maxBound :: MultiHeader
$cmaxBound :: MultiHeader
minBound :: MultiHeader
$cminBound :: 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
$cto :: forall x. Rep MultiHeader x -> MultiHeader
$cfrom :: forall x. MultiHeader -> Rep MultiHeader x
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. (Eq k, 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 :: 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 :: m (Either e a) -> ErrorT e m a
toErrorT = m (Either e a) -> ErrorT 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

type ActionT = ActionCtxT ()

newtype ActionCtxT ctx m a = ActionCtxT
  {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)
a -> ActionCtxT ctx m a
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)
ActionCtxT ctx m a
-> (a -> ActionCtxT ctx m b) -> ActionCtxT ctx m b
ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m b
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
return :: a -> ActionCtxT ctx m a
$creturn :: forall ctx (m :: * -> *) a. Monad m => a -> ActionCtxT ctx m a
>> :: 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 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
-> (a -> ActionCtxT ctx m b) -> ActionCtxT ctx m b
$cp1Monad :: forall ctx (m :: * -> *). Monad m => Applicative (ActionCtxT ctx m)
Monad,
      a -> ActionCtxT ctx m b -> ActionCtxT ctx m a
(a -> b) -> ActionCtxT ctx m a -> ActionCtxT ctx m b
(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
<$ :: a -> ActionCtxT ctx m b -> ActionCtxT ctx m a
$c<$ :: forall ctx (m :: * -> *) a b.
Functor m =>
a -> ActionCtxT ctx m b -> ActionCtxT ctx m a
fmap :: (a -> b) -> ActionCtxT ctx m a -> ActionCtxT ctx m b
$cfmap :: forall ctx (m :: * -> *) a b.
Functor m =>
(a -> b) -> ActionCtxT ctx m a -> ActionCtxT ctx m b
Functor,
      Functor (ActionCtxT ctx m)
a -> ActionCtxT ctx m a
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)
ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m b
ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m a
ActionCtxT ctx m (a -> b)
-> ActionCtxT ctx m a -> ActionCtxT ctx m b
(a -> b -> c)
-> ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m c
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
<* :: ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m a
$c<* :: forall ctx (m :: * -> *) a b.
Monad m =>
ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m a
*> :: 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 b
liftA2 :: (a -> b -> c)
-> ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m c
$cliftA2 :: forall ctx (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> ActionCtxT ctx m a -> ActionCtxT ctx m b -> ActionCtxT ctx m c
<*> :: ActionCtxT ctx m (a -> b)
-> ActionCtxT ctx m a -> ActionCtxT ctx m b
$c<*> :: forall ctx (m :: * -> *) a b.
Monad m =>
ActionCtxT ctx m (a -> b)
-> ActionCtxT ctx m a -> ActionCtxT ctx m b
pure :: a -> ActionCtxT ctx m a
$cpure :: forall ctx (m :: * -> *) a. Monad m => a -> ActionCtxT ctx m a
$cp1Applicative :: forall ctx (m :: * -> *). Monad m => Functor (ActionCtxT ctx m)
Applicative,
      Applicative (ActionCtxT ctx m)
ActionCtxT ctx m a
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)
ActionCtxT ctx m a -> ActionCtxT ctx m a -> ActionCtxT ctx m a
ActionCtxT ctx m a -> ActionCtxT ctx m [a]
ActionCtxT ctx m a -> ActionCtxT ctx m [a]
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
many :: ActionCtxT ctx m a -> ActionCtxT ctx m [a]
$cmany :: forall ctx (m :: * -> *) a.
Monad m =>
ActionCtxT ctx m a -> ActionCtxT ctx m [a]
some :: ActionCtxT ctx m a -> ActionCtxT ctx m [a]
$csome :: forall ctx (m :: * -> *) a.
Monad m =>
ActionCtxT ctx m a -> ActionCtxT ctx m [a]
<|> :: ActionCtxT ctx m a -> ActionCtxT ctx m a -> ActionCtxT ctx m a
$c<|> :: forall ctx (m :: * -> *) a.
Monad m =>
ActionCtxT ctx m a -> ActionCtxT ctx m a -> ActionCtxT ctx m a
empty :: ActionCtxT ctx m a
$cempty :: forall ctx (m :: * -> *) a. Monad m => ActionCtxT ctx m a
$cp1Alternative :: forall ctx (m :: * -> *). Monad m => Applicative (ActionCtxT ctx m)
Alternative,
      Monad (ActionCtxT ctx m)
Monad (ActionCtxT ctx m)
-> (forall a. IO a -> ActionCtxT ctx m a)
-> MonadIO (ActionCtxT ctx m)
IO a -> ActionCtxT ctx m a
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
liftIO :: IO a -> ActionCtxT ctx m a
$cliftIO :: forall ctx (m :: * -> *) a. MonadIO m => IO a -> ActionCtxT ctx m a
$cp1MonadIO :: forall ctx (m :: * -> *). MonadIO m => Monad (ActionCtxT ctx m)
MonadIO,
      MonadReader (RequestInfo ctx),
      MonadState ResponseState,
      MonadError ActionInterupt
    )

instance MonadTrans (ActionCtxT ctx) where
  lift :: 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 (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 (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance MM.MFunctor (ActionCtxT ctx) where
  hoist :: (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
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
MM.hoist 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 :: (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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        (\a
x -> (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 :: 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 :: 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 :: (RunInBase (ActionCtxT ctx m) b -> b a) -> ActionCtxT ctx m a
liftBaseWith = (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 :: StM (ActionCtxT ctx m) a -> ActionCtxT ctx m a
restoreM = 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 ()
  }

defaultSpockConfigInternal :: SpockConfigInternal
defaultSpockConfigInternal :: SpockConfigInternal
defaultSpockConfigInternal =
  Maybe Word64
-> (Status -> IO Application)
-> (Text -> IO ())
-> SpockConfigInternal
SpockConfigInternal Maybe Word64
forall a. Maybe a
Nothing Status -> IO Application
forall (m :: * -> *) p t.
Monad m =>
Status -> m (p -> (Response -> t) -> t)
defaultErrorHandler (Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr)
  where
    defaultErrorHandler :: Status -> m (p -> (Response -> t) -> t)
defaultErrorHandler Status
status = (p -> (Response -> t) -> t) -> m (p -> (Response -> t) -> t)
forall (m :: * -> *) a. Monad m => a -> m a
return ((p -> (Response -> t) -> t) -> m (p -> (Response -> t) -> t))
-> (p -> (Response -> t) -> t) -> m (p -> (Response -> t) -> t)
forall a b. (a -> b) -> a -> b
$ \p
_ 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 :: HashMap (CI ByteString) ByteString
-> HashMap MultiHeader [ByteString]
-> Status
-> ResponseBody
-> ResponseState
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 :: HashMap (CI ByteString) ByteString
-> HashMap MultiHeader [ByteString]
-> Status
-> ResponseBody
-> ResponseState
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 ::
  InternalState -> SpockMethod -> Wai.Request -> IO (RequestInfo (), TVar V.Vault)
makeActionEnvironment :: InternalState
-> SpockMethod -> Request -> IO (RequestInfo (), TVar Vault)
makeActionEnvironment InternalState
st SpockMethod
stdMethod Request
req =
  do
    TVar Vault
vaultVar <- IO (TVar Vault) -> IO (TVar Vault)
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
vaultIf =
          VaultIf :: ((Vault -> Vault) -> IO ())
-> (forall a. Key a -> IO (Maybe a)) -> 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 :: [(Text, Text)]
getParams =
          ((ByteString, Maybe ByteString) -> (Text, Text))
-> [(ByteString, Maybe ByteString)] -> [(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)) ([(ByteString, Maybe ByteString)] -> [(Text, Text)])
-> [(ByteString, Maybe ByteString)] -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ Request -> [(ByteString, Maybe ByteString)]
Wai.queryString Request
req
    CacheVar ByteString
rbValue <-
      IO ByteString -> IO (CacheVar ByteString)
forall v. IO v -> IO (CacheVar v)
newCacheVar (IO ByteString -> IO (CacheVar ByteString))
-> IO ByteString -> IO (CacheVar ByteString)
forall a b. (a -> b) -> a -> b
$
        do
          let parseBody :: IO ByteString
parseBody = Request -> IO ByteString
Wai.getRequestBodyChunk Request
req
              bodyLength :: RequestBodyLength
bodyLength = Request -> RequestBodyLength
Wai.requestBodyLength Request
req
              buffStart :: Int64
buffStart =
                case RequestBodyLength
bodyLength of
                  RequestBodyLength
Wai.ChunkedBody -> Int64
1024
                  Wai.KnownLength Word64
x -> Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
x
          Int64 -> (SuperBuffer -> IO ()) -> IO ByteString
SB.withBuffer Int64
buffStart ((SuperBuffer -> IO ()) -> IO ByteString)
-> (SuperBuffer -> IO ()) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \SuperBuffer
sb ->
            do
              let loop :: IO ()
loop =
                    do
                      ByteString
b <- IO ByteString
parseBody
                      if ByteString -> Bool
BS.null ByteString
b then () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () else (SuperBuffer -> ByteString -> IO ()
SB.appendBuffer SuperBuffer
sb ByteString
b IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
loop)
              IO ()
loop
    CacheVar ([(Text, Text)], HashMap Text UploadedFile)
bodyTuple <-
      IO ([(Text, Text)], HashMap Text UploadedFile)
-> IO (CacheVar ([(Text, Text)], HashMap Text UploadedFile))
forall v. IO v -> IO (CacheVar v)
newCacheVar (IO ([(Text, Text)], HashMap Text UploadedFile)
 -> IO (CacheVar ([(Text, Text)], HashMap Text UploadedFile)))
-> IO ([(Text, Text)], HashMap Text UploadedFile)
-> IO (CacheVar ([(Text, Text)], HashMap Text UploadedFile))
forall a b. (a -> b) -> a -> b
$
        case Request -> Maybe RequestBodyType
P.getRequestBodyType Request
req of
          Maybe RequestBodyType
Nothing -> ([(Text, Text)], HashMap Text UploadedFile)
-> IO ([(Text, Text)], HashMap Text UploadedFile)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], HashMap Text UploadedFile
forall k v. HashMap k v
HM.empty)
          Just RequestBodyType
rbt ->
            do
              ByteString
bodyBs <- CacheVar ByteString -> IO ByteString
forall v. CacheVar v -> IO v
loadCacheVar CacheVar ByteString
rbValue
              IORef (Maybe ByteString)
bodyRef <- Maybe ByteString -> IO (IORef (Maybe ByteString))
forall a. a -> IO (IORef a)
newIORef (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bodyBs)
              let loader :: IO ByteString
loader =
                    do
                      Maybe ByteString
mb <- IORef (Maybe ByteString) -> IO (Maybe ByteString)
forall a. IORef a -> IO a
readIORef IORef (Maybe ByteString)
bodyRef
                      case Maybe ByteString
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
b
                        Maybe ByteString
Nothing -> ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
BS.empty
              ([Param]
bodyParams, [File String]
bodyFiles) <-
                BackEnd String
-> RequestBodyType -> IO ByteString -> IO ([Param], [File String])
forall y.
BackEnd y
-> RequestBodyType -> IO ByteString -> IO ([Param], [File y])
P.sinkRequestBody (InternalState -> BackEnd String
forall ignored1 ignored2.
InternalState -> ignored1 -> ignored2 -> IO ByteString -> IO String
P.tempFileBackEnd InternalState
st) RequestBodyType
rbt IO ByteString
loader
              let uploadedFiles :: HashMap Text UploadedFile
uploadedFiles =
                    [(Text, UploadedFile)] -> HashMap Text UploadedFile
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Text, UploadedFile)] -> HashMap Text UploadedFile)
-> [(Text, UploadedFile)] -> HashMap Text UploadedFile
forall a b. (a -> b) -> a -> b
$
                      ((File String -> (Text, UploadedFile))
 -> [File String] -> [(Text, UploadedFile)])
-> [File String]
-> (File String -> (Text, UploadedFile))
-> [(Text, UploadedFile)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (File String -> (Text, UploadedFile))
-> [File String] -> [(Text, UploadedFile)]
forall a b. (a -> b) -> [a] -> [b]
map [File String]
bodyFiles ((File String -> (Text, UploadedFile)) -> [(Text, UploadedFile)])
-> (File String -> (Text, UploadedFile)) -> [(Text, UploadedFile)]
forall a b. (a -> b) -> a -> b
$ \(ByteString
k, FileInfo String
fileInfo) ->
                        ( 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 :: [(Text, Text)]
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 (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ByteString -> Text
T.decodeUtf8) [Param]
bodyParams
              ([(Text, Text)], HashMap Text UploadedFile)
-> IO ([(Text, Text)], HashMap Text UploadedFile)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Text, Text)]
postParams, HashMap Text UploadedFile
uploadedFiles)
    let reqBody :: RequestBody
reqBody =
          RequestBody :: CacheVar ByteString
-> CacheVar [(Text, Text)]
-> CacheVar (HashMap Text UploadedFile)
-> RequestBody
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 (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 (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
            }
    (RequestInfo (), TVar Vault) -> IO (RequestInfo (), TVar Vault)
forall (m :: * -> *) a. Monad m => a -> m a
return
      ( RequestInfo :: forall ctx.
SpockMethod
-> Request
-> [(Text, Text)]
-> RequestBody
-> VaultIf
-> ctx
-> RequestInfo ctx
RequestInfo
          { ri_method :: SpockMethod
ri_method = SpockMethod
stdMethod,
            ri_request :: Request
ri_request = Request
req,
            ri_getParams :: [(Text, Text)]
ri_getParams = [(Text, Text)]
getParams,
            ri_reqBody :: RequestBody
ri_reqBody = RequestBody
reqBody,
            ri_vaultIf :: VaultIf
ri_vaultIf = VaultIf
vaultIf,
            ri_context :: ()
ri_context = ()
          },
        TVar Vault
vaultVar
      )

applyAction ::
  MonadIO m =>
  SpockConfigInternal ->
  Wai.Request ->
  RequestInfo () ->
  [ActionT m ()] ->
  m (Maybe ResponseVal)
applyAction :: SpockConfigInternal
-> Request
-> RequestInfo ()
-> [ActionT m ()]
-> m (Maybe ResponseVal)
applyAction SpockConfigInternal
config Request
_ RequestInfo ()
_ [] =
  Maybe ResponseVal -> m (Maybe ResponseVal)
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
    (Either ActionInterupt ()
r, ResponseState
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 Either ActionInterupt ()
r of
      Left (ActionRedirect Text
loc) ->
        Maybe ResponseVal -> m (Maybe ResponseVal)
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 :: Status
rs_status = Status
status302,
                  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 ((CI ByteString
"Location", Text -> ByteString
T.encodeUtf8 Text
loc) (CI ByteString, ByteString) -> 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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
            SpockConfigInternal -> Text -> IO ()
sci_logError SpockConfigInternal
config (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 (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 (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 (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 (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 (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
                Application
errHandler <- SpockConfigInternal -> Status -> IO Application
sci_errorHandler SpockConfigInternal
config Status
status404
                Middleware
mw <- IO Middleware
getMiddleware
                Application -> IO Application
forall (m :: * -> *) a. Monad m => a -> m a
return (Application -> IO Application) -> Application -> IO Application
forall a b. (a -> b) -> a -> b
$ Middleware
mw Application
errHandler
      Right () ->
        Maybe ResponseVal -> m (Maybe ResponseVal)
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 :: 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
    Request
reqGo <-
      case SpockConfigInternal -> Maybe Word64
sci_maxRequestSize SpockConfigInternal
config of
        Maybe Word64
Nothing -> Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return Request
req
        Just Word64
lim -> Word64 -> Request -> IO Request
requestSizeCheck Word64
lim Request
req
    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
stdMethod forall a. m a -> IO a
registryLift [ActionT m ()]
allActions InternalState
st Application
coreApp Request
reqGo Response -> IO ResponseReceived
respond

handleRequest' ::
  MonadIO m =>
  SpockConfigInternal ->
  SpockMethod ->
  (forall a. m a -> IO a) ->
  [ActionT m ()] ->
  InternalState ->
  Wai.Application ->
  Wai.Application
handleRequest' :: 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
    Either (RequestInfo (), TVar Vault) ResponseVal
actEnv <-
      ((RequestInfo (), TVar Vault)
-> Either (RequestInfo (), TVar Vault) ResponseVal
forall a b. a -> Either a b
Left ((RequestInfo (), TVar Vault)
 -> Either (RequestInfo (), TVar Vault) ResponseVal)
-> IO (RequestInfo (), TVar Vault)
-> IO (Either (RequestInfo (), TVar Vault) ResponseVal)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InternalState
-> SpockMethod -> Request -> IO (RequestInfo (), TVar Vault)
makeActionEnvironment InternalState
st SpockMethod
stdMethod Request
req)
        IO (Either (RequestInfo (), TVar Vault) ResponseVal)
-> (SizeException
    -> IO (Either (RequestInfo (), TVar Vault) ResponseVal))
-> IO (Either (RequestInfo (), TVar Vault) ResponseVal)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SizeException
_ :: SizeException) ->
          Either (RequestInfo (), TVar Vault) ResponseVal
-> IO (Either (RequestInfo (), TVar Vault) ResponseVal)
forall (m :: * -> *) a. Monad m => a -> m a
return (ResponseVal -> Either (RequestInfo (), TVar Vault) ResponseVal
forall a b. b -> Either a b
Right (ResponseVal -> Either (RequestInfo (), TVar Vault) ResponseVal)
-> ResponseVal -> Either (RequestInfo (), TVar Vault) ResponseVal
forall a b. (a -> b) -> a -> b
$ SpockConfigInternal -> Status -> ResponseVal
getErrorHandler SpockConfigInternal
config Status
status413)
    case Either (RequestInfo (), TVar Vault) ResponseVal
actEnv of
      Left (RequestInfo ()
mkEnv, TVar Vault
vaultVar) ->
        do
          Maybe ResponseVal
mRespState <-
            m (Maybe ResponseVal) -> IO (Maybe ResponseVal)
forall a. m a -> IO a
registryLift (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 ()
mkEnv [ActionT m ()]
allActions)
              IO (Maybe ResponseVal)
-> [Handler (Maybe ResponseVal)] -> IO (Maybe ResponseVal)
forall a. IO a -> [Handler a] -> IO a
`catches` [ (SizeException -> IO (Maybe ResponseVal))
-> Handler (Maybe ResponseVal)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((SizeException -> IO (Maybe ResponseVal))
 -> Handler (Maybe ResponseVal))
-> (SizeException -> IO (Maybe ResponseVal))
-> Handler (Maybe ResponseVal)
forall a b. (a -> b) -> a -> b
$ \(SizeException
_ :: SizeException) ->
                            Maybe ResponseVal -> IO (Maybe ResponseVal)
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),
                          (SomeException -> IO (Maybe ResponseVal))
-> Handler (Maybe ResponseVal)
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((SomeException -> IO (Maybe ResponseVal))
 -> Handler (Maybe ResponseVal))
-> (SomeException -> IO (Maybe ResponseVal))
-> Handler (Maybe ResponseVal)
forall a b. (a -> b) -> a -> b
$ \(SomeException
e :: SomeException) ->
                            do
                              SpockConfigInternal -> Text -> IO ()
sci_logError SpockConfigInternal
config (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 (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 Maybe ResponseVal
mRespState of
            Just (ResponseHandler IO Application
responseHandler) ->
              IO Application
responseHandler IO Application
-> (Application -> IO ResponseReceived) -> IO ResponseReceived
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
                Vault
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' = Request
req {vault :: Vault
Wai.vault = Vault -> Vault -> Vault
V.union Vault
newVault (Request -> Vault
Wai.vault Request
req)}
                Application
coreApp Request
req' Response -> IO ResponseReceived
respond
      Right ResponseVal
respState ->
        Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ ResponseVal -> Response
respStateToResponse ResponseVal
respState

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

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
showList :: [SizeException] -> ShowS
$cshowList :: [SizeException] -> ShowS
show :: SizeException -> String
$cshow :: SizeException -> String
showsPrec :: Int -> SizeException -> ShowS
$cshowsPrec :: Int -> 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
    IORef Word64
currentSize <- Word64 -> IO (IORef Word64)
forall a. a -> IO (IORef a)
newIORef Word64
0
    Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> IO Request) -> Request -> IO Request
forall a b. (a -> b) -> a -> b
$
      Request
req
        { requestBody :: IO ByteString
Wai.requestBody =
            do
              ByteString
bs <- Request -> IO ByteString
Wai.getRequestBodyChunk Request
req
              Word64
total <-
                IORef Word64 -> (Word64 -> (Word64, Word64)) -> IO Word64
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Word64
currentSize ((Word64 -> (Word64, Word64)) -> IO Word64)
-> (Word64 -> (Word64, Word64)) -> IO Word64
forall a b. (a -> b) -> a -> b
$ \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 Word64
total Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
maxSize
                then SizeException -> IO ByteString
forall e a. Exception e => e -> IO a
throwIO SizeException
SizeException
                else ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
        }

buildMiddleware ::
  forall m.
  (MonadIO m) =>
  SpockConfigInternal ->
  (forall a. m a -> IO a) ->
  SpockAllT m m () ->
  IO Wai.Middleware
buildMiddleware :: 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
    (()
_, SpockMethod -> [Text] -> [ActionT m ()]
getMatchingRoutes, [Middleware]
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
$ SpockAllT m m ()
-> m ((), SpockMethod -> [Text] -> [ActionT m ()], [Middleware])
forall (m :: * -> *) reqTypes (n :: * -> *) b middleware a.
(Monad m, Hashable reqTypes, Eq reqTypes) =>
RegistryT n b middleware reqTypes m a
-> m (a, reqTypes -> [Text] -> [n b], [middleware])
runRegistry SpockAllT m m ()
spockActions
    let spockMiddleware :: Middleware
spockMiddleware = (Middleware -> Middleware -> Middleware)
-> Middleware -> [Middleware] -> Middleware
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 :: Middleware
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)
                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 forall a. m a -> IO a
registryLift [ActionT m ()]
allActions InternalState
st Application
coreApp Request
req Response -> IO ResponseReceived
respond
    Middleware -> IO Middleware
forall (m :: * -> *) a. Monad m => a -> m a
return (Middleware -> IO Middleware) -> Middleware -> IO Middleware
forall a b. (a -> b) -> a -> b
$ Middleware
spockMiddleware Middleware -> Middleware -> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Middleware
app

withSpockMethod :: forall t. Method -> (SpockMethod -> t) -> t
withSpockMethod :: 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)