module Happstack.Server.Internal.Types
(Request(..), Response(..), RqBody(..), Input(..), HeaderPair(..),
takeRequestBody, readInputsBody,
rqURL, mkHeaders,
getHeader, getHeaderBS, getHeaderUnsafe,
hasHeader, hasHeaderBS, hasHeaderUnsafe,
setHeader, setHeaderBS, setHeaderUnsafe,
addHeader, addHeaderBS, addHeaderUnsafe,
setRsCode,
Conf(..), nullConf, result, resultBS,
redirect,
isHTTP1_0, isHTTP1_1,
RsFlags(..), nullRsFlags, contentLength, chunked, noContentLength,
HttpVersion(..), Length(..), Method(..), Headers, continueHTTP,
Host, ContentType(..)
) where
import Control.Monad.Error (Error(strMsg))
import Control.Monad.Trans (MonadIO(liftIO))
import Control.Concurrent.MVar
import qualified Data.Map as M
import Data.Data (Data)
import Data.IORef (IORef, atomicModifyIORef, readIORef)
import Data.Time.Format (FormatTime(..))
import Data.Typeable(Typeable)
import qualified Data.ByteString.Char8 as P
import Data.ByteString.Char8 (ByteString,pack)
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.ByteString.Lazy.UTF8 as LU (fromString)
import Data.Maybe
import Data.List
import Happstack.Server.SURI
import Data.Char (toLower)
import Happstack.Server.Internal.RFC822Headers ( ContentType(..) )
import Happstack.Server.Internal.Cookie
import Happstack.Util.LogFormat (formatRequestCombined)
import System.Log.Logger (Priority(..), logM)
import Text.Show.Functions ()
data HttpVersion = HttpVersion Int Int
deriving(Read,Eq)
instance Show HttpVersion where
show (HttpVersion x y) = (show x) ++ "." ++ (show y)
isHTTP1_1 :: Request -> Bool
isHTTP1_1 rq = case rqVersion rq of HttpVersion 1 1 -> True; _ -> False
isHTTP1_0 :: Request -> Bool
isHTTP1_0 rq = case rqVersion rq of HttpVersion 1 0 -> True; _ -> False
continueHTTP :: Request -> Response -> Bool
continueHTTP rq res = (isHTTP1_0 rq && checkHeaderBS connectionC keepaliveC rq && rsfLength (rsFlags res) == ContentLength) ||
(isHTTP1_1 rq && not (checkHeaderBS connectionC closeC rq) && rsfLength (rsFlags res) /= NoContentLength)
data Conf = Conf { port :: Int
, validator :: Maybe (Response -> IO Response)
, logAccess :: forall t. FormatTime t => Maybe (String -> String -> t -> String -> Int -> Integer -> String -> String -> IO ())
, timeout :: Int
}
nullConf :: Conf
nullConf = Conf { port = 8000
, validator = Nothing
, logAccess = Just logMAccess
, timeout = 30
}
logMAccess host user time requestLine responseCode size referer userAgent =
logM "Happstack.Server.AccessLog.Combined" INFO $ formatRequestCombined host user time requestLine responseCode size referer userAgent
data Method = GET | HEAD | POST | PUT | DELETE | TRACE | OPTIONS | CONNECT
deriving(Show,Read,Eq,Ord,Typeable,Data)
data HeaderPair
= HeaderPair { hName :: ByteString
, hValue :: [ByteString]
}
deriving (Read,Show)
type Headers = M.Map ByteString HeaderPair
data Length
= ContentLength
| TransferEncodingChunked
| NoContentLength
deriving (Eq, Ord, Read, Show, Enum)
data RsFlags = RsFlags
{ rsfLength :: Length
} deriving (Show,Read,Typeable)
nullRsFlags :: RsFlags
nullRsFlags = RsFlags { rsfLength = TransferEncodingChunked }
noContentLength :: Response -> Response
noContentLength res = res { rsFlags = flags } where flags = (rsFlags res) { rsfLength = NoContentLength }
chunked :: Response -> Response
chunked res = res { rsFlags = flags } where flags = (rsFlags res) { rsfLength = TransferEncodingChunked }
contentLength :: Response -> Response
contentLength res = res { rsFlags = flags } where flags = (rsFlags res) { rsfLength = ContentLength }
data Input = Input
{ inputValue :: Either FilePath L.ByteString
, inputFilename :: Maybe FilePath
, inputContentType :: ContentType
} deriving (Show,Read,Typeable)
type Host = (String, Int)
data Response = Response { rsCode :: Int,
rsHeaders :: Headers,
rsFlags :: RsFlags,
rsBody :: L.ByteString,
rsValidator :: Maybe (Response -> IO Response)
}
| SendFile { rsCode :: Int,
rsHeaders :: Headers,
rsFlags :: RsFlags,
rsValidator :: Maybe (Response -> IO Response),
sfFilePath :: FilePath,
sfOffset :: Integer,
sfCount :: Integer
}
deriving (Typeable)
instance Show Response where
showsPrec _ res@Response{} =
showString "================== Response ================" .
showString "\nrsCode = " . shows (rsCode res) .
showString "\nrsHeaders = " . shows (rsHeaders res) .
showString "\nrsFlags = " . shows (rsFlags res) .
showString "\nrsBody = " . shows (rsBody res) .
showString "\nrsValidator = " . shows (rsValidator res)
showsPrec _ res@SendFile{} =
showString "================== Response ================" .
showString "\nrsCode = " . shows (rsCode res) .
showString "\nrsHeaders = " . shows (rsHeaders res) .
showString "\nrsFlags = " . shows (rsFlags res) .
showString "\nrsValidator = " . shows (rsValidator res).
showString "\nsfFilePath = " . shows (sfFilePath res) .
showString "\nsfOffset = " . shows (sfOffset res) .
showString "\nsfCount = " . shows (sfCount res)
instance Error Response where
strMsg str =
setHeader "Content-Type" "text/plain; charset=UTF-8" $
result 500 str
data Request = Request { rqMethod :: Method,
rqPaths :: [String],
rqUri :: String,
rqQuery :: String,
rqInputsQuery :: [(String,Input)],
rqInputsBody :: MVar [(String,Input)],
rqCookies :: [(String,Cookie)],
rqVersion :: HttpVersion,
rqHeaders :: Headers,
rqBody :: MVar RqBody,
rqPeer :: Host
} deriving(Typeable)
instance Show Request where
showsPrec _ rq =
showString "================== Request =================" .
showString "\nrqMethod = " . shows (rqMethod rq) .
showString "\nrqPaths = " . shows (rqPaths rq) .
showString "\nrqUri = " . showString (rqUri rq) .
showString "\nrqQuery = " . showString (rqQuery rq) .
showString "\nrqInputsQuery = " . shows (rqInputsQuery rq) .
showString "\nrqInputsBody = " . showString "<<mvar>>" .
showString "\nrqCookies = " . shows (rqCookies rq) .
showString "\nrqVersion = " . shows (rqVersion rq) .
showString "\nrqHeaders = " . shows (rqHeaders rq) .
showString "\nrqBody = " . showString "<<mvar>>" .
showString "\nrqPeer = " . shows (rqPeer rq)
takeRequestBody :: (MonadIO m) => Request -> m (Maybe RqBody)
takeRequestBody rq = liftIO $ tryTakeMVar (rqBody rq)
readInputsBody :: Request -> IO (Maybe [(String, Input)])
readInputsBody req =
do mbi <- tryTakeMVar (rqInputsBody req)
case mbi of
(Just bi) ->
do putMVar (rqInputsBody req) bi
return (Just bi)
Nothing -> return Nothing
rqURL :: Request -> String
rqURL rq = '/':intercalate "/" (rqPaths rq) ++ (rqQuery rq)
class HasHeaders a where
updateHeaders :: (Headers->Headers) -> a -> a
headers :: a -> Headers
instance HasHeaders Response where updateHeaders f rs = rs{rsHeaders=f $ rsHeaders rs}
headers = rsHeaders
instance HasHeaders Request where updateHeaders f rq = rq{rqHeaders = f $ rqHeaders rq}
headers = rqHeaders
instance HasHeaders Headers where updateHeaders f = f
headers = id
newtype RqBody = Body { unBody :: L.ByteString } deriving (Read,Show,Typeable)
setRsCode :: (Monad m) => Int -> Response -> m Response
setRsCode code rs = return rs {rsCode = code}
mkHeaders :: [(String,String)] -> Headers
mkHeaders hdrs
= M.fromListWith join [ (P.pack (map toLower key), HeaderPair (P.pack key) [P.pack value]) | (key,value) <- hdrs ]
where join (HeaderPair key vs1) (HeaderPair _ vs2) = HeaderPair key (vs1++vs2)
getHeader :: HasHeaders r => String -> r -> Maybe ByteString
getHeader = getHeaderBS . pack
getHeaderBS :: HasHeaders r => ByteString -> r -> Maybe ByteString
getHeaderBS = getHeaderUnsafe . P.map toLower
getHeaderUnsafe :: HasHeaders r => ByteString -> r -> Maybe ByteString
getHeaderUnsafe key var = listToMaybe =<< fmap hValue (getHeaderUnsafe' key var)
getHeaderUnsafe' :: HasHeaders r => ByteString -> r -> Maybe HeaderPair
getHeaderUnsafe' key = M.lookup key . headers
hasHeader :: HasHeaders r => String -> r -> Bool
hasHeader key r = isJust (getHeader key r)
hasHeaderBS :: HasHeaders r => ByteString -> r -> Bool
hasHeaderBS key r = isJust (getHeaderBS key r)
hasHeaderUnsafe :: HasHeaders r => ByteString -> r -> Bool
hasHeaderUnsafe key r = isJust (getHeaderUnsafe' key r)
checkHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> Bool
checkHeaderBS key val = checkHeaderUnsafe (P.map toLower key) (P.map toLower val)
checkHeaderUnsafe :: HasHeaders r => ByteString -> ByteString -> r -> Bool
checkHeaderUnsafe key val r
= case getHeaderUnsafe key r of
Just val' | P.map toLower val' == val -> True
_ -> False
setHeader :: HasHeaders r => String -> String -> r -> r
setHeader key val = setHeaderBS (pack key) (pack val)
setHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> r
setHeaderBS key val = setHeaderUnsafe (P.map toLower key) (HeaderPair key [val])
setHeaderUnsafe :: HasHeaders r => ByteString -> HeaderPair -> r -> r
setHeaderUnsafe key val = updateHeaders (M.insert key val)
addHeader :: HasHeaders r => String -> String -> r -> r
addHeader key val = addHeaderBS (pack key) (pack val)
addHeaderBS :: HasHeaders r => ByteString -> ByteString -> r -> r
addHeaderBS key val = addHeaderUnsafe (P.map toLower key) (HeaderPair key [val])
addHeaderUnsafe :: HasHeaders r => ByteString -> HeaderPair -> r -> r
addHeaderUnsafe key val = updateHeaders (M.insertWith join key val)
where join (HeaderPair k vs1) (HeaderPair _ vs2) = HeaderPair k (vs1++vs2)
result :: Int -> String -> Response
result code = resultBS code . LU.fromString
resultBS :: Int -> L.ByteString -> Response
resultBS code s = Response code M.empty nullRsFlags s Nothing
redirect :: (ToSURI s) => Int -> s -> Response -> Response
redirect c s resp = setHeaderBS locationC (pack (render (toSURI s))) resp{rsCode = c}
locationC :: ByteString
locationC = P.pack "Location"
closeC :: ByteString
closeC = P.pack "close"
connectionC :: ByteString
connectionC = P.pack "Connection"
keepaliveC :: ByteString
keepaliveC = P.pack "Keep-Alive"