happstack-server-0.1: src/HAppS/Server/HTTP/Handler.hs
{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-}
module HAppS.Server.HTTP.Handler(request-- version,required
,parseResponse,putRequest
-- ,unchunkBody,val,testChunk,pack
) where
-- ,fsepC,crlfC,pversion
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 HAppS.Server.Cookie
import HAppS.Server.HTTP.Clock
import HAppS.Server.HTTP.LazyLiner
import HAppS.Server.HTTP.Types
import HAppS.Server.HTTP.Multipart
import HAppS.Server.HTTP.RFC822Headers
import HAppS.Server.MessageWrap
import HAppS.Server.SURI(SURI(..),path,query)
import HAppS.Server.SURI.ParseURI
import HAppS.Util.TimeOut
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 ] -- Ugle
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
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}
-- http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html
-- note this does NOT handle extenions
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 -- endchar
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"
-- Properly lazy version of 'lines' for lazy bytestrings
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)]
-- Result side
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 x = P.hPut h x
-- TODO: Hoist static headers to the toplevel.
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 -- 'union' prefers 'headers res' when duplicate keys are encountered.
mapM_ put $ concat
[ (pversion $ rqVersion req) -- Print HTTP version
, [responseMessage $ rsCode res] -- Print responseCode
, concatMap ph (M.elems allHeaders) -- Print all headers
, [crlfC]
]
when (rqMethod req /= HEAD) $ L.hPut h $ rsBody res
hFlush h
putRequest :: Handle -> Request -> IO ()
putRequest h rq = do
let put x = B.hPut h x
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
-- Version
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"
-- Constants
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 "HAppS/0.9.2"
textHtmlC :: B.ByteString
textHtmlC = P.pack "text/html; charset=utf-8"
-- Response code names
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")