tighttp 0.0.0.8 → 0.0.0.9
raw patch · 7 files changed
+144/−6 lines, 7 files
Files
- examples/get.hs +2/−0
- src/Network/TigHTTP/Client.hs +2/−0
- src/Network/TigHTTP/CookieTime.hs +16/−0
- src/Network/TigHTTP/HttpTypes.hs +119/−4
- src/Network/TigHTTP/Server.hs +1/−0
- src/Network/TigHTTP/Types.hs +2/−0
- tighttp.cabal +2/−2
examples/get.hs view
@@ -14,6 +14,8 @@ addr : pth : _ <- getArgs h <- connectTo addr $ PortNumber 80 r <- request h $ get addr 80 pth+ print $ responseOthers r+ print $ responseSetCookie r _ <- runPipe $ responseBody r =$= finally printP (putStrLn "") return ()
src/Network/TigHTTP/Client.hs view
@@ -45,6 +45,7 @@ getAcceptEncoding = Just [], getConnection = Just [Connection "keep-alive"], getCacheControl = Just [MaxAge 0],+ getCookie = [], getOthers = [] } @@ -102,6 +103,7 @@ postContentType = Just $ ContentType Text Plain [], postContentLength = cl, postTransferEncoding = ch,+ postCookie = [], postOthers = [], postBody = fromList cnt }
+ src/Network/TigHTTP/CookieTime.hs view
@@ -0,0 +1,16 @@+module Network.TigHTTP.CookieTime (+ cookieExpiresTime, parseCookieExpiresTime) where++import Data.Time+import System.Locale++import qualified Data.ByteString.Char8 as BSC++format :: String+format = "%a, %d-%b-%Y %H:%M:%S GMT"++cookieExpiresTime :: UTCTime -> BSC.ByteString+cookieExpiresTime = BSC.pack . formatTime defaultTimeLocale format++parseCookieExpiresTime :: BSC.ByteString -> Maybe UTCTime+parseCookieExpiresTime = parseTime defaultTimeLocale format . BSC.unpack
src/Network/TigHTTP/HttpTypes.hs view
@@ -19,12 +19,17 @@ AcceptEncoding(..), HostName,++ SetCookie(..), setCookie, ) where import Control.Applicative import "monads-tf" Control.Monad.Trans import Data.Maybe+import Data.List+import Text.Read (readMaybe) import Data.Char+-- import Data.List import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import Data.Time@@ -33,6 +38,7 @@ import System.Locale import Network.TigHTTP.Papillon+import Network.TigHTTP.CookieTime import Data.HandleLike @@ -90,6 +96,11 @@ map showConnection <$> getConnection g, ("Cache-Control: " +++) . BSC.intercalate "," . map showCacheControl <$> getCacheControl g,+ ("Cookie : " +++) . BSC.intercalate "; " .+ map (\(k, v) -> k +++ "=" +++ v) <$>+ if null $ getCookie g+ then Nothing+ else Just $ getCookie g, Just "" ] hlDebug sv "medium" . crlf $ catMaybes r@@ -109,7 +120,12 @@ ("Cache-Control: " +++) . BSC.intercalate "," . map showCacheControl <$> postCacheControl p, ("Content-Type: " +++) . showContentType <$> postContentType p,- ("Content-Length: " +++) . showContentLength <$> postContentLength p+ ("Content-Length: " +++) . showContentLength <$> postContentLength p,+ ("Cookie : " +++) . BSC.intercalate "; " .+ map (\(k, v) -> k +++ "=" +++ v) <$>+ if null $ postCookie p+ then Nothing+ else Just $ postCookie p ] ++ map (\(k, v) -> Just $ k +++ ": " +++ v) (postOthers p) ++ [ Just "" ] hlDebug sv "medium" . crlf $ catMaybes hd@@ -131,6 +147,7 @@ getAcceptLanguage :: Maybe [AcceptLanguage], getHost :: Maybe Host, getUserAgent :: Maybe [Product],+ getCookie :: [(BS.ByteString, BS.ByteString)], getOthers :: [(BS.ByteString, BS.ByteString)] } deriving Show @@ -145,6 +162,7 @@ postUserAgent :: Maybe [Product], postContentLength :: Maybe ContentLength, postContentType :: Maybe ContentType,+ postCookie :: [(BS.ByteString, BS.ByteString)], postOthers :: [(BS.ByteString, BS.ByteString)], postBody :: Pipe () BS.ByteString (HandleMonad h) () } @@ -220,6 +238,7 @@ getConnection = map parseConnection . unlist <$> lookup "Connection" kvs, getCacheControl = map parseCacheControl . unlist <$> lookup "Cache-Control" kvs,+ getCookie = maybe [] parseCookie $ lookup "Cookie" kvs, getOthers = filter ((`notElem` getKeys) . fst) kvs } @@ -242,6 +261,7 @@ Just "chunked" -> Just Chunked Nothing -> Nothing _ -> error "bad Transfer-Encoding",+ postCookie = maybe [] parseCookie $ lookup "Cookie" kvs, postOthers = filter ((`notElem` postKeys) . fst) kvs, postBody = return () }@@ -272,7 +292,7 @@ getKeys :: [BS.ByteString] getKeys = [ "Host", "User-Agent", "Accept", "Accept-Language", "Accept-Encoding",- "Connection", "Cache-Control"+ "Connection", "Cache-Control", "Cookie" ] data Host = Host BS.ByteString (Maybe Int) deriving Show@@ -408,6 +428,12 @@ _ -> error "parseCacheControl: bad" parseCacheControl cc = CacheControlRaw cc +parseCookie :: BS.ByteString -> [(BS.ByteString, BS.ByteString)]+parseCookie bs =+ map ((\[k, v] -> (BSC.dropWhile isSpace k, BSC.dropWhile isSpace v))+ . BSC.split '=')+ $ BSC.split ';' bs+ data Response p h = Response { responseVersion :: Version, responseStatusCode :: StatusCode,@@ -420,10 +446,36 @@ responseContentLength :: Maybe ContentLength, responseContentType :: ContentType, responseLastModified :: Maybe UTCTime,+ responseSetCookie :: [SetCookie], responseOthers :: [(BS.ByteString, BS.ByteString)], responseBody :: p () BS.ByteString (HandleMonad h) () } +data SetCookie = SetCookie {+ cookieName :: BS.ByteString,+ cookieValue :: BS.ByteString,+ cookieExpires :: Maybe UTCTime,+ cookieMaxAge :: Maybe DiffTime,+ cookieDomain :: Maybe BS.ByteString,+ cookiePath :: Maybe BS.ByteString,+ cookieSecure :: Bool,+ cookieHttpOnly :: Bool,+ cookieExtension :: [BS.ByteString]+ } deriving Show++setCookie :: BS.ByteString -> BS.ByteString -> SetCookie+setCookie n v = SetCookie {+ cookieName = n,+ cookieValue = v,+ cookieExpires = Nothing,+ cookieMaxAge = Nothing,+ cookieDomain = Nothing,+ cookiePath = Nothing,+ cookieSecure = True,+ cookieHttpOnly = True,+ cookieExtension = []+ }+ parseResponse :: ( Monad (p () BS.ByteString (HandleMonad h)), HandleLike h) =>@@ -462,14 +514,64 @@ responseETag = lookup "ETag" kvs, responseAcceptRanges = lookup "Accept-Ranges" kvs, responseConnection = lookup "Connection" kvs,+ responseSetCookie = map parseSetCookie . map snd $ filter ((== "Set-Cookie") . fst) kvs , responseOthers = filter ((`notElem` responseKeys) . fst) kvs, responseBody = return ()- }+ } +parseSetCookie :: BS.ByteString -> SetCookie+parseSetCookie bs = SetCookie {+ cookieName = nm,+ cookieValue = vl,+ cookieExpires = (\(CookieExpires e) -> e) <$> find isCookieExpires cas,+ cookieMaxAge = (\(CookieMaxAge ma) -> ma) <$> find isCookieMaxAge cas,+ cookieDomain = (\(CookieDomain d) -> d) <$> find isCookieDomain cas,+ cookiePath = (\(CookiePath p) -> p) <$> find isCookiePath cas,+ cookieSecure = CookieSecure `elem` cas,+ cookieHttpOnly = CookieHttpOnly `elem` cas,+ cookieExtension = (\(CookieExtension e) -> e) <$> filter isCookieExtension cas+ }+ where+ (nmvl) : kvs = map (BSC.dropWhile isSpace) $ BSC.split ';' bs+ [nm, vl] = BSC.split '=' nmvl+ cas = map cookieAttr kvs++cookieAttr :: BS.ByteString -> CookieAttr+cookieAttr ca+ | ["Expires", v] <- av, Just d <- parseCookieExpiresTime v =+ CookieExpires d+ | ["Max-Age", v] <- av, Just ma <- fromInteger <$> readMaybe (BSC.unpack v) =+ CookieMaxAge ma+ | ["Domain", v] <- av = CookieDomain v+ | ["Path", v] <- av = CookiePath v+ where+ av = BSC.split '=' ca+cookieAttr "Secure" = CookieSecure+cookieAttr "HttpOnly" = CookieHttpOnly+cookieAttr ca = CookieExtension ca++data CookieAttr+ = CookieExpires UTCTime+ | CookieMaxAge DiffTime+ | CookieDomain BS.ByteString+ | CookiePath BS.ByteString+ | CookieSecure+ | CookieHttpOnly+ | CookieExtension BS.ByteString+ deriving (Show, Eq)++isCookieExpires, isCookieMaxAge, isCookieDomain,+ isCookiePath, isCookieExtension :: CookieAttr -> Bool+isCookieExpires (CookieExpires _) = True; isCookieExpires _ = False+isCookieMaxAge (CookieMaxAge _) = True; isCookieMaxAge _ = False+isCookieDomain (CookieDomain _) = True; isCookieDomain _ = False+isCookiePath (CookiePath _) = True; isCookiePath _ = False+isCookieExtension (CookieExtension _) = True; isCookieExtension _ = False+ responseKeys :: [BS.ByteString] responseKeys = [ "Date", "Content-Length", "Content-Type", "Server", "Last-Modified",- "ETag", "Accept-Ranges", "Connection", "Transfer-Encoding" ]+ "ETag", "Accept-Ranges", "Connection", "Transfer-Encoding", "Set-Cookie" ] initN :: Int -> BS.ByteString -> BS.ByteString initN n lst = BS.take (BS.length lst - n) lst@@ -537,12 +639,25 @@ ("Accept-Ranges: " +++) <$> responseAcceptRanges r, ("Connection: " +++) <$> responseConnection r ] +++ map (Just . ("Set-Cookie: " +++) . showSetCookie)+ (responseSetCookie r) ++ map (\(k, v) -> Just $ k +++ ": " +++ v) (responseOthers r) ++ [ Just "" ] p = responseBody r hlPut cl . crlf $ catMaybes hd _ <- runPipe $ p =$= putAll cl return ()++showSetCookie :: SetCookie -> BS.ByteString+showSetCookie sc = BS.intercalate "; " $ catMaybes [+ Just $ cookieName sc +++ "=" +++ cookieValue sc,+ ("Expires=" +++) . cookieExpiresTime <$> cookieExpires sc,+ ("Max-Age=" +++) . BSC.pack . init . show <$> cookieMaxAge sc,+ ("Domain=" +++) <$> cookieDomain sc,+ ("Path=" +++) <$> cookiePath sc,+ if cookieSecure sc then Just "Secure" else Nothing,+ if cookieHttpOnly sc then Just "HttpOnly" else Nothing+ ] putAll :: ( PipeClass p, MonadTrans (p BS.ByteString ()),
src/Network/TigHTTP/Server.hs view
@@ -86,6 +86,7 @@ responseETag = Nothing, responseAcceptRanges = Nothing, responseConnection = Nothing,+ responseSetCookie = [], responseOthers = [], responseBody = fromList $ LBS.toChunks cnt }
src/Network/TigHTTP/Types.hs view
@@ -14,6 +14,8 @@ Accept(..), AcceptEncoding(..), AcceptLanguage(..), Host(..), -- ** Response Header+ SetCookie(..), setCookie,+ -- ** Entity Header ContentLength(..), ContentType(..), Type(..), Subtype(..),
tighttp.cabal view
@@ -2,7 +2,7 @@ cabal-version: >= 1.8 name: tighttp-version: 0.0.0.8+version: 0.0.0.9 stability: Experimental author: Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer: Yoshikuni Jujo <PAF01143@nifty.ne.jp>@@ -110,7 +110,7 @@ Network.TigHTTP.Types other-modules: Network.TigHTTP.HttpTypes, Network.TigHTTP.Papillon,- Network.TigHTTP.Token+ Network.TigHTTP.Token, Network.TigHTTP.CookieTime build-depends: base == 4.*, bytestring == 0.10.*, handle-like == 0.1.*, old-locale == 1.0.*, time == 1.4.*, monads-tf == 0.1.*,