module Network.Web.HTTP (receive, respond,
Request,
reqMethod, reqURI, reqVersion, reqFields,
reqBody, reqLength,
Response,
rspStatus, rspFields, rspBody, rspLength, rspLogMsg,
makeResponse, makeResponse2, makeResponse3,
Comm, Fields,
lookupField, lookupField',
insertField, insertField',
receiveFields, fromFields,
module Network.Web.Params) where
import Control.Applicative
import Control.Exception (try, throw)
import Control.Monad
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Char
import qualified Data.Map as M
import Data.Maybe
import Network.Web.Params
import Network.Web.URI
import System.IO
import System.IO.Error hiding (try)
import Text.Printf
data Request = Request {
reqMethod :: Method
, reqURI :: URI
, reqVersion :: Version
, reqFields :: Fields
, reqBody :: Maybe L.ByteString
, reqLength :: Integer
} deriving Show
data Response = Response {
rspStatus :: Status
, rspFields :: Fields
, rspBody :: Maybe L.ByteString
, rspLength :: Maybe Integer
, rspLogMsg :: String
}
class Comm a where
getFields :: a -> Fields
setFields :: a -> Fields -> a
instance Comm Request where
getFields = reqFields
setFields req hdrs = req { reqFields = hdrs }
instance Comm Response where
getFields = rspFields
setFields rsp hdrs = rsp { rspFields = hdrs }
defaultRequest :: Request
defaultRequest = Request {
reqMethod = GET
, reqURI = undefined
, reqVersion = HTTP11
, reqFields = emptyFields
, reqBody = Nothing
, reqLength = 0
}
defaultResponse :: Response
defaultResponse = Response {
rspStatus = OK
, rspFields = emptyFields
, rspBody = Nothing
, rspLength = Nothing
, rspLogMsg = ""
}
makeResponse :: Status -> [(FieldKey,FieldValue)] -> Response
makeResponse st kvs = defaultResponse { rspStatus = st
, rspBody = Just body
, rspLength = Just len
, rspFields = flds
}
where
(<+>) = L.append
body = "<html><body>" <+> L.pack (show st) <+> "</body></html>\n"
len = fromIntegral $ L.length body
flds = toFields kvs
makeResponse2 :: Status -> Maybe L.ByteString -> Maybe Integer -> [(FieldKey,FieldValue)] -> Response
makeResponse2 st mval mlen kvs = defaultResponse { rspStatus = st
, rspBody = mval
, rspLength = mlen
, rspFields = flds
}
where
flds = toFields kvs
makeResponse3 :: Status -> Maybe L.ByteString -> Maybe Integer -> Fields -> Response
makeResponse3 st mval mlen flds = defaultResponse { rspStatus = st
, rspBody = mval
, rspLength = mlen
, rspFields = flds'
}
where
flds' = copyFields flds
receive :: Handle -> IO (Maybe Request)
receive hdl = do
mreq <- try $ receiveRequest hdl
case mreq of
Left e -> if isEOFError e ||
show (ioeGetErrorType e) == "resource vanished"
then throw TerminatedByClient
else return Nothing
Right req -> return $ Just req
receiveRequest :: Handle -> IO Request
receiveRequest hdl = do
(method,url,version) <- receiveRequestLine hdl
let req0 = defaultRequest
req1 = req0 { reqMethod = method, reqVersion = version }
flds <- receiveFields hdl
uri <- toURI url flds
let req2 = req1 { reqURI = uri, reqFields = flds }
receiveBody hdl flds req2
isEOH :: S.ByteString -> Bool
isEOH l = S.null l || l == "\r"
receiveRequestLine :: Handle -> IO (Method,S.ByteString,Version)
receiveRequestLine hdl = parseRequestLine <$> skipNullLines
where
skipNullLines = do
l <- S.hGetLine hdl
if isEOH l
then skipNullLines
else return l
receiveFields :: Handle -> IO Fields
receiveFields hdl = toFields . map parseField <$> getHeaderLines
where
getHeaderLines = do
l <- S.hGetLine hdl
if isEOH l
then return []
else (l:) <$> getHeaderLines
toURI :: S.ByteString -> Fields -> IO URI
toURI url fields = maybe (fail "toURI") return $ toURI' url fields
toURI' :: S.ByteString -> Fields -> Maybe URI
toURI' url fields
| isAbsoluteURI url = parseURI url
| otherwise = lookupField' FkHost fields >>= \host ->
parseURI $ "http://" +++ host +++ url
where
(+++) = S.append
receiveBody :: Handle -> Fields -> Request -> IO Request
receiveBody hdl flds req =
case lookupField' FkContentLength flds of
Nothing -> return req
Just bs -> do
let Just (len,_) = S.readInteger bs
body <- L.hGet hdl (fromIntegral len)
return req { reqBody = Just body, reqLength = len }
respond :: Handle -> Version -> Persist -> Response -> IO ()
respond hdl ver persist rsp = do
sendStatusLine hdl ver rsp
sendResponseFields hdl ver persist rsp
S.hPutStr hdl crlf
sendResponseBody hdl ver rsp
hFlush hdl
sendStatusLine :: Handle -> Version -> Response -> IO ()
sendStatusLine hdl ver rsp = do
S.hPutStr hdl $ fromVersion ver
S.hPutStr hdl spc
S.hPutStr hdl $ fromStatus (rspStatus rsp)
S.hPutStr hdl crlf
sendResponseFields :: Handle -> Version -> Persist -> Response -> IO ()
sendResponseFields hdl ver persist rsp = do
putFields
putContentLength
putTransferEncoding
putConnection
where
putFields = S.hPutStr hdl . S.concat . map composeField . fromFields $ getFields rsp
putContentLength =
case rspBody rsp >> rspLength rsp of
Just len -> S.hPutStr hdl $ composeField (FkContentLength, S.pack (show len))
Nothing -> return ()
putTransferEncoding =
when (ver == HTTP11 && isJust (rspBody rsp) && isNothing (rspLength rsp)) $
S.hPutStr hdl $ composeField (FkTransferEncoding, "chunked")
putConnection = S.hPutStr hdl $ composeField (FkConnection, fromPersist persist)
sendResponseBody :: Handle -> Version -> Response -> IO ()
sendResponseBody hdl ver rsp =
case rspBody rsp of
Just body -> case rspLength rsp of
Just _ -> L.hPut hdl body
Nothing -> if ver == HTTP10
then L.hPut hdl body
else sendChunk hdl body
Nothing -> return ()
sendChunk :: Handle -> L.ByteString -> IO ()
sendChunk hdl body = do
let (fcnk,rest) = L.splitAt chunkSize body
if L.null rest
then do
putChunk fcnk $ toHex (L.length fcnk)
putLastChunk
S.hPutStr hdl crlf
else do
putChunk fcnk defSize
sendChunk hdl rest
where
chunkSize = 1024 * 4
defSize = toHex chunkSize
toHex = S.pack . printf "%X"
putChunk cnk siz = do
S.hPutStr hdl siz
S.hPutStr hdl crlf
L.hPut hdl cnk
S.hPutStr hdl crlf
putLastChunk = do
S.hPutStr hdl "0"
S.hPutStr hdl crlf
newtype Fields = Fields (M.Map FieldKey FieldValue) deriving Show
emptyFields :: Fields
emptyFields = Fields M.empty
lookupField :: Comm a => FieldKey -> a -> Maybe FieldValue
lookupField key comm = lookupField' key (getFields comm)
lookupField' :: FieldKey -> Fields -> Maybe FieldValue
lookupField' key (Fields fields) = maybe Nothing (Just . trim) mvalue
where
mvalue = M.lookup key fields
insertField :: Comm a => FieldKey -> FieldValue -> a -> a
insertField key val comm = setFields comm fields
where
fields = insertField' key val $ getFields comm
insertField' :: FieldKey -> FieldValue -> Fields -> Fields
insertField' key val (Fields fields) = Fields (M.insert key val fields)
toFields :: [(FieldKey,FieldValue)] -> Fields
toFields kvs = Fields (M.fromList kvs)
fromFields :: Fields -> [(FieldKey,FieldValue)]
fromFields (Fields fields) = M.toList fields
copyFields :: Fields -> Fields
copyFields = toFields . map (\(x,y) -> (x, trim y)) . fromFields
composeField :: (FieldKey,FieldValue) -> S.ByteString
composeField (k,v) = fromFieldKey k +++ ": " +++ v +++ crlf
where
(+++) = S.append
parseField :: S.ByteString -> (FieldKey,FieldValue)
parseField l = let kv = S.break (==':') (chomp l)
in toKeyValue kv
where
toKeyValue (k,"") = (toFieldKey k, "")
toKeyValue (k,bs) = (toFieldKey k, S.tail bs)
parseRequestLine :: S.ByteString -> (Method,S.ByteString,Version)
parseRequestLine l = let (m,l') = S.break (==' ') (chomp l)
(u,v') = S.break (==' ') (chop l')
v = trim v'
in (toMethod m, u, toVersion v)
chop :: S.ByteString -> S.ByteString
chop = S.dropWhile isSpace
chomp :: S.ByteString -> S.ByteString
chomp = fst . S.break (=='\r')
trim :: S.ByteString -> S.ByteString
trim = S.reverse . chop . S.reverse . chop
crlf :: S.ByteString
crlf = "\r\n"
spc :: S.ByteString
spc = " "