module Network.TigHTTP.HttpTypes (
Version(..),
Request(..), RequestType(..), Path(..), Get(..), CacheControl(..),
Accept(..), AcceptLanguage(..), Qvalue(..),
Host(..), Product(..), Connection(..),
Response(..), StatusCode(..), ContentLength(..), contentLength,
ContentType(..), Type(..), Subtype(..), Parameter(..), Charset(..),
TransferEncoding(..),
parseReq, parseResponse, putRequest, putResponse, (+++),
myLast, requestBodyLength, postAddBody,
Post(..),
putPostBody,
requestBody,
requestPath,
AcceptEncoding(..),
HostName,
) where
import Control.Applicative
import "monads-tf" Control.Monad.Trans
import Data.Maybe
import Data.Char
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Data.Time
import Data.Pipe
import Data.Pipe.List
import System.Locale
import Network.TigHTTP.Papillon
import Data.HandleLike
type HostName = String
(+++) :: BS.ByteString -> BS.ByteString -> BS.ByteString
(+++) = BS.append
(-:-) :: Char -> BS.ByteString -> BS.ByteString
(-:-) = BSC.cons
data Request h
= RequestGet Path Version Get
| RequestPost Path Version (Post h)
| RequestRaw RequestType Path Version [(BS.ByteString, BS.ByteString)]
requestBodyLength :: Request h -> Maybe Int
requestBodyLength (RequestPost _ _ p) = contentLength <$> postContentLength p
requestBodyLength _ = Nothing
postAddBody :: HandleLike h => Request h -> BS.ByteString -> Request h
postAddBody (RequestPost u v p) b = RequestPost u v $ p { postBody = pp }
where
pp = fromList [b]
postAddBody r _ = r
putPostBody :: HandleLike h => h -> Request h ->
Pipe () BS.ByteString (HandleMonad h) () -> Request h
putPostBody _ (RequestPost u v p) pp = RequestPost u v $ p { postBody = pp }
putPostBody _ r _ = r
requestBody :: HandleLike h => Request h -> Pipe () BS.ByteString (HandleMonad h) ()
requestBody (RequestPost _ _ p) = postBody p
requestBody _ = return ()
requestPath :: Request h -> Path
requestPath (RequestGet p _ _) = p
requestPath (RequestPost p _ _) = p
requestPath (RequestRaw _ p _ _) = p
putRequest :: HandleLike h => h -> Request h -> HandleMonad h ()
putRequest sv (RequestGet uri vsn g) = do
let r = [
Just $ "GET " +++ showPath uri +++ " " +++ showVersion vsn,
("Host: " +++) . showHost <$> getHost g,
("User-Agent: " +++) . BSC.unwords .
map showProduct <$> getUserAgent g,
("Accept: " +++) . BSC.intercalate "," .
map showAccept <$> getAccept g,
("Accept-Language: " +++) . BSC.intercalate "," .
map showAcceptLanguage <$> getAcceptLanguage g,
("Accept-Encoding: " +++) . BSC.intercalate "," .
map showAcceptEncoding <$> getAcceptEncoding g,
("Connection: " +++) . BSC.intercalate "," .
map showConnection <$> getConnection g,
("Cache-Control: " +++) . BSC.intercalate "," .
map showCacheControl <$> getCacheControl g,
Just ""
]
hlDebug sv "medium" . crlf $ catMaybes r
hlPut sv . crlf $ catMaybes r
putRequest sv (RequestPost uri vsn p) = do
let hd = [
Just $ "POST " +++ showPath uri +++ " " +++ showVersion vsn,
("Host: " +++) . showHost <$> postHost p,
("User-Agent: " +++) . BSC.unwords . map showProduct <$> postUserAgent p,
("Accept: " +++) . BSC.intercalate "," . map showAccept <$> postAccept p,
("Accept-Language: " +++) . BSC.intercalate "," .
map showAcceptLanguage <$> postAcceptLanguage p,
("Accept-Encoding: " +++) . BSC.intercalate "," .
map showAcceptEncoding <$> postAcceptEncoding p,
("Connection: " +++) . BSC.intercalate "," .
map showConnection <$> postConnection p,
("Cache-Control: " +++) . BSC.intercalate "," .
map showCacheControl <$> postCacheControl p,
("Content-Type: " +++) . showContentType <$> postContentType p,
("Content-Length: " +++) . showContentLength <$> postContentLength p
] ++ map (\(k, v) -> Just $ k +++ ": " +++ v) (postOthers p) ++ [
Just "" ]
hlPut sv . crlf $ catMaybes hd
_ <- runPipe $ postBody p =$= putAll sv
return ()
putRequest sv (RequestRaw rt uri vsn kvs) = do
let r = [
Just $ showRequestType rt +++
" " +++ showPath uri +++ " " +++ showVersion vsn ] ++
map (\(k, v) -> Just $ k +++ ": " +++ v) kvs ++ [ Just "" ]
hlPut sv . crlf $ catMaybes r
data Get = Get {
getCacheControl :: Maybe [CacheControl],
getConnection :: Maybe [Connection],
getAccept :: Maybe [Accept],
getAcceptEncoding :: Maybe [AcceptEncoding],
getAcceptLanguage :: Maybe [AcceptLanguage],
getHost :: Maybe Host,
getUserAgent :: Maybe [Product],
getOthers :: [(BS.ByteString, BS.ByteString)]
} deriving Show
data Post h = Post {
postCacheControl :: Maybe [CacheControl],
postConnection :: Maybe [Connection],
postTransferEncoding :: Maybe TransferEncoding,
postAccept :: Maybe [Accept],
postAcceptEncoding :: Maybe [AcceptEncoding],
postAcceptLanguage :: Maybe [AcceptLanguage],
postHost :: Maybe Host,
postUserAgent :: Maybe [Product],
postContentLength :: Maybe ContentLength,
postContentType :: Maybe ContentType,
postOthers :: [(BS.ByteString, BS.ByteString)],
postBody :: Pipe () BS.ByteString (HandleMonad h) () }
data RequestType
= RequestTypeGet
| RequestTypePost
| RequestTypeRaw BS.ByteString
deriving Show
showRequestType :: RequestType -> BS.ByteString
showRequestType RequestTypeGet = "GET"
showRequestType RequestTypePost = "POST"
showRequestType (RequestTypeRaw rt) = rt
data Path = Path BS.ByteString deriving Show
showPath :: Path -> BS.ByteString
showPath (Path uri) = uri
data Version = Version Int Int deriving Show
showVersion :: Version -> BS.ByteString
showVersion (Version vmjr vmnr) =
"HTTP/" +++ BSC.pack (show vmjr) +++ "." +++ BSC.pack (show vmnr)
parseReq :: HandleLike h => [BS.ByteString] -> Request h
parseReq (h : t) = let
(rt, uri, v) = parseRequestLine h in
parseSep rt uri v $ map separate t
where
separate i = let (k, csv) = BSC.span (/= ':') i in
case BS.splitAt 2 csv of
(": ", v) -> (k, v)
_ -> error "parse: bad"
parseReq [] = error "parse: bad request"
parseSep :: HandleLike h => RequestType ->
Path -> Version -> [(BS.ByteString, BS.ByteString)] -> Request h
parseSep RequestTypeGet uri v kvs = RequestGet uri v $ parseGet kvs
parseSep RequestTypePost uri v kvs = RequestPost uri v $ parsePost kvs
parseSep rt uri v kvs = RequestRaw rt uri v kvs
parseRequestLine :: BS.ByteString -> (RequestType, Path, Version)
parseRequestLine rl = let
[rts, uris, vs] = BSC.words rl
rt = case rts of
"GET" -> RequestTypeGet
"POST" -> RequestTypePost
_ -> RequestTypeRaw rts in
(rt, Path uris, parseVersion vs)
parseVersion :: BS.ByteString -> Version
parseVersion httpVns
| ("HTTP/", vns) <- BS.splitAt 5 httpVns = let
(vmjrs, dvmnrs) = BSC.span (/= '.') vns in case BSC.uncons dvmnrs of
Just ('.', vmnrs) -> Version
(read $ BSC.unpack vmjrs) (read $ BSC.unpack vmnrs)
_ -> error "parseVersion: bad http version"
parseVersion _ = error "parseVersion: bad http version"
parseGet :: [(BS.ByteString, BS.ByteString)] -> Get
parseGet kvs = Get {
getHost = parseHost <$> lookup "Host" kvs,
getUserAgent = map parseProduct . sepTkn <$> lookup "User-Agent" kvs,
getAccept = map parseAccept . unlist <$> lookup "Accept" kvs,
getAcceptLanguage =
map parseAcceptLanguage . unlist <$> lookup "Accept-Language" kvs,
getAcceptEncoding =
map parseAcceptEncoding . unlist <$> lookup "Accept-Encoding" kvs,
getConnection = map parseConnection . unlist <$> lookup "Connection" kvs,
getCacheControl =
map parseCacheControl . unlist <$> lookup "Cache-Control" kvs,
getOthers = filter ((`notElem` getKeys) . fst) kvs
}
parsePost :: HandleLike h => [(BS.ByteString, BS.ByteString)] -> Post h
parsePost kvs = Post {
postHost = parseHost <$> lookup "Host" kvs,
postUserAgent = map parseProduct . sepTkn <$> lookup "User-Agent" kvs,
postAccept = map parseAccept . unlist <$> lookup "Accept" kvs,
postAcceptLanguage =
map parseAcceptLanguage . unlist <$> lookup "Accept-Language" kvs,
postAcceptEncoding =
map parseAcceptEncoding . unlist <$> lookup "Accept-Encoding" kvs,
postConnection = map parseConnection . unlist <$> lookup "Connection" kvs,
postCacheControl =
map parseCacheControl . unlist <$> lookup "Cache-Control" kvs,
postContentType = parseContentType <$> lookup "Content-Type" kvs,
postContentLength = ContentLength . read . BSC.unpack <$>
lookup "Content-Length" kvs,
postTransferEncoding = case lookup "Transfer-Encoding" kvs of
Just "chunked" -> Just Chunked
Nothing -> Nothing
_ -> error "bad Transfer-Encoding",
postOthers = filter ((`notElem` postKeys) . fst) kvs,
postBody = return ()
}
postKeys :: [BS.ByteString]
postKeys = [
"Host", "User-Agent", "Accept", "Accept-Language", "Accept-Encoding",
"Connection", "Cache-Control", "Content-Type", "Content-Length",
"Transfer-Encoding"
]
sepTkn :: BS.ByteString -> [BS.ByteString]
sepTkn "" = []
sepTkn psrc
| Just ('(', src) <- BSC.uncons psrc = let
(cm, src') = let (c_, s_) = BSC.span (/= ')') src in
case BSC.uncons s_ of
Just (')', s__) -> (c_, s__)
_ -> error "setTkn: bad comment" in
('(' -:- cm +++ ")") : sepTkn (BSC.dropWhile isSpace src')
sepTkn src = tk : sepTkn (BSC.dropWhile isSpace src')
where
(tk, src') = BSC.span (not . isSpace) src
getKeys :: [BS.ByteString]
getKeys = [
"Host", "User-Agent", "Accept", "Accept-Language", "Accept-Encoding",
"Connection", "Cache-Control"
]
data Host = Host BS.ByteString (Maybe Int) deriving Show
parseHost :: BS.ByteString -> Host
parseHost src = case BSC.span (/= ':') src of
(h, cp) -> case BSC.uncons cp of
Just (':', p) -> Host h (Just . read $ BSC.unpack p)
Nothing -> Host h Nothing
_ -> error "parseHost: never occur"
showHost :: Host -> BS.ByteString
showHost (Host h p) = h +++ maybe "" ((':' -:-) . BSC.pack . show) p
data Product
= Product BS.ByteString (Maybe BS.ByteString)
| ProductComment BS.ByteString
deriving Show
showProduct :: Product -> BS.ByteString
showProduct (Product pn mpv) = pn +++ case mpv of
Just v -> '/' -:- v
_ -> ""
showProduct (ProductComment cm) = "(" +++ cm +++ ")"
parseProduct :: BS.ByteString -> Product
parseProduct pcm
| Just ('(', cm) <- BSC.uncons pcm = case myLast "here" cm of
')' -> ProductComment $ BS.init cm
_ -> error "parseProduct: bad comment"
parseProduct pnv = case BSC.span (/= '/') pnv of
(pn, sv) -> case BSC.uncons sv of
Just ('/', v) -> Product pn $ Just v
_ -> Product pnv Nothing
myLast :: String -> BS.ByteString -> Char
myLast err bs
| BS.null bs = error err
| otherwise = BSC.last bs
data Accept
= Accept (BS.ByteString, BS.ByteString) Qvalue
deriving Show
showAccept :: Accept -> BS.ByteString
showAccept (Accept (t, st) qv) = ((t +++ "/" +++ st) +++) $ showQvalue qv
parseAccept :: BS.ByteString -> Accept
parseAccept src = case BSC.span (/= ';') src of
(mr, sqv) -> case BSC.uncons sqv of
Just (';', qv) -> Accept (parseMediaRange mr) $ parseQvalue qv
Nothing -> Accept (parseMediaRange mr) $ Qvalue 1
_ -> error "parseAccept: never occur"
parseMediaRange :: BS.ByteString -> (BS.ByteString, BS.ByteString)
parseMediaRange src = case BSC.span (/= '/') src of
(t, sst) -> case BSC.uncons sst of
Just ('/', st) -> (t, st)
_ -> error "parseMediaRange: bad media range"
unlist :: BS.ByteString -> [BS.ByteString]
unlist "" = []
unlist src = case BSC.span (/= ',') src of
(h, "") -> [h]
(h, ct) -> case BSC.uncons ct of
Just (',', t) -> h : unlist (BSC.dropWhile isSpace t)
_ -> error "unlist: never occur"
data Qvalue
= Qvalue Double
deriving Show
showQvalue :: Qvalue -> BS.ByteString
showQvalue (Qvalue 1.0) = ""
showQvalue (Qvalue qv) = ";q=" +++ BSC.pack (show qv)
parseQvalue :: BS.ByteString -> Qvalue
parseQvalue qeqv
| ("q=", qv) <- BS.splitAt 2 qeqv = Qvalue . read $ BSC.unpack qv
parseQvalue _ = error "parseQvalue: bad qvalue"
data AcceptLanguage
= AcceptLanguage BS.ByteString Qvalue
deriving Show
showAcceptLanguage :: AcceptLanguage -> BS.ByteString
showAcceptLanguage (AcceptLanguage al qv) = al +++ showQvalue qv
parseAcceptLanguage :: BS.ByteString -> AcceptLanguage
parseAcceptLanguage src = case BSC.span (/= ';') src of
(al, sqv) -> case BSC.uncons sqv of
Just (';', qv) -> AcceptLanguage al $ parseQvalue qv
Nothing -> AcceptLanguage al $ Qvalue 1
_ -> error "parseAcceptLanguage: never occur"
data AcceptEncoding
= AcceptEncoding BS.ByteString Qvalue
deriving Show
showAcceptEncoding :: AcceptEncoding -> BS.ByteString
showAcceptEncoding (AcceptEncoding ae qv) = ae +++ showQvalue qv
parseAcceptEncoding :: BS.ByteString -> AcceptEncoding
parseAcceptEncoding src = case BSC.span (/= ';') src of
(ae, sqv) -> case BSC.uncons sqv of
Just (';', qv) -> AcceptEncoding ae $ parseQvalue qv
Nothing -> AcceptEncoding ae $ Qvalue 1
_ -> error "parseAcceptEncoding: never occur"
data Connection
= Connection BS.ByteString
deriving Show
showConnection :: Connection -> BS.ByteString
showConnection (Connection c) = c
parseConnection :: BS.ByteString -> Connection
parseConnection = Connection
data CacheControl
= MaxAge Int
| CacheControlRaw BS.ByteString
deriving Show
showCacheControl :: CacheControl -> BS.ByteString
showCacheControl (MaxAge ma) = "max-age=" +++ BSC.pack (show ma)
showCacheControl (CacheControlRaw cc) = cc
parseCacheControl :: BS.ByteString -> CacheControl
parseCacheControl ccma
| ("max-age", ema) <- BSC.span (/= '=') ccma = case BSC.uncons ema of
Just ('=', ma) -> MaxAge . read $ BSC.unpack ma
_ -> error "parseCacheControl: bad"
parseCacheControl cc = CacheControlRaw cc
data Response p h = Response {
responseVersion :: Version,
responseStatusCode :: StatusCode,
responseConnection :: Maybe BS.ByteString,
responseDate :: Maybe UTCTime,
responseTransferEncoding :: Maybe TransferEncoding,
responseAcceptRanges :: Maybe BS.ByteString,
responseETag :: Maybe BS.ByteString,
responseServer :: Maybe [Product],
responseContentLength :: Maybe ContentLength,
responseContentType :: ContentType,
responseLastModified :: Maybe UTCTime,
responseOthers :: [(BS.ByteString, BS.ByteString)],
responseBody :: p () BS.ByteString (HandleMonad h) ()
}
parseResponse :: (
Monad (p () BS.ByteString (HandleMonad h)),
HandleLike h) =>
[BS.ByteString] -> Response p h
parseResponse (h : t) = let (v, sc) = parseResponseLine h in
parseResponseSep v sc $ map separate t
where
separate i = let (k, csv) = BSC.span (/= ':') i in
case BS.splitAt 2 csv of
(": ", v) -> (k, v)
_ -> error "parseResponse: bad response"
parseResponse _ = error "parseResponse: bad response"
parseResponseSep :: (
Monad (p () BS.ByteString (HandleMonad h)),
HandleLike h) =>
Version -> StatusCode ->
[(BS.ByteString, BS.ByteString)] -> Response p h
parseResponseSep v sc kvs = Response {
responseVersion = v,
responseStatusCode = sc,
responseDate = readTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S" .
BSC.unpack . initN 4 <$> lookup "Date" kvs,
responseContentLength = ContentLength . read . BSC.unpack <$>
lookup "Content-Length" kvs,
responseTransferEncoding = case lookup "Transfer-Encoding" kvs of
Just "chunked" -> Just Chunked
Nothing -> Nothing
_ -> error "bad Transfer-Encoding",
responseContentType = parseContentType . fromJust $
lookup "Content-Type" kvs,
responseServer = map parseProduct . sepTkn <$> lookup "Server" kvs,
responseLastModified = readTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S" .
BSC.unpack . initN 4 <$> lookup "Last-Modified" kvs,
responseETag = lookup "ETag" kvs,
responseAcceptRanges = lookup "Accept-Ranges" kvs,
responseConnection = lookup "Connection" kvs,
responseOthers = filter ((`notElem` responseKeys) . fst) kvs,
responseBody = return ()
}
responseKeys :: [BS.ByteString]
responseKeys = [
"Date", "Content-Length", "Content-Type", "Server", "Last-Modified",
"ETag", "Accept-Ranges", "Connection", "Transfer-Encoding" ]
initN :: Int -> BS.ByteString -> BS.ByteString
initN n lst = BS.take (BS.length lst n) lst
parseResponseLine :: BS.ByteString -> (Version, StatusCode)
parseResponseLine src = case BSC.span (/= ' ') src of
(vs, sscs) -> case BSC.uncons sscs of
Just (' ', scs) -> (parseVersion vs, parseStatusCode scs)
_ -> error "parseResponseLine: bad response line"
parseStatusCode :: BS.ByteString -> StatusCode
parseStatusCode sc
| ("200", _) <- BSC.span (not . isSpace) sc = OK
| ("301", _) <- BSC.span (not . isSpace) sc = MovedPermanently
| ("302", _) <- BSC.span (not . isSpace) sc = Found
| ("400", _) <- BSC.span (not . isSpace) sc = BadRequest
parseStatusCode sc = error $ "parseStatusCode: bad status code: " ++ BSC.unpack sc
putResponse :: (
PipeClass p, MonadTrans (p BS.ByteString ()),
Monad (p BS.ByteString () (HandleMonad h)),
HandleLike h) =>
h -> Response p h -> HandleMonad h ()
putResponse cl r = do
let hd = [
Just $ showVersion (responseVersion r) +++ " " +++
showStatusCode (responseStatusCode r),
Just $ "Date: " +++ maybe "" showTime (responseDate r),
("Content-Length: " +++) . showContentLength <$>
responseContentLength r,
("Transfer-Encoding: " +++) . showTransferEncoding <$>
responseTransferEncoding r,
Just $ "Content-Type: " +++
showContentType (responseContentType r),
("Server: " +++) . BSC.unwords . map showProduct <$> responseServer r,
("Last-Modified: " +++) . showTime <$> responseLastModified r,
("ETag: " +++) <$> responseETag r,
("Accept-Ranges: " +++) <$> responseAcceptRanges r,
("Connection: " +++) <$> responseConnection r
] ++
map (\(k, v) -> Just $ k +++ ": " +++ v) (responseOthers r) ++
[ Just "" ]
p = responseBody r
hlPut cl . crlf $ catMaybes hd
_ <- runPipe $ p =$= putAll cl
return ()
putAll :: (
PipeClass p, MonadTrans (p BS.ByteString ()),
Monad (p BSC.ByteString () (HandleMonad h)),
HandleLike h) =>
h -> p BS.ByteString () (HandleMonad h) ()
putAll cl = do
ms <- await
case ms of
Just s -> do
lift $ hlPut cl s
putAll cl
_ -> return ()
crlf :: [BS.ByteString] -> BS.ByteString
crlf = BS.concat . map (`BS.append` "\r\n")
data StatusCode
= Continue
| SwitchingProtocols
| OK
| MovedPermanently
| Found
| BadRequest
deriving Show
showStatusCode :: StatusCode -> BS.ByteString
showStatusCode Continue = "100 Continue"
showStatusCode SwitchingProtocols = "101 SwitchingProtocols"
showStatusCode OK = "200 OK"
showStatusCode MovedPermanently = "301 Moved Permanently"
showStatusCode Found = "302 Found"
showStatusCode BadRequest = "400 Bad Request"
data ContentLength = ContentLength Int deriving Show
showContentLength :: ContentLength -> BS.ByteString
showContentLength (ContentLength n) = BSC.pack $ show n
contentLength :: ContentLength -> Int
contentLength (ContentLength n) = n
data TransferEncoding = Chunked deriving Show
showTransferEncoding :: TransferEncoding -> BS.ByteString
showTransferEncoding Chunked = "chunked"
showTime :: UTCTime -> BS.ByteString
showTime = BSC.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT"