{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Web.Spock.Wire where import Web.Spock.Routing import Control.Applicative import Control.Exception import Control.Monad.RWS.Strict 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 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 Network.Wai as Wai import qualified Network.Wai.Parse as P instance Hashable StdMethod where hashWithSalt = hashUsing fromEnum type SpockRoutingTree m = RoutingTree (ActionT m ()) type SpockTreeMap m = HM.HashMap StdMethod (SpockRoutingTree m) type SpockRouteMap m = HM.HashMap StdMethod (HM.HashMap T.Text (ActionT m ())) data SpockState m = SpockState { ss_treeMap :: !(SpockRouteMap m) , ss_middleware :: Wai.Middleware , ss_spockLift :: forall a. m a -> IO a } data UploadedFile = UploadedFile { uf_name :: T.Text , uf_contentType :: T.Text , uf_tempLocation :: FilePath } 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 } data ResponseBody = ResponseFile FilePath | ResponseLBS BSL.ByteString | ResponseRedirect T.Text data ResponseState = ResponseState { rs_responseHeaders :: [(T.Text, T.Text)] , rs_status :: Status , rs_responseBody :: ResponseBody } type BaseRoute = T.Text newtype ActionT m a = ActionT { runActionT :: RWST RequestInfo () ResponseState m a } deriving (Monad, Functor, Applicative, MonadIO, MonadTrans, MonadReader RequestInfo, MonadState ResponseState) newtype SpockT (m :: * -> *) a = SpockT { runSpockT :: RWST BaseRoute () (SpockState m) m a } deriving (Monad, Functor, Applicative, MonadIO, MonadReader BaseRoute, MonadState (SpockState m)) instance MonadTrans SpockT where lift = SpockT . 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)] 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 [ "