{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} module Web.Spock.Internal.Wire where import Control.Applicative import Control.Concurrent.STM import Control.Exception import Control.Monad.RWS.Strict import Control.Monad.Error import Control.Monad.Reader.Class () import Control.Monad.Trans.Resource import Data.Hashable import Data.Maybe 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.Directory import Web.Routing.AbstractRouter import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL 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.Vault.Lazy as V import qualified Network.Wai as Wai import qualified Network.Wai.Parse as P instance Hashable StdMethod where hashWithSalt = hashUsing fromEnum data UploadedFile = UploadedFile { uf_name :: T.Text , uf_contentType :: T.Text , uf_tempLocation :: FilePath } data VaultIf = VaultIf { vi_modifyVault :: (V.Vault -> V.Vault) -> IO () , vi_lookupKey :: forall a. V.Key a -> IO (Maybe a) } data RequestInfo = RequestInfo { ri_request :: Wai.Request , ri_params :: HM.HashMap CaptureVar T.Text , ri_queryParams :: [(T.Text, T.Text)] , ri_files :: HM.HashMap T.Text UploadedFile , ri_vaultIf :: VaultIf } data ResponseBody = ResponseFile FilePath | ResponseLBS BSL.ByteString | ResponseRedirect T.Text deriving (Show, Eq) data ResponseState = ResponseState { rs_responseHeaders :: [(T.Text, T.Text)] , rs_status :: Status , rs_responseBody :: ResponseBody } deriving (Show, Eq) data ActionInterupt = ActionRedirect T.Text | ActionTryNext | ActionError String | ActionDone | ActionMiddlewarePass deriving (Show) instance Error ActionInterupt where noMsg = ActionError "Unkown Internal Action Error" strMsg = ActionError newtype ActionT m a = ActionT { runActionT :: ErrorT ActionInterupt (RWST RequestInfo () ResponseState m) a } deriving (Monad, Functor, Applicative, MonadIO, MonadReader RequestInfo, MonadState ResponseState, MonadError ActionInterupt) instance MonadTrans ActionT where lift = ActionT . lift . lift respStateToResponse :: ResponseState -> Wai.Response respStateToResponse (ResponseState headers status body) = case body of ResponseFile fp -> Wai.responseFile status waiHeaders fp Nothing ResponseLBS bsl -> Wai.responseLBS status waiHeaders bsl ResponseRedirect target -> Wai.responseLBS status302 (("Location", T.encodeUtf8 target) : waiHeaders) BSL.empty where waiHeaders = map (\(k, v) -> (CI.mk $ T.encodeUtf8 k, T.encodeUtf8 v)) headers errorResponse :: Status -> BSL.ByteString -> ResponseState errorResponse s e = ResponseState { rs_responseHeaders = [("Content-Type", "text/html")] , rs_status = s , rs_responseBody = ResponseLBS $ BSL.concat [ "