{-# LANGUAGE GADTs #-} {-# 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.Applicative import Control.Arrow ((***)) import Control.Concurrent.MVar 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.Router 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.Vault.Lazy as V import qualified Network.Wai as Wai import qualified Network.Wai.Parse as P newtype HttpMethod = HttpMethod { unHttpMethod :: StdMethod } deriving (Show, Eq, Generic) instance Hashable HttpMethod where hashWithSalt = hashUsing (fromEnum . 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 deriving (Eq, Generic) instance Hashable SpockMethod data UploadedFile = UploadedFile { uf_name :: !T.Text , uf_contentType :: !T.Text , uf_tempLocation :: !FilePath } deriving Show data VaultIf = VaultIf { vi_modifyVault :: (V.Vault -> V.Vault) -> IO () , vi_lookupKey :: forall a. V.Key a -> IO (Maybe a) } data CacheVar v = forall r. CacheVar { cv_lock :: !(MVar ()) , cv_makeVal :: !(IO r) , cv_value :: !(IORef (Maybe r)) , cv_read :: r -> v } instance Functor CacheVar where fmap f (CacheVar lock makeVal valRef readV) = CacheVar { cv_lock = lock , cv_makeVal = makeVal , cv_value = valRef , cv_read = f . readV } newCacheVar :: IO v -> IO (CacheVar v) newCacheVar makeVal = do lock <- newEmptyMVar valueR <- newIORef Nothing return (CacheVar lock makeVal valueR id) loadCacheVarOpt :: CacheVar v -> IO (Maybe v) loadCacheVarOpt (CacheVar lock _ valRef readV) = bracket_ (putMVar lock ()) (takeMVar lock) $ fmap readV <$> readIORef valRef loadCacheVar :: CacheVar v -> IO v loadCacheVar (CacheVar lock makeVal valRef readV) = bracket_ (putMVar lock ()) (takeMVar lock) $ do val <- readIORef valRef case val of Just v -> return (readV v) Nothing -> do v <- makeVal writeIORef valRef (Just v) return (readV v) data RequestBody = RequestBody { rb_value :: CacheVar BS.ByteString , rb_postParams :: CacheVar [(T.Text, T.Text)] , rb_files :: CacheVar (HM.HashMap T.Text UploadedFile) } data RequestInfo ctx = RequestInfo { ri_method :: !SpockMethod , ri_request :: !Wai.Request , ri_getParams :: ![(T.Text, T.Text)] , ri_reqBody :: !RequestBody , 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 ResponseVal = ResponseValState !ResponseState | ResponseHandler !(IO Wai.Application) 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 | ActionMiddleware !(IO Wai.Middleware) | ActionApplication !(IO Wai.Application) deriving 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 data SpockConfigInternal = SpockConfigInternal { sci_maxRequestSize :: Maybe Word64 , sci_errorHandler :: Status -> IO Wai.Application } defaultSpockConfigInternal :: SpockConfigInternal defaultSpockConfigInternal = SpockConfigInternal Nothing defaultErrorHandler where defaultErrorHandler status = return $ \_ respond -> do let errorMessage = "Error handler failed with status code " ++ (show $ statusCode status) respond $ Wai.responseLBS status500 [] $ BSLC.pack errorMessage respStateToResponse :: ResponseVal -> Wai.Response respStateToResponse (ResponseValState (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 respStateToResponse _ = error "ResponseState expected" errorResponse :: Status -> BSL.ByteString -> ResponseVal errorResponse s e = ResponseValState $ 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 [ "