diff --git a/examples/get.hs b/examples/get.hs --- a/examples/get.hs +++ b/examples/get.hs @@ -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 () diff --git a/src/Network/TigHTTP/Client.hs b/src/Network/TigHTTP/Client.hs --- a/src/Network/TigHTTP/Client.hs +++ b/src/Network/TigHTTP/Client.hs @@ -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 } diff --git a/src/Network/TigHTTP/CookieTime.hs b/src/Network/TigHTTP/CookieTime.hs new file mode 100644 --- /dev/null +++ b/src/Network/TigHTTP/CookieTime.hs @@ -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 diff --git a/src/Network/TigHTTP/HttpTypes.hs b/src/Network/TigHTTP/HttpTypes.hs --- a/src/Network/TigHTTP/HttpTypes.hs +++ b/src/Network/TigHTTP/HttpTypes.hs @@ -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 ()), diff --git a/src/Network/TigHTTP/Server.hs b/src/Network/TigHTTP/Server.hs --- a/src/Network/TigHTTP/Server.hs +++ b/src/Network/TigHTTP/Server.hs @@ -86,6 +86,7 @@ responseETag = Nothing, responseAcceptRanges = Nothing, responseConnection = Nothing, + responseSetCookie = [], responseOthers = [], responseBody = fromList $ LBS.toChunks cnt } diff --git a/src/Network/TigHTTP/Types.hs b/src/Network/TigHTTP/Types.hs --- a/src/Network/TigHTTP/Types.hs +++ b/src/Network/TigHTTP/Types.hs @@ -14,6 +14,8 @@ Accept(..), AcceptEncoding(..), AcceptLanguage(..), Host(..), -- ** Response Header + SetCookie(..), setCookie, + -- ** Entity Header ContentLength(..), ContentType(..), Type(..), Subtype(..), diff --git a/tighttp.cabal b/tighttp.cabal --- a/tighttp.cabal +++ b/tighttp.cabal @@ -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 maintainer: Yoshikuni Jujo @@ -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.*,