module Data.HttpSpec.HttpTypes
(HttpBody, HttpMethod, HttpUrl, HttpCode, HttpReason
,HttpHeaderName, HttpHeaderValue, HttpHeader, HttpHeaders
,HttpParamName, HttpParamValue, HttpParams
,HttpData(..), ReqIn(..), ReqOut(..), ResIn(..), ResOut(..)
,IsHttp(..), IsReq(..), IsRes(..)
,reqIn_body, reqIn_headers, reqOut_body, reqOut_headers
,resIn_body, resIn_headers, resOut_body, resOut_headers
,urlParams, urlMatchPrefix, urlMatchPrefix', urlSplit, url
,completeReq, completeRes, mkHeaderName)
where
import Data.Char (toLower)
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map
import Data.List (intersperse, unfoldr, isPrefixOf)
import Control.Monad (liftM)
import Control.Arrow (first)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as BSLChar
import Data.Encoding (decodeLazyByteStringExplicit)
import qualified Network.HTTP as Http
import qualified Network.URI as Uri
import qualified Network.CGI as Cgi
import Text.PrettyPrint.HughesPJ (Doc, ($+$), (<+>), (<>), text, colon
,int, empty)
import Safe (headMay)
import Data.HttpSpec.Pretty (Pretty(..))
import Data.HttpSpec.EncodingHelper (xmlEncoding, encodingFromContentType)
type HttpPath = String
type HttpParamName = String
type HttpParamValue = String
type HttpParams = [(HttpParamName, HttpParamValue)]
type HttpUrl = Uri.URI
type HttpHeaderName = Http.HeaderName
type HttpHeaderValue = String
type HttpHeader = (HttpHeaderName, String)
type HttpHeaders = [HttpHeader]
type HttpBody = BSL.ByteString
type HttpMethod = Http.RequestMethod
type HttpCode = Int
type HttpReason = String
data HttpData = HttpData { http_headers :: HttpHeaders
, http_body :: HttpBody
}
deriving (Show)
data ReqIn = ReqIn { reqIn_progUrl :: HttpUrl
, reqIn_fullUrl :: HttpUrl
, reqIn_method :: HttpMethod
, reqIn_data :: HttpData
}
deriving (Show)
reqIn_body :: ReqIn -> HttpBody
reqIn_body = http_body . reqIn_data
reqIn_headers :: ReqIn -> HttpHeaders
reqIn_headers = http_headers . reqIn_data
data ReqOut = ReqOut { reqOut_url :: HttpUrl
, reqOut_method :: HttpMethod
, reqOut_data :: HttpData }
deriving (Show)
reqOut_body :: ReqOut -> HttpBody
reqOut_body = http_body . reqOut_data
reqOut_headers :: ReqOut -> HttpHeaders
reqOut_headers = http_headers . reqOut_data
data ResIn = ResIn { resIn_code :: HttpCode
, resIn_reason :: HttpReason
, resIn_data :: HttpData }
deriving (Show)
resIn_body :: ResIn -> HttpBody
resIn_body = http_body . resIn_data
resIn_headers :: ResIn -> HttpHeaders
resIn_headers = http_headers . resIn_data
data ResOut = ResOut { resOut_code :: HttpCode
, resOut_reason :: Maybe HttpReason
, resOut_data :: HttpData }
deriving (Show)
resOut_body :: ResOut -> HttpBody
resOut_body = http_body . resOut_data
resOut_headers :: ResOut -> HttpHeaders
resOut_headers = http_headers . resOut_data
instance Ord Http.HeaderName where
compare hn1 hn2 = compare (mapHdr hn1) (mapHdr hn2)
where mapHdr (Http.HdrCustom l) = Left l
mapHdr other = Right (show other)
mkHeaderName :: String -> HttpHeaderName
mkHeaderName s'
| s == "content-length" = Http.HdrContentLength
| s == "content-md5" = Http.HdrContentMD5
| s == "content-type" = Http.HdrContentType
| s == "content-encoding" = Http.HdrContentEncoding
| s == "content-transfer-encoding" = Http.HdrContentTransferEncoding
| s == "transfer-encoding" = Http.HdrTransferEncoding
| s == "user-agent" = Http.HdrUserAgent
| otherwise = Http.HdrCustom s'
where s = map toLower s'
url :: String -> HttpUrl
url s = case Uri.parseURI s of
Just uri -> uri
Nothing -> error $ "HttpTypes.url: Invalid URI `" ++ s ++ "'"
urlParams :: HttpUrl -> HttpParams
urlParams uri = Cgi.formDecode $ dropWhile (=='?') (Uri.uriQuery uri)
urlAddParam :: HttpParamName -> HttpParamValue -> HttpUrl -> HttpUrl
urlAddParam n v uri = uri'
where params = Cgi.formDecode $ dropWhile (=='?') (Uri.uriQuery uri)
params' = (n,v) : params
uri' = uri { Uri.uriQuery = '?' : Cgi.formEncode params' }
urlAppendPath :: HttpPath -> HttpUrl -> HttpUrl
urlAppendPath path uri = uri { Uri.uriPath = Uri.uriPath uri ++ path }
urlSetPath :: HttpPath -> HttpUrl -> HttpUrl
urlSetPath path uri = uri { Uri.uriPath = path }
urlSplit :: Monad m => HttpUrl -> m (HttpPath, HttpUrl)
urlSplit uri = liftM mapUri (uriPathSplit $ Uri.uriPath uri)
where
mapUri (hd, tl) = (hd, uri { Uri.uriPath = tl })
uriPathSplit "" = fail "Empty URL Path."
uriPathSplit "/" = return ("/", "")
uriPathSplit ('/':path) = liftM (first ('/':)) (uriPathSplit path)
uriPathSplit path = return $ span (/='/') path
urlMatchPrefix :: HttpPath -> HttpUrl -> Maybe HttpUrl
urlMatchPrefix s uri
| s `isPrefixOf` path = Just $ uri { Uri.uriPath = drop (length s) path }
| otherwise = Nothing
where path = Uri.uriPath uri
urlMatchPrefix' :: HttpUrl -> HttpUrl -> Maybe HttpUrl
urlMatchPrefix' prefixUrl = urlMatchPrefix prefixPath
where prefixPath = Uri.uriPath prefixUrl
completeReq :: IsHttp req => req -> req
completeReq r = if clen /= 0 then r2 else r
where
clen = BSL.length (httpBody r)
r1 | not (httpHasHeader Http.HdrTransferEncoding r)
&& not (httpHasHeader Http.HdrContentLength r)
= httpSetHeader Http.HdrContentLength (show clen) r
| otherwise = r
r2 | not (httpHasHeader Http.HdrContentType r1)
= httpSetHeader Http.HdrContentType "application/octet-stream" r1
| otherwise = r1
completeRes :: IsHttp res => res -> res
completeRes = completeReq
class IsHttp a where
httpData :: a -> HttpData
httpSetData :: a -> HttpData -> a
httpHeaders :: a -> HttpHeaders
httpHeaders = http_headers . httpData
httpBody :: a -> HttpBody
httpBody = http_body . httpData
httpGetHeader :: HttpHeaderName -> a -> Maybe HttpHeaderValue
httpGetHeader hn x =
case hn of
Http.HdrCustom mixedName -> headMay vals
where vals = [v | (Http.HdrCustom n, v) <- httpHeaders x, map toLower n == name]
name = map toLower mixedName
_ -> lookup hn (httpHeaders x)
httpHasHeader :: HttpHeaderName -> a -> Bool
httpHasHeader n = (/=Nothing) . httpGetHeader n
httpSetBody :: HttpBody -> a -> a
httpSetBody body this = httpSetData this (HttpData (httpHeaders this) body)
httpSetHeaders :: HttpHeaders -> a -> a
httpSetHeaders hs this = httpSetData this (HttpData hs (httpBody this))
httpSetHeader :: HttpHeaderName -> HttpHeaderValue -> a -> a
httpSetHeader name val this = flip httpSetHeaders this .
Map.toList $
Map.insert name val $
Map.fromList (httpHeaders this)
class IsHttp a => IsRes a where
resCode :: a -> HttpCode
resSetStatus :: HttpCode -> Maybe HttpReason -> a -> a
resReason :: a -> HttpReason
resReason res = fromMaybe def $ lookup (resCode res) statusCodeMessageMap
where def = ""
class IsHttp a => IsReq a where
reqMethod :: a -> HttpMethod
reqUrl :: a -> HttpUrl
reqSetMethod :: HttpMethod -> a -> a
reqSetUrl :: HttpUrl -> a -> a
reqUrlPath :: a -> HttpPath
reqUrlPath req = Uri.uriPath (reqUrl req)
reqSetUrlPath :: HttpPath -> a -> a
reqSetUrlPath p req = reqSetUrl (urlSetPath p (reqUrl req)) req
reqAppendUrlPath :: HttpPath -> a -> a
reqAppendUrlPath p req = reqSetUrl (urlAppendPath p (reqUrl req)) req
reqAddUrlParam :: HttpParamName -> HttpParamValue -> a -> a
reqAddUrlParam n v r = reqSetUrl (urlAddParam n v (reqUrl r)) r
instance IsHttp HttpData where
httpData = id
httpSetData = const
instance IsHttp ReqIn where
httpData = reqIn_data
httpSetData this x = this { reqIn_data = x }
instance IsHttp ReqOut where
httpData = reqOut_data
httpSetData this x = this { reqOut_data = x }
instance IsHttp ResIn where
httpData = resIn_data
httpSetData this x = this { resIn_data = x }
instance IsHttp ResOut where
httpData = resOut_data
httpSetData this x = this { resOut_data = x }
instance IsRes ResIn where
resCode = resIn_code
resSetStatus code mr r = r { resIn_reason = fromMaybe (resIn_reason r) mr
, resIn_code = code }
instance IsRes ResOut where
resCode = resOut_code
resSetStatus code mr r = r { resOut_reason = mr
, resOut_code = code }
instance IsReq ReqIn where
reqMethod = reqIn_method
reqUrl = reqIn_fullUrl
reqSetMethod meth req = req { reqIn_method = meth }
reqSetUrl newUrl req = req { reqIn_fullUrl = newUrl }
instance IsReq ReqOut where
reqMethod = reqOut_method
reqUrl = reqOut_url
reqSetMethod meth req = req { reqOut_method = meth }
reqSetUrl newUrl req = req { reqOut_url = newUrl }
pprReq :: IsReq req => req -> Doc
pprReq req = ppr (reqMethod req) <+> ppr (reqUrl req) <+> text "HTTP/1.1"
$+$ ppr (httpData req)
pprRes :: IsRes res => res -> Doc
pprRes res = int (resCode res) <+> text (resReason res) $+$ ppr (httpData res)
pprHttpBody :: Maybe String -> BSL.ByteString -> Doc
pprHttpBody mctype b =
case mctype of
Just ctype | "text/xml" `isPrefixOf` ctype || "application/xml" `isPrefixOf` ctype
-> pprWithEncoding (xmlEncoding b)
Just ctype | "text/" `isPrefixOf` ctype
-> pprWithEncoding (encodingFromContentType ctype)
Nothing | BSL.length b == 0 -> empty
_ ->
let hd' = BSL.take (fromIntegral maxbytes) b
hd = BSLChar.takeWhile (<'\128') hd'
unfold x = if BSL.length x > (fromIntegral maxlinelen)
then Just (BSL.splitAt (fromIntegral maxlinelen) x)
else Nothing
in if BSL.length hd' > 20
then (text . BSLChar.unpack . BSL.concat . intersperse binsep) (unfoldr unfold hd)
else (text "[" <> text (show $ BSL.length b) <+> text "bytes"
<+> text (fromMaybe "binary data" mctype) <> text "]")
where
pprWithEncoding Nothing =
(text ("Could not determine encoding of body of content-type "
++ fromMaybe "(unknown)" mctype ++ ".")
$+$ text "The first 64 bytes are: "
$+$ text (show (BSL.take 64 b)))
pprWithEncoding (Just enc) =
case decodeLazyByteStringExplicit enc b of
Left err -> text ("Could not decode body with " ++ show (BSL.length b) ++ " bytes " ++
" using the given encoding " ++ show enc ++ ": " ++ show err)
Right s -> foldl ($+$) empty (map text $ "" : showlines s)
showlines s | (showlines'' s) /= lines s = (showlines'' s) ++ ["[body shortend!]"]
| otherwise = bodylines s
showlines'' s = map (shorten maxlinelen) (showlines' s)
showlines' s =
let (shorts,longs) = (span ((<=maxtakelinelen) . length) . take 25) (bodylines s)
in shorts ++ take 1 longs
bodylines s = lines (take maxbytes s)
maxbytes = 1500
binsep = BSLChar.pack "\\\n"
maxtakelinelen = 160
maxlinelen = 100
shorten :: Int -> String -> String
shorten i s
| length s <= i = s
| otherwise = take (i3) s ++ "..."
instance Pretty Uri.URI where
ppr = text . show
instance Pretty HttpData where
ppr http@(HttpData hds b) = headers $+$ body
where
body = pprHttpBody (httpGetHeader Http.HdrContentType http) b
headers = foldl ($+$) empty (map pprHd hds)
pprHd (n,v) = text (show n) <> colon <+> text v
instance Pretty ReqIn where
ppr = pprReq
instance Pretty ReqOut where
ppr = pprReq
instance Pretty ResIn where
ppr = pprRes
instance Pretty ResOut where
ppr = pprRes
instance Pretty Http.RequestMethod where
ppr = text . show
statusCodeMessageMap :: [(Int, String)]
statusCodeMessageMap =
[(100, "Continue")
,(101, "Switching Protocols")
,(200, "OK")
,(201, "Created")
,(202, "Accepted")
,(203, "Non-Authoritative Information")
,(204, "No Content")
,(205, "Reset Content")
,(206, "Partial Content")
,(300, "Multiple Choices")
,(301, "Moved Permanently")
,(302, "Found")
,(303, "See Other")
,(304, "Not Modified")
,(305, "Use Proxy")
,(307, "Temporary Redirect")
,(400, "Bad Request")
,(401, "Unauthorized")
,(402, "Payment Required")
,(403, "Forbidden")
,(404, "Not Found")
,(405, "Method Not Allowed")
,(406, "Not Acceptable")
,(407, "Proxy Authentication Required")
,(408, "Request Time-out")
,(409, "Conflict")
,(410, "Gone")
,(411, "Length Required")
,(412, "Precondition Failed")
,(413, "Request Entity Too Large")
,(414, "Request-URI Too Large")
,(415, "Unsupported Media Type")
,(416, "Requested range not satisfiable")
,(417, "Expectation Failed")
,(500, "Internal Server Error")
,(501, "Not Implemented")
,(502, "Bad Gateway")
,(503, "Service Unavailable")
,(504, "Gateway Time-out")
,(505, "HTTP Version not supported")
]