{-# LANGUAGE OverloadedStrings #-} {-| HTTP library for HTTP server. -} 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, 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 ---------------------------------------------------------------- {-| Abstract data type of HTTP request. -} data Request = Request { -- | Request method reqMethod :: Method -- | URI parsed from absolute URL or relative URL with the Host: field , reqURI :: URI -- | HTTP version , reqVersion :: Version -- | Key-values of request header , reqFields :: Fields -- | Entity body if exists , reqBody :: Maybe L.ByteString -- | Length of entity body from Content-Length: , reqLength :: Integer } deriving Show {-| Abstract data type of HTTP response. -} data Response = Response { -- | Response status rspStatus :: Status , rspFields :: Fields , rspBody :: Maybe L.ByteString -- Nothing -> No entity / No CL: -- Just bs -- Just bs.empty , rspLength :: Maybe Integer -- Nothing -> chunked or close -- Just x -> CL: x , rspLogMsg :: String } {-| A class to abstract 'Request' and 'Response'. -} 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 } ---------------------------------------------------------------- {-| Default Request. -} defaultRequest :: Request defaultRequest = Request { reqMethod = GET , reqURI = undefined , reqVersion = HTTP11 , reqFields = emptyFields , reqBody = Nothing , reqLength = 0 } {-| Default Response. -} defaultResponse :: Response defaultResponse = Response { rspStatus = OK , rspFields = emptyFields , rspBody = Nothing , rspLength = Nothing , rspLogMsg = "" } ---------------------------------------------------------------- {-| A function to make 'Response'. -} makeResponse :: Status -> [(FieldKey,FieldValue)] -> Response makeResponse st kvs = defaultResponse { rspStatus = st , rspBody = Just body , rspLength = Just len , rspFields = flds } where (<+>) = L.append body = "" <+> L.pack (show st) <+> "\n" len = fromIntegral $ L.length body flds = toFields kvs {-| A function to make 'Response'. -} 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 {-| A function to make 'Response'. -} 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 ---------------------------------------------------------------- {-| Receiving HTTP request from 'Handle'. If request is broken, 'Nothing' is returned. -} 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 {-| Parsing HTTP header from 'Handle'. This function is useful to parse CGI output. -} 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 -- xxx body <- L.hGet hdl (fromIntegral len) return req { reqBody = Just body, reqLength = len } ---------------------------------------------------------------- {-| Sending HTTP response to 'Handle'. If 'Keep' is specified, the HTTP connection will be kept. If 'Close' is specified, the connection will be closed. 'Version' should be copied from 'Request'. -} 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) -- including reason-phrase 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 ---------------------------------------------------------------- {-| Abstract data type for Key-values of HTTP header. -} newtype Fields = Fields (M.Map FieldKey FieldValue) deriving Show emptyFields :: Fields emptyFields = Fields M.empty {-| Looking up the HTTP field value. -} lookupField :: Comm a => FieldKey -> a -> Maybe FieldValue lookupField key comm = lookupField' key (getFields comm) {-| Looking up the HTTP field value. -} lookupField' :: FieldKey -> Fields -> Maybe FieldValue lookupField' key (Fields fields) = maybe Nothing (Just . trim) mvalue where mvalue = M.lookup key fields {-| Inserting the HTTP field. -} insertField :: Comm a => FieldKey -> FieldValue -> a -> a insertField key val comm = setFields comm fields where fields = insertField' key val $ getFields comm {-| Inserting the HTTP field. -} 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) -- bs is trimmed by lookupField 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 = " "