salvia-0.0.4: src/Network/Protocol/Http.hs
{-# LANGUAGE FlexibleInstances #-}
module Network.Protocol.Http(
Status (..)
, Method (..)
, methods
, Version (..)
, Headers
, Direction (..)
, Message (..)
, utf8
, http10
, http11
, emptyRequest
, emptyResponse
, method
, setMethod
, uri
, setUri
, modUri
, status
, setStatus
, setVersion
, setBody
, modBody
, header
, setHeader
, modHeader
, getLocation
, getHost
, getContentLength
, getKeepAlive
, getCookie
, setContentType
, setContentLength
, setLocation
, setDate
, setServer
, setCookie
, normalizeHeader
, pRequest
, pResponse
, showVersion
, showHeaders
, showMessageHeader
, statusCodes
, statusFailure
, statusFromCode
, codeFromStatus
) where
import Control.Applicative hiding (empty)
import Data.Char
import Data.List (intercalate)
import Data.Maybe (fromMaybe)
import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))
import qualified Data.Bimap as Bm
import qualified Data.Map as M
import Misc.Misc
import Network.Protocol.Uri (URI, mkURI, pUriReference)
import Network.Protocol.Cookie ()
-------- HTTP message data-types ----------------------------------------------
data Status =
Continue | SwitchingProtocols
| OK | Created
| Accepted | NonAuthoritativeInformation
| NoContent | ResetContent
| PartialContent | MultipleChoices
| MovedPermanently | Found
| SeeOther | NotModified
| UseProxy | TemporaryRedirect
| BadRequest | Unauthorized
| PaymentRequired | Forbidden
| NotFound | MethodNotAllowed
| NotAcceptable | ProxyAuthenticationRequired
| RequestTimeOut | Conflict
| Gone | LengthRequired
| PreconditionFailed | RequestEntityTooLarge
| RequestURITooLarge | UnsupportedMediaType
| RequestedRangeNotSatisfiable | ExpectationFailed
| InternalServerError | NotImplemented
| BadGateway | ServiceUnavailable
| GatewayTimeOut | HTTPVersionNotSupported
| CustomStatus Int
deriving (Eq, Ord)
data Method =
OPTIONS
| GET
| HEAD
| POST
| PUT
| DELETE
| TRACE
| CONNECT
deriving (Show, Eq)
methods :: [Method]
methods = [OPTIONS, GET, HEAD, POST, PUT, DELETE, TRACE, CONNECT]
data Version = Version {major :: Int, minor :: Int}
type Headers = M.Map String String
data Direction =
Request {_method :: Method, _uri :: URI}
| Response {_status :: Status}
data Message =
Message {
direction :: Direction
, version :: Version
, headers :: Headers
, body :: String
}
utf8 :: String
utf8 = "utf-8"
-------- HTTP message creation and alteration ---------------------------------
-- Create HTTP versions.
http10, http11 :: Version
http10 = Version 1 0
http11 = Version 1 1
emptyRequest :: Message
emptyRequest = Message (Request GET (mkURI)) http11 M.empty ""
emptyResponse :: Message
emptyResponse = Message (Response OK) http11 M.empty ""
method :: Message -> Method
method = _method . direction
setMethod :: Method -> Message -> Message
setMethod e m = m { direction = Request e (uri m) }
uri :: Message -> URI
uri = _uri . direction
setUri :: URI -> Message -> Message
setUri u m = m { direction = Request (method m) u }
modUri :: (URI -> URI) -> Message -> Message
modUri f m = setUri (f $ uri m) m
status :: Message -> Status
status = _status . direction
setStatus :: Status -> Message -> Message
setStatus s m = m { direction = Response s }
setVersion :: Version -> Message -> Message
setVersion v m = m { version = v }
setBody :: String -> Message -> Message
setBody b m = m { body = b }
modBody :: (String -> String) -> Message -> Message
modBody f m = setBody (f $ body m) m
header :: String -> Message -> String
header k = maybe "" id . M.lookup (normalizeHeader k) . headers
setHeader :: String -> String -> Message -> Message
setHeader k a (Message r v h b) = Message r v (M.insert (normalizeHeader k) a h) b
modHeader :: String -> (String -> String) -> Message -> Message
modHeader k f m = setHeader k (f $ header k m) m
getLocation :: Message -> String
getLocation = header "Location"
getHost :: Message -> String
getHost = header "Host"
getContentLength :: Message -> Maybe Int
getContentLength = intRead . header "Content-Length"
getKeepAlive :: Message -> Maybe Int
getKeepAlive = intRead . header "Keep-Alive"
getCookie :: Message -> String
getCookie = header "Cookie"
setContentType :: String -> Maybe String -> Message -> Message
setContentType t c = setHeader "Content-Type" (t ++ maybe "" ("; charset="++) c)
setContentLength :: Num a => a -> Message -> Message
setContentLength l = setHeader "Content-Length" (show l)
setLocation :: URI -> Message -> Message
setLocation l = setHeader "Location" (show l)
setDate :: String -> Message -> Message
setDate d = setHeader "Date" d
setServer :: String -> Message -> Message
setServer n = setHeader "Server" n
setCookie :: String -> Message -> Message
setCookie c = setHeader "Set-Cookie" c
normalizeHeader :: String -> String
normalizeHeader = (intercalate "-") . (map normalCase) . (Misc.Misc.split '-')
-------- HTTP message parsing -------------------------------------------------
-- todo: cleanup ugly code
lf, ws, ls :: String
lf = "\r\n"
ws = " \t\r\n"
ls = " \t"
pLf :: GenParser Char st Char
pLf = (char '\r' <* pMaybe (char '\n')) <|> char '\n'
pVersion :: GenParser Char st Version
pVersion =
(\h l -> Version (ord h - ord '0') (ord l - ord '0'))
<$> (string "HTTP/" *> digit)
<*> (char '.' *> digit)
pHeaders :: GenParser Char st Headers
pHeaders = M.insert
<$> many1 (noneOf (':':ws)) <* string ":"
<*> (intercalate ws <$> (many $ many1 (oneOf ls) *> many1 (noneOf lf) <* pLf))
<*> option M.empty pHeaders
pMethod :: GenParser Char st Method
pMethod = choice $ map (\a -> a <$ (try $ string $ show a)) methods
pRequest :: GenParser Char st Message
pRequest = (\m u v h b -> Message (Request m u) v h b)
<$> (pMethod <* many1 (oneOf ls))
<*> (pUriReference <* many1 (oneOf ls))
<*> (pVersion <* pLf)
<*> (pHeaders <* pLf)
<*> (many anyToken)
pResponse :: GenParser Char st Message
pResponse = (\v s h b -> Message (Response (statusFromCode $ read s)) v h b)
<$> (pVersion <* many1 (oneOf ls))
<*> (many1 digit <* many1 (oneOf ls) <* many1 (noneOf lf) <* pLf)
<*> (pHeaders <* pLf)
<*> (many anyToken)
-------- HTTP message pretty printing -----------------------------------------
showVersion :: Version -> String
showVersion (Version a b) = concat ["HTTP/", show a, ".", show b]
showHeaders :: Headers -> String
showHeaders =
intercalate lf
. M.elems
. M.mapWithKey (\k a -> k ++ ": " ++ a)
showMessageHeader :: Message -> String
showMessageHeader (Message (Response s) v hs _) =
concat [
showVersion v, " "
, maybe "Unknown status" show
$ Bm.lookupR s statusCodes, " "
, show s, lf
, showHeaders hs, lf, lf
]
showMessageHeader (Message (Request m u) v hs _) =
concat [show m, " ", show u, " ", showVersion v, lf, showHeaders hs, lf, lf]
instance Show Message where
show m = concat [showMessageHeader m, body m]
-------- status code mappings -------------------------------------------------
-- rfc2616 sec6.1.1 Status Code and Reason Phrase
statusCodes :: Bm.Bimap Int Status
statusCodes = Bm.fromList [
(100, Continue)
, (101, SwitchingProtocols)
, (200, OK)
, (201, Created)
, (202, Accepted)
, (203, NonAuthoritativeInformation)
, (204, NoContent)
, (205, ResetContent)
, (206, PartialContent)
, (300, MultipleChoices)
, (301, MovedPermanently)
, (302, Found)
, (303, SeeOther)
, (304, NotModified)
, (305, UseProxy)
, (307, TemporaryRedirect)
, (400, BadRequest)
, (401, Unauthorized)
, (402, PaymentRequired)
, (403, Forbidden)
, (404, NotFound)
, (405, MethodNotAllowed)
, (406, NotAcceptable)
, (407, ProxyAuthenticationRequired)
, (408, RequestTimeOut)
, (409, Conflict)
, (410, Gone)
, (411, LengthRequired)
, (412, PreconditionFailed)
, (413, RequestEntityTooLarge)
, (414, RequestURITooLarge)
, (415, UnsupportedMediaType)
, (416, RequestedRangeNotSatisfiable)
, (417, ExpectationFailed)
, (500, InternalServerError)
, (501, NotImplemented)
, (502, BadGateway)
, (503, ServiceUnavailable)
, (504, GatewayTimeOut)
, (505, HTTPVersionNotSupported)
]
-- rfc2616 sec6.1.1 Status Code and Reason Phrase
instance Show Status where
show Continue = "Continue"
show SwitchingProtocols = "Switching Protocols"
show OK = "OK"
show Created = "Created"
show Accepted = "Accepted"
show NonAuthoritativeInformation = "Non-Authoritative Information"
show NoContent = "No Content"
show ResetContent = "Reset Content"
show PartialContent = "Partial Content"
show MultipleChoices = "Multiple Choices"
show MovedPermanently = "Moved Permanently"
show Found = "Found"
show SeeOther = "See Other"
show NotModified = "Not Modified"
show UseProxy = "Use Proxy"
show TemporaryRedirect = "Temporary Redirect"
show BadRequest = "Bad Request"
show Unauthorized = "Unauthorized"
show PaymentRequired = "Payment Required"
show Forbidden = "Forbidden"
show NotFound = "Not Found"
show MethodNotAllowed = "Method Not Allowed"
show NotAcceptable = "Not Acceptable"
show ProxyAuthenticationRequired = "Proxy Authentication Required"
show RequestTimeOut = "Request Time-out"
show Conflict = "Conflict"
show Gone = "Gone"
show LengthRequired = "Length Required"
show PreconditionFailed = "Precondition Failed"
show RequestEntityTooLarge = "Request Entity Too Large"
show RequestURITooLarge = "Request-URI Too Large"
show UnsupportedMediaType = "Unsupported Media Type"
show RequestedRangeNotSatisfiable = "Requested range not satisfiable"
show ExpectationFailed = "Expectation Failed"
show InternalServerError = "Internal Server Error"
show NotImplemented = "Not Implemented"
show BadGateway = "Bad Gateway"
show ServiceUnavailable = "Service Unavailable"
show GatewayTimeOut = "Gateway Time-out"
show HTTPVersionNotSupported = "HTTP Version not supported"
show (CustomStatus _) = "Unknown Status"
statusFailure :: Status -> Bool
statusFailure st = codeFromStatus st >= 400
statusFromCode :: Int -> Status
statusFromCode num =
fromMaybe (CustomStatus num)
$ Bm.lookup num statusCodes
codeFromStatus :: Status -> Int
codeFromStatus st =
fromMaybe 0 -- total, should not happen
$ Bm.lookupR st statusCodes