Network/Web/HTTP.hs

{-|
  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 Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.ByteString.Lazy.Char8 as LBS hiding (ByteString)
import Data.Char
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map hiding (Map)
import Data.Maybe
import IO hiding (try)
import Network.URI
import Network.Web.Params
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 ByteString
  -- | Length of entity body from Content-Length:
  , reqLength  :: Integer
}

{-|
  Abstract data type of HTTP response.
-}
data Response = Response {
  -- | Response status
    rspStatus  :: Status
  , rspFields  :: Fields
  , rspBody    :: Maybe 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
    cs = "<html><body>" ++ show st ++ "</body></html>\n"
    len = fromIntegral $ length cs
    body = LBS.pack cs
    flds = toFields kvs

{-|
  A function to make 'Response'.
-}
makeResponse2 :: Status -> Maybe 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 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
                   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 :: String -> Bool
isEOH l = null l || l == "\r"

receiveRequestLine :: Handle -> IO (Method,String,Version)
receiveRequestLine hdl = parseRequestLine <$> skipNullLines
  where
    skipNullLines = do
      l <- 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 <- hGetLine hdl
      if isEOH l
         then return []
         else (l:) <$> getHeaderLines

toURI :: String -> Fields -> IO URI
toURI url fields = maybe (fail "toURI") return $ toURI' url fields

toURI' :: String -> Fields -> Maybe URI
toURI' url fields
  | isAbsoluteURI url = parseURI url
  | otherwise         = lookupField' FkHost fields >>= \host ->
                        parseURI $ "http://" ++ host ++ url

receiveBody :: Handle -> Fields -> Request -> IO Request
receiveBody hdl flds req =
    case lookupField' FkContentLength flds of
      Nothing -> return req
      Just cs  -> do
        let len = read cs
        body <- LBS.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 h ver persist rsp = do
    sendStatusLine h ver rsp
    sendResponseFields h ver persist rsp
    hPutStr h crlf
    sendResponseBody h ver rsp
    hFlush h

sendStatusLine :: Handle -> Version -> Response -> IO ()
sendStatusLine h ver rsp = do
    hPutStr h $ show ver
    hPutStr h spc
    hPutStr h $ show (rspStatus rsp) -- including reason-phrase
    hPutStr h crlf

sendResponseFields :: Handle -> Version -> Persist -> Response -> IO ()
sendResponseFields h ver persist rsp = do
    putFields
    putContentLength
    putTransferEncoding
    putConnection
 where
    putFields = hPutStr h . concatMap composeField . fromFields $ getFields rsp
    putContentLength =
      case rspBody rsp >> rspLength rsp of
        Just len -> hPutStr h $ composeField (FkContentLength, show len)
        Nothing -> return ()
    putTransferEncoding =
      if ver == HTTP11 && isJust (rspBody rsp) && isNothing (rspLength rsp)
      then hPutStr h $ composeField (FkTransferEncoding, "chunked")
      else return ()
    putConnection = hPutStr h $ composeField (FkConnection, show persist)

sendResponseBody :: Handle -> Version -> Response -> IO ()
sendResponseBody h ver rsp =
  case rspBody rsp of
    Just body -> case rspLength rsp of
      Just _  -> LBS.hPut h body
      Nothing -> if ver == HTTP10
                 then LBS.hPut h body
                 else sendChunk h body
    Nothing   -> return ()

sendChunk :: Handle -> ByteString -> IO ()
sendChunk h body = do
    let (fcnk,rest) = LBS.splitAt chunkSize body
    if LBS.null rest
      then do
        putChunk fcnk $ toHex (LBS.length fcnk)
        putLastChunk
      else do
        putChunk fcnk defSize
        sendChunk h rest
  where
    chunkSize = 1024 * 4
    defSize = toHex chunkSize
    toHex = printf "%X"
    putChunk cnk siz = do
        hPutStr h siz
        hPutStr h crlf
        LBS.hPut h cnk
        hPutStr h crlf
    putLastChunk = do
        hPutStr h "0"
        hPutStr h crlf
        hPutStr h crlf

----------------------------------------------------------------

{-|
  Abstract data type for Key-values of HTTP header.
-}
newtype Fields = Fields (Map FieldKey FieldValue) deriving Show

emptyFields :: Fields
emptyFields = Fields Map.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 = Map.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 (Map.insert key val fields)

toFields :: [(FieldKey,FieldValue)] -> Fields
toFields kvs = Fields (Map.fromList kvs)

fromFields :: Fields -> [(FieldKey,FieldValue)]
fromFields (Fields fields) = Map.toList fields

copyFields :: Fields -> Fields
copyFields = toFields . map (\(x,y) -> (x, trim y)) . fromFields

----------------------------------------------------------------

composeField :: (FieldKey,FieldValue) -> String
composeField (k,v) = fromFieldKey k ++ ": " ++ v ++ crlf

parseField :: String -> (FieldKey,FieldValue)
parseField l = let kv = break (==':') (chomp l)
               in toKeyValue kv
  where
    toKeyValue (k,"")  = (toFieldKey k, "")
    toKeyValue (k,_:v) = (toFieldKey k, v) -- v is trimmed by lookupField

parseRequestLine :: String -> (Method,String,Version)
parseRequestLine l = let (m,l') = break (==' ') (chomp l)
                         (u,v') = break (==' ') (chop l')
                         v = trim v'
                     in (read m, u, read v)

----------------------------------------------------------------

chop :: String -> String
chop = dropWhile isSpace

chomp :: String -> String
chomp = fst . break (=='\r')

trim :: String -> String
trim = reverse . chop . reverse . chop

----------------------------------------------------------------

crlf :: String
crlf = "\r\n"

spc :: String
spc = " "