salvia-0.0.5: src/Network/Protocol/Http.hs
{-# LANGUAGE FlexibleInstances, TemplateHaskell #-}
module Network.Protocol.Http(
Status (..)
, Method (..)
, methods
, Version
, Headers
, Direction
, Message
, major
, minor
, method
, uri
, status
, direction
, version
, headers
, body
, utf8
, http10
, http11
, emptyRequest
, emptyResponse
, normalizeHeader
, header
, contentLength
, keepAlive
, cookie
, location
, contentType
, date
, server
, hostname
, 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 Data.Record.Label
import Misc.Misc
import Network.Protocol.Uri (URI, mkURI, pUriReference, parseURI)
import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))
import qualified Data.Bimap as Bm
import qualified Data.Map as M
-------- 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 HeaderKey = String
type HeaderValue = String
type Headers = M.Map HeaderKey HeaderValue
data Direction =
Request {__method :: Method, __uri :: URI}
| Response {__status :: Status}
data Message =
Message {
_direction :: Direction
, _version :: Version
, _headers :: Headers
, _body :: String
}
$(mkLabels [''Version, ''Direction, ''Message])
major :: Label Version Int
minor :: Label Version Int
body :: Label Message String
headers :: Label Message Headers
version :: Label Message Version
direction :: Label Message Direction
_status :: Label Direction Status
_uri :: Label Direction URI
_method :: Label Direction Method
-- Public labels based on private labels.
method :: Label Message Method
method = _method % direction
uri :: Label Message URI
uri = _uri % direction
status :: Label Message Status
status = _status % direction
-- More advanced labels.
normalizeHeader :: String -> String
normalizeHeader = (intercalate "-") . (map normalCase) . (Misc.Misc.split '-')
header :: HeaderKey -> Label Message HeaderValue
header key =
Label {
lget = maybe "" id . M.lookup (normalizeHeader key) . lget headers
, lset = lmod headers . M.insert (normalizeHeader key)
}
contentLength :: Label Message (Maybe Integer)
contentLength = comp safeRead (maybe "" show) (header "Content-Length")
keepAlive :: Label Message (Maybe Integer)
keepAlive = comp safeRead (maybe "" show) (header "Keep-Alive")
cookie :: Label Message String
cookie =
Label {
lget = lget (header "Cookie")
, lset = lset (header "Set-Cookie")
}
location :: Label Message (Maybe URI)
location =
Label {
lget = parseURI . lget (header "Location")
, lset = lset (header "Location") . maybe "" show
}
contentType :: Label Message (String, Maybe String)
contentType = comp pa pr (header "Content-Length")
where pr (t, c) = t ++ maybe "" ("; charset="++) c
pa = error "no getter for contentType yet"
date :: Label Message String
date = header "Date"
hostname :: Label Message String
hostname = header "Host"
server :: Label Message String
server = header "Server"
-- 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 ""
utf8 :: String
utf8 = "utf-8"
-------- 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, lget 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