{-# OPTIONS_GHC -Wno-warnings-deprecations #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
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.RWS.Strict hiding ((<>))
#if MIN_VERSION_mtl(2,2,0)
import Control.Monad.Except
#else
import Control.Monad.Error
#endif
import Control.Monad.Reader.Class ()
import Control.Monad.Trans.Control
import Control.Monad.Trans.Resource
import Data.Hashable
import Data.IORef
import Data.Maybe
import Data.Semigroup
import Data.Typeable
import Data.Word
import GHC.Generics
import Network.HTTP.Types.Header (ResponseHeaders)
import Network.HTTP.Types.Method
import Network.HTTP.Types.Status
#if MIN_VERSION_base(4,6,0)
import Prelude
#else
import Prelude hiding (catch)
#endif
import System.IO
import Web.Routing.Router
import qualified Control.Monad.Morph as MM
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 qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import qualified Data.Vault.Lazy as V
import qualified Network.Wai as Wai
import qualified Network.Wai.Parse as P

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)