module Happstack.Server.HTTP.Handler(request
,parseResponse,putRequest
) where
import qualified Paths_happstack_server as Paths
import qualified Data.Version as DV
import Control.Exception.Extensible as E
import Control.Monad
import Data.List(elemIndex)
import Data.Char(toLower)
import Data.Maybe ( fromMaybe, fromJust, isJust, isNothing )
import Prelude hiding (last)
import qualified Data.List as List
import qualified Data.ByteString.Char8 as P
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Map as M
import System.IO
import Numeric
import Data.Int (Int64)
import Happstack.Server.Cookie
import Happstack.Server.HTTP.Clock
import Happstack.Server.HTTP.LazyLiner
import Happstack.Server.HTTP.Types
import Happstack.Server.HTTP.Multipart
import Happstack.Server.HTTP.RFC822Headers
import Happstack.Server.MessageWrap
import Happstack.Server.SURI(SURI(..),path,query)
import Happstack.Server.SURI.ParseURI
import Happstack.Util.TimeOut
import Happstack.Util.LogFormat (formatRequestCombined)
import Data.Time.Clock (getCurrentTime)
import System.Log.Logger (Priority(..), logM)
log' = logM "Happstack.Server"
request :: Conf -> Handle -> Host -> (Request -> IO Response) -> IO ()
request conf h host handler = rloop conf h host handler =<< L.hGetContents h
required :: String -> Maybe a -> Either String a
required err Nothing = Left err
required _ (Just a) = Right a
transferEncodingC :: [Char]
transferEncodingC = "transfer-encoding"
rloop :: t
-> Handle
-> Host
-> (Request -> IO Response)
-> L.ByteString
-> IO ()
rloop conf h host handler inputStr
| L.null inputStr = return ()
| otherwise
= join $ withTimeOut (30 * second) $
do let parseRequest
= do (topStr, restStr) <- required "failed to separate request" $ splitAtEmptyLine inputStr
(rql, headerStr) <- required "failed to separate headers/body" $ splitAtCRLF topStr
let (m,u,v) = requestLine rql
headers' <- parseHeaders "host" (L.unpack headerStr)
let headers = mkHeaders headers'
let contentLength = fromMaybe 0 $ fmap fst (P.readInt =<< getHeaderUnsafe contentlengthC headers)
(body, nextRequest) <- case () of
() | contentLength < 0 -> fail "negative content-length"
| isJust $ getHeader transferEncodingC headers ->
return $ consumeChunks restStr
| otherwise -> return (L.splitAt (fromIntegral contentLength) restStr)
let cookies = [ (cookieName c, c) | cl <- fromMaybe [] (fmap getCookies (getHeader "Cookie" headers)), c <- cl ]
rqTmp = Request m (pathEls (path u)) (path u) (query u)
[] cookies v headers (Body body) host
rq = rqTmp{rqInputs = queryInput u ++ bodyInput rqTmp}
return (rq, nextRequest)
case parseRequest of
Left err -> error $ "failed to parse HTTP request: " ++ err
Right (req, rest)
-> return $
do let ioseq act = act >>= \x -> x `seq` return x
res <- ioseq (handler req) `E.catch` \(e::E.SomeException) -> return $ result 500 $ "Server error: " ++ show e
time <- getCurrentTime
let host' = fst host
user = "-"
requestLine = unwords [show $ rqMethod req, rqUri req, show $ rqVersion req]
responseCode = rsCode res
size = toInteger $ L.length $ rsBody res
referer = B.unpack $ fromMaybe (B.pack "") $ getHeader "Referer" req
userAgent = B.unpack $ fromMaybe (B.pack "") $ getHeader "User-Agent" req
log' NOTICE $ formatRequestCombined host' user time requestLine responseCode size referer userAgent
putAugmentedResult h req res
when (continueHTTP req res) $ rloop conf h host handler rest
parseResponse :: L.ByteString -> Either String Response
parseResponse inputStr =
do (topStr,restStr) <- required "failed to separate response" $
splitAtEmptyLine inputStr
(rsl,headerStr) <- required "failed to separate headers/body" $
splitAtCRLF topStr
let (_,code) = responseLine rsl
headers' <- parseHeaders "host" (L.unpack headerStr)
let headers = mkHeaders headers'
let mbCL = fmap fst (B.readInt =<< getHeader "content-length" headers)
(body,_) <-
maybe (if (isNothing $ getHeader "transfer-encoding" headers)
then return (restStr,L.pack "")
else return $ consumeChunks restStr)
(\cl->return (L.splitAt (fromIntegral cl) restStr))
mbCL
return $ Response {rsCode=code,rsHeaders=headers,rsBody=body,rsFlags=RsFlags True,rsValidator=Nothing}
consumeChunks::L.ByteString->(L.ByteString,L.ByteString)
consumeChunks str = let (parts,tr,rest) = consumeChunksImpl str in (L.concat . (++ [tr]) .map snd $ parts,rest)
consumeChunksImpl :: L.ByteString -> ([(Int64, L.ByteString)], L.ByteString, L.ByteString)
consumeChunksImpl str
| L.null str = ([],L.empty,str)
| chunkLen == 0 = let (last,rest') = L.splitAt lenLine1 str
(tr',rest'') = getTrailer rest'
in ([(0,last)],tr',rest'')
| otherwise = ((chunkLen,part):crest,tr,rest2)
where
line1 = head $ lazylines str
lenLine1 = (L.length line1) + 1
chunkLen = (fst $ head $ readHex $ L.unpack line1)
len = chunkLen + lenLine1 + 2
(part,rest) = L.splitAt len str
(crest,tr,rest2) = consumeChunksImpl rest
getTrailer s = L.splitAt index s
where index | crlfLC `L.isPrefixOf` s = 2
| otherwise = let iscrlf = L.zipWith (\a b -> a == '\r' && b == '\n') s . L.tail $ s
Just i = elemIndex True $ zipWith (&&) iscrlf (tail (tail iscrlf))
in fromIntegral $ i+4
crlfLC :: L.ByteString
crlfLC = L.pack "\r\n"
lazylines :: L.ByteString -> [L.ByteString]
lazylines s
| L.null s = []
| otherwise =
let (l,s') = L.break ((==) '\n') s
in l : if L.null s' then []
else lazylines (L.tail s')
requestLine :: L.ByteString -> (Method, SURI, Version)
requestLine l = case P.words ((P.concat . L.toChunks) l) of
[rq,uri,ver] -> (method rq, SURI $ parseURIRef uri, version ver)
[rq,uri] -> (method rq, SURI $ parseURIRef uri,Version 0 9)
x -> error $ "requestLine cannot handle input: " ++ (show x)
responseLine :: L.ByteString -> (B.ByteString, Int)
responseLine l = case B.words ((B.concat . L.toChunks) l) of
(v:c:_) -> version v `seq` (v,fst (fromJust (B.readInt c)))
x -> error $ "responseLine cannot handle input: " ++ (show x)
method :: B.ByteString -> Method
method r = fj $ lookup r mtable
where fj (Just x) = x
fj Nothing = error "invalid request method"
mtable = [(P.pack "GET", GET),
(P.pack "HEAD", HEAD),
(P.pack "POST", POST),
(P.pack "PUT", PUT),
(P.pack "DELETE", DELETE),
(P.pack "TRACE", TRACE),
(P.pack "OPTIONS", OPTIONS),
(P.pack "CONNECT", CONNECT)]
staticHeaders :: Headers
staticHeaders =
foldr (uncurry setHeaderBS) (mkHeaders [])
[ (serverC, happsC), (contentTypeC, textHtmlC) ]
putAugmentedResult :: Handle -> Request -> Response -> IO ()
putAugmentedResult h req res = do
let ph (HeaderPair k vs) = map (\v -> P.concat [k, fsepC, v, crlfC]) vs
raw <- getApproximateTime
let cl = L.length $ rsBody res
let put = P.hPut h
let stdHeaders = staticHeaders `M.union`
M.fromList ( [ (dateCLower, HeaderPair dateC [raw])
, (connectionCLower, HeaderPair connectionC [if continueHTTP req res then keepAliveC else closeC])
] ++ if rsfContentLength (rsFlags res)
then [(contentlengthC, HeaderPair contentLengthC [P.pack (show cl)])]
else [] )
allHeaders = rsHeaders res `M.union` stdHeaders
mapM_ put $ concat
[ (pversion $ rqVersion req)
, [responseMessage $ rsCode res]
, concatMap ph (M.elems allHeaders)
, [crlfC]
]
when (rqMethod req /= HEAD) $ L.hPut h $ rsBody res
hFlush h
putRequest :: Handle -> Request -> IO ()
putRequest h rq = do
let put = B.hPut h
ph (HeaderPair k vs) = map (\v -> B.concat [k, fsepC, v, crlfC]) vs
sp = [B.pack " "]
mapM_ put $ concat
[[B.pack $ show $ rqMethod rq],sp
,[B.pack $ rqURL rq],sp
,(pversion $ rqVersion rq), [crlfC]
,concatMap ph (M.elems $ rqHeaders rq)
,[crlfC]
]
let Body body = rqBody rq
L.hPut h body
hFlush h
pversion :: Version -> [B.ByteString]
pversion (Version 1 1) = [http11]
pversion (Version 1 0) = [http10]
pversion (Version x y) = [P.pack "HTTP/", P.pack (show x), P.pack ".", P.pack (show y)]
version :: B.ByteString -> Version
version x | x == http09 = Version 0 9
| x == http10 = Version 1 0
| x == http11 = Version 1 1
| otherwise = error "Invalid HTTP version"
http09 :: B.ByteString
http09 = P.pack "HTTP/0.9"
http10 :: B.ByteString
http10 = P.pack "HTTP/1.0"
http11 :: B.ByteString
http11 = P.pack "HTTP/1.1"
connectionC :: B.ByteString
connectionC = P.pack "Connection"
connectionCLower :: B.ByteString
connectionCLower = P.map toLower connectionC
closeC :: B.ByteString
closeC = P.pack "close"
keepAliveC :: B.ByteString
keepAliveC = P.pack "Keep-Alive"
crlfC :: B.ByteString
crlfC = P.pack "\r\n"
fsepC :: B.ByteString
fsepC = P.pack ": "
contentTypeC :: B.ByteString
contentTypeC = P.pack "Content-Type"
contentLengthC :: B.ByteString
contentLengthC = P.pack "Content-Length"
contentlengthC :: B.ByteString
contentlengthC = P.pack "content-length"
dateC :: B.ByteString
dateC = P.pack "Date"
dateCLower :: B.ByteString
dateCLower = P.map toLower dateC
serverC :: B.ByteString
serverC = P.pack "Server"
happsC :: B.ByteString
happsC = P.pack $ "Happstack/" ++ DV.showVersion Paths.version
textHtmlC :: B.ByteString
textHtmlC = P.pack "text/html; charset=utf-8"
responseMessage :: (Num t) => t -> B.ByteString
responseMessage 100 = P.pack " 100 Continue\r\n"
responseMessage 101 = P.pack " 101 Switching Protocols\r\n"
responseMessage 200 = P.pack " 200 OK\r\n"
responseMessage 201 = P.pack " 201 Created\r\n"
responseMessage 202 = P.pack " 202 Accepted\r\n"
responseMessage 203 = P.pack " 203 Non-Authoritative Information\r\n"
responseMessage 204 = P.pack " 204 No Content\r\n"
responseMessage 205 = P.pack " 205 Reset Content\r\n"
responseMessage 206 = P.pack " 206 Partial Content\r\n"
responseMessage 300 = P.pack " 300 Multiple Choices\r\n"
responseMessage 301 = P.pack " 301 Moved Permanently\r\n"
responseMessage 302 = P.pack " 302 Found\r\n"
responseMessage 303 = P.pack " 303 See Other\r\n"
responseMessage 304 = P.pack " 304 Not Modified\r\n"
responseMessage 305 = P.pack " 305 Use Proxy\r\n"
responseMessage 307 = P.pack " 307 Temporary Redirect\r\n"
responseMessage 400 = P.pack " 400 Bad Request\r\n"
responseMessage 401 = P.pack " 401 Unauthorized\r\n"
responseMessage 402 = P.pack " 402 Payment Required\r\n"
responseMessage 403 = P.pack " 403 Forbidden\r\n"
responseMessage 404 = P.pack " 404 Not Found\r\n"
responseMessage 405 = P.pack " 405 Method Not Allowed\r\n"
responseMessage 406 = P.pack " 406 Not Acceptable\r\n"
responseMessage 407 = P.pack " 407 Proxy Authentication Required\r\n"
responseMessage 408 = P.pack " 408 Request Time-out\r\n"
responseMessage 409 = P.pack " 409 Conflict\r\n"
responseMessage 410 = P.pack " 410 Gone\r\n"
responseMessage 411 = P.pack " 411 Length Required\r\n"
responseMessage 412 = P.pack " 412 Precondition Failed\r\n"
responseMessage 413 = P.pack " 413 Request Entity Too Large\r\n"
responseMessage 414 = P.pack " 414 Request-URI Too Large\r\n"
responseMessage 415 = P.pack " 415 Unsupported Media Type\r\n"
responseMessage 416 = P.pack " 416 Requested range not satisfiable\r\n"
responseMessage 417 = P.pack " 417 Expectation Failed\r\n"
responseMessage 500 = P.pack " 500 Internal Server Error\r\n"
responseMessage 501 = P.pack " 501 Not Implemented\r\n"
responseMessage 502 = P.pack " 502 Bad Gateway\r\n"
responseMessage 503 = P.pack " 503 Service Unavailable\r\n"
responseMessage 504 = P.pack " 504 Gateway Time-out\r\n"
responseMessage 505 = P.pack " 505 HTTP Version not supported\r\n"
responseMessage x = P.pack (show x ++ "\r\n")