{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} module Web.Spock.Internal.Wire where import Control.Arrow ((***)) import Control.Applicative import Control.Concurrent.STM import Control.Exception import Control.Monad.RWS.Strict #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.Resource import Data.Hashable import Data.IORef import Data.Maybe 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.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 ctx = RequestInfo { ri_method :: !StdMethod , 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 , 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 (Show, Eq, Enum, Bounded, Generic) instance Hashable MultiHeader multiHeaderCI :: MultiHeader -> CI.CI BS.ByteString multiHeaderCI mh = case mh of MultiHeaderCacheControl -> "Cache-Control" MultiHeaderConnection -> "Connection" MultiHeaderContentEncoding -> "Content-Encoding" MultiHeaderContentLanguage -> "Content-Language" MultiHeaderPragma -> "Pragma" MultiHeaderProxyAuthenticate -> "Proxy-Authenticate" MultiHeaderTrailer -> "Trailer" MultiHeaderTransferEncoding -> "Transfer-Encoding" MultiHeaderUpgrade -> "Upgrade" MultiHeaderVia -> "Via" MultiHeaderWarning -> "Warning" MultiHeaderWWWAuth -> "WWW-Authenticate" MultiHeaderSetCookie -> "Set-Cookie" multiHeaderMap :: HM.HashMap (CI.CI BS.ByteString) MultiHeader multiHeaderMap = HM.fromList $ flip map allHeaders $ \mh -> (multiHeaderCI mh, 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 = [ MultiHeaderCacheControl , MultiHeaderConnection , MultiHeaderContentEncoding , MultiHeaderContentLanguage , MultiHeaderPragma , MultiHeaderProxyAuthenticate , MultiHeaderTrailer , MultiHeaderTransferEncoding , MultiHeaderUpgrade , MultiHeaderVia , MultiHeaderWarning , MultiHeaderWWWAuth , MultiHeaderSetCookie ] data ResponseState = ResponseState { rs_responseHeaders :: !(HM.HashMap (CI.CI BS.ByteString) BS.ByteString) , rs_multiResponseHeaders :: !(HM.HashMap MultiHeader [BS.ByteString]) , rs_status :: !Status , rs_responseBody :: !ResponseBody } data ActionInterupt = ActionRedirect !T.Text | ActionTryNext | ActionError String | ActionDone | ActionMiddlewarePass deriving (Show, Typeable) instance Monoid ActionInterupt where mempty = ActionDone mappend _ a = a #if MIN_VERSION_mtl(2,2,0) type ErrorT = ExceptT runErrorT :: ExceptT e m a -> m (Either e a) runErrorT = runExceptT #else instance Error ActionInterupt where noMsg = ActionError "Unkown Internal Action Error" strMsg = ActionError #endif type ActionT = ActionCtxT () newtype ActionCtxT ctx m a = ActionCtxT { runActionCtxT :: ErrorT ActionInterupt (RWST (RequestInfo ctx) () ResponseState m) a } deriving (Monad, Functor, Applicative, Alternative, MonadIO, MonadReader (RequestInfo ctx), MonadState ResponseState, MonadError ActionInterupt) instance MonadTrans (ActionCtxT ctx) where lift = ActionCtxT . lift . lift respStateToResponse :: ResponseState -> Wai.Response respStateToResponse (ResponseState headers multiHeaders status (ResponseBody body)) = let mkMultiHeader (k, vals) = let kCi = multiHeaderCI k in map (\v -> (kCi, v)) vals outHeaders = HM.toList headers ++ (concatMap mkMultiHeader $ HM.toList multiHeaders) in body status outHeaders errorResponse :: Status -> BSL.ByteString -> ResponseState errorResponse s e = ResponseState { rs_responseHeaders = HM.singleton "Content-Type" "text/html" , rs_multiResponseHeaders = HM.empty , rs_status = s , rs_responseBody = ResponseBody $ \status headers -> Wai.responseLBS status headers $ BSL.concat [ "