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, catMaybes) import Data.Map (Map) import qualified Data.Map as Map import Data.List (isPrefixOf) import Control.Monad (liftM) import Control.Arrow (first) import System.FilePath (takeDirectory, ()) ---------------------------------------- -- 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, vcat, ($+$), (<+>), (<>), text, colon ,int, empty) import Safe (headMay) ---------------------------------------- -- LOCAL ---------------------------------------- import Data.HttpSpec.Pretty (Pretty(..)) -- ============================================================================ -- 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 = String -- 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 = http_body . reqIn_data reqIn_headers = http_headers . reqIn_data data ReqOut = ReqOut { reqOut_url :: HttpUrl , reqOut_method :: HttpMethod , reqOut_data :: HttpData } deriving (Show) reqOut_body = http_body . reqOut_data reqOut_headers = http_headers . reqOut_data data ResIn = ResIn { resIn_code :: HttpCode , resIn_reason :: HttpReason , resIn_data :: HttpData } deriving (Show) resIn_body = http_body . resIn_data resIn_headers = http_headers . resIn_data data ResOut = ResOut { resOut_code :: HttpCode , resOut_reason :: Maybe HttpReason , resOut_data :: HttpData } deriving (Show) resOut_body = http_body . resOut_data 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 = Http.HdrCustom 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 } -- | 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 (head, tail) = (head, uri { Uri.uriPath = tail }) 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 = 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 n x = case n of Http.HdrCustom mixedName -> headMay vals where vals = [v | (Http.HdrCustom n, v) <- httpHeaders x, map toLower n == name] name = map toLower mixedName _ -> lookup n (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) 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 url req = req { reqIn_fullUrl = url } instance IsReq ReqOut where reqMethod = reqOut_method reqUrl = reqOut_url reqSetMethod meth req = req { reqOut_method = meth } reqSetUrl url req = req { reqOut_url = url } 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) instance Pretty Uri.URI where ppr = text . show instance Pretty HttpData where ppr (HttpData hds b) = foldl ($+$) empty (map pprHd hds) $+$ foldl ($+$) empty (map text $ "" : bodylines) where pprHd (n,v) = text (show n) <> colon <+> text v showlines | showlines' /= bodylines = bodylines ++ ["[...]"] | otherwise = bodylines showlines' = takeWhile ((<=80) . length) $ take 5 bodylines bodylines = lines b 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") ]