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 ---------------------------------------- -- STDLIB ---------------------------------------- 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) ---------------------------------------- -- SITE-PACKAGES ---------------------------------------- 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) ---------------------------------------- -- LOCAL ---------------------------------------- import Data.HttpSpec.Pretty (Pretty(..)) import Data.HttpSpec.EncodingHelper (xmlEncoding, encodingFromContentType) -- ============================================================================ -- http types -- ============================================================================ -- URL types type HttpPath = String type HttpParamName = String type HttpParamValue = String type HttpParams = [(HttpParamName, HttpParamValue)] type HttpUrl = Uri.URI -- Http message types type HttpHeaderName = Http.HeaderName type HttpHeaderValue = String type HttpHeader = (HttpHeaderName, String) type HttpHeaders = [HttpHeader] type HttpBody = BSL.ByteString -- Request types type HttpMethod = Http.RequestMethod -- Response types 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 -- ============================================================================ -- helper functions and instances -- ============================================================================ 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 } -- | Splits off the first path component of a URL. -- @urlSplit (url "http://svr/foo/bar") == Just ("/foo", url "http://svr/bar")@ -- @urlSplit (url "http://svr/") == Just ("/", url "http://svr")@ -- @urlSplit (url "http://svr") == Nothing@ 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 -- ============================================================================ -- access helper type classes -- ============================================================================ class IsHttp a where -- required methods httpData :: a -> HttpData httpSetData :: a -> HttpData -> a -- methods with default implementations 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 (i-3) 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") ]