diff --git a/Network/HTTP/Conduit.hs b/Network/HTTP/Conduit.hs --- a/Network/HTTP/Conduit.hs +++ b/Network/HTTP/Conduit.hs @@ -47,6 +47,8 @@ -- > -- > main = withSocketsDo -- > $ simpleHttp "http://www.haskell.org/" >>= L.putStr +-- > +-- > Cookies are implemented according to RFC 6265. module Network.HTTP.Conduit ( -- * Perform a request simpleHttp @@ -84,6 +86,16 @@ , managerCheckCerts -- *** Defaults , defaultCheckCerts + -- * Cookies + , Cookie(..) + , CookieJar + , createCookieJar + , destroyCookieJar + , updateCookieJar + , receiveSetCookie + , insertCookiesIntoRequest + , computeCookieString + , evictExpiredCookies -- * Utility functions , parseUrl , applyBasicAuth @@ -118,10 +130,13 @@ import Control.Monad.Trans.Resource (ResourceT, ResourceIO) import Control.Exception.Lifted (try, SomeException) +import Data.Time.Clock + import Network.HTTP.Conduit.Request import Network.HTTP.Conduit.Response import Network.HTTP.Conduit.Manager import Network.HTTP.Conduit.ConnInfo +import Network.HTTP.Conduit.Cookies -- | The most low-level function for initiating an HTTP request. -- @@ -151,18 +166,21 @@ res@(Response status hs body) <- if redirectCount req0 == 0 then httpRaw req0 manager - else go (redirectCount req0) req0 + else go (redirectCount req0) req0 def case checkStatus req0 status hs of Nothing -> return res Just exc -> do C.sourceClose body liftBase $ throwIO exc where - go 0 _ = liftBase $ throwIO TooManyRedirects - go count req = do - res <- httpRaw req manager - case getRedirectedRequest req (responseHeaders res) (W.statusCode (statusCode res)) of - Just req' -> go (count - 1) req' + go 0 _ _ = liftBase $ throwIO TooManyRedirects + go count req'' cookie_jar'' = do + now <- liftIO $ getCurrentTime + let (req', cookie_jar') = insertCookiesIntoRequest req'' (evictExpiredCookies cookie_jar'' now) now + res' <- httpRaw req' manager + let (cookie_jar, res) = updateCookieJar res' req' now cookie_jar' + case getRedirectedRequest req' (responseHeaders res) (W.statusCode (statusCode res)) of + Just req -> go (count - 1) req cookie_jar Nothing -> return res -- | Get a 'Response' without any redirect following. diff --git a/Network/HTTP/Conduit/ConnInfo.hs b/Network/HTTP/Conduit/ConnInfo.hs --- a/Network/HTTP/Conduit/ConnInfo.hs +++ b/Network/HTTP/Conduit/ConnInfo.hs @@ -21,6 +21,7 @@ import Control.Exception (SomeException, throwIO, try) import System.IO (Handle, hClose) +import Control.Monad (unless) import Control.Monad.Base (MonadBase, liftBase) @@ -34,6 +35,8 @@ import qualified Network.Socket as NS import Network.Socks5 (socksConnectWith, SocksConf) +import Network.HTTP.Conduit.Request (HttpException (HandshakeFailed)) + import Network.TLS import Network.TLS.Extra (ciphersuite_all) @@ -129,13 +132,14 @@ #endif let tcp = defaultParams { pConnectVersion = TLS10 - , pAllowedVersions = [ TLS10, TLS11 ] + , pAllowedVersions = [ TLS10, TLS11, TLS12 ] , pCiphers = ciphersuite_all , onCertificatesRecv = onCerts } gen <- makeSystem istate <- client tcp gen h - _ <- handshake istate + handshakeRes <- handshake istate + unless handshakeRes $ throwIO HandshakeFailed return ConnInfo { connRead = recvD istate , connWrite = sendData istate . L.fromChunks . (:[]) diff --git a/Network/HTTP/Conduit/Cookies.hs b/Network/HTTP/Conduit/Cookies.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Conduit/Cookies.hs @@ -0,0 +1,14 @@ +-- | This module implements the algorithms described in RFC 6265 for the Network.HTTP.Conduit library. +module Network.HTTP.Conduit.Cookies + ( Cookie(..) + , CookieJar + , createCookieJar + , destroyCookieJar + , updateCookieJar + , receiveSetCookie + , insertCookiesIntoRequest + , computeCookieString + , evictExpiredCookies + ) where + +import Network.HTTP.Conduit.Cookies.Internal diff --git a/Network/HTTP/Conduit/Cookies/Internal.hs b/Network/HTTP/Conduit/Cookies/Internal.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Conduit/Cookies/Internal.hs @@ -0,0 +1,247 @@ +-- | This module implements the algorithms described in RFC 6265 for the Network.HTTP.Conduit library. +module Network.HTTP.Conduit.Cookies.Internal where + +import qualified Network.HTTP.Types as W +import qualified Data.ByteString as BS +import qualified Data.ByteString.UTF8 as U +import Text.Regex +import Data.Maybe +import qualified Data.List as L +import Data.Time.Clock +import Data.Time.Calendar +import Web.Cookie +import qualified Data.CaseInsensitive as CI +import Blaze.ByteString.Builder +import Data.Default + +import qualified Network.HTTP.Conduit.Request as Req +import qualified Network.HTTP.Conduit.Response as Res + +slash :: Integral a => a +slash = 47 -- '/' + +isIpAddress :: W.Ascii -> Bool +isIpAddress a = case strs of + Just strs' -> helper strs' + Nothing -> False + where s = U.toString a + regex = mkRegex "^([0-9]{1,3})\\.([0-9]{1,3})\\.([0-9]{1,3})\\.([0-9]{1,3})$" + strs = matchRegex regex s + helper l = length l == 4 && all helper2 l + helper2 v = (read v :: Int) >= 0 && (read v :: Int) < 256 + +-- | This corresponds to the subcomponent algorithm entitled \"Domain Matching\" detailed +-- in section 5.1.3 +domainMatches :: W.Ascii -> W.Ascii -> Bool +domainMatches string domainString + | string == domainString = True + | BS.length string < BS.length domainString + 1 = False + | domainString `BS.isSuffixOf` string && BS.singleton (BS.last difference) == U.fromString "." && not (isIpAddress string) = True + | otherwise = False + where difference = BS.take (BS.length string - BS.length domainString) string + +-- | This corresponds to the subcomponent algorithm entitled \"Paths\" detailed +-- in section 5.1.4 +defaultPath :: Req.Request m -> W.Ascii +defaultPath req + | BS.null uri_path = U.fromString "/" + | BS.singleton (BS.head uri_path) /= U.fromString "/" = U.fromString "/" + | BS.count slash uri_path <= 1 = U.fromString "/" + | otherwise = BS.reverse $ BS.tail $ BS.dropWhile (/= slash) $ BS.reverse uri_path + where uri_path = Req.path req + +-- | This corresponds to the subcomponent algorithm entitled \"Path-Match\" detailed +-- in section 5.1.4 +pathMatches :: W.Ascii -> W.Ascii -> Bool +pathMatches requestPath cookiePath + | cookiePath == requestPath = True + | cookiePath `BS.isPrefixOf` requestPath && BS.singleton (BS.last cookiePath) == U.fromString "/" = True + | cookiePath `BS.isPrefixOf` requestPath && BS.singleton (BS.head remainder) == U.fromString "/" = True + | otherwise = False + where remainder = BS.drop (BS.length cookiePath) requestPath + +-- This corresponds to the description of a cookie detailed in Section 5.3 \"Storage Model\" +data Cookie = Cookie + { cookie_name :: W.Ascii + , cookie_value :: W.Ascii + , cookie_expiry_time :: UTCTime + , cookie_domain :: W.Ascii + , cookie_path :: W.Ascii + , cookie_creation_time :: UTCTime + , cookie_last_access_time :: UTCTime + , cookie_persistent :: Bool + , cookie_host_only :: Bool + , cookie_secure_only :: Bool + , cookie_http_only :: Bool + } + deriving (Show) +-- This corresponds to step 11 of the algorithm described in Section 5.3 \"Storage Model\" +instance Eq Cookie where + (==) a b = name_matches && domain_matches && path_matches + where name_matches = cookie_name a == cookie_name b + domain_matches = cookie_domain a == cookie_domain b + path_matches = cookie_path a == cookie_path b +instance Ord Cookie where + compare c1 c2 + | BS.length (cookie_path c1) > BS.length (cookie_path c2) = LT + | BS.length (cookie_path c1) < BS.length (cookie_path c2) = GT + | cookie_creation_time c1 > cookie_creation_time c2 = GT + | otherwise = LT + +newtype CookieJar = CJ { expose :: [Cookie] } + +-- | empty cookie jar +instance Default CookieJar where + def = CJ [] + +instance Eq CookieJar where + (==) cj1 cj2 = (L.sort $ expose cj1) == (L.sort $ expose cj2) + +instance Show CookieJar where + show = show . expose + +createCookieJar :: [Cookie] -> CookieJar +createCookieJar = CJ + +destroyCookieJar :: CookieJar -> [Cookie] +destroyCookieJar = expose + +insertIntoCookieJar :: Cookie -> CookieJar -> CookieJar +insertIntoCookieJar cookie cookie_jar' = CJ $ cookie : cookie_jar + where cookie_jar = expose cookie_jar' + +removeExistingCookieFromCookieJar :: Cookie -> CookieJar -> (Maybe Cookie, CookieJar) +removeExistingCookieFromCookieJar cookie cookie_jar' = (mc, CJ lc) + where (mc, lc) = removeExistingCookieFromCookieJarHelper cookie (expose cookie_jar') + removeExistingCookieFromCookieJarHelper _ [] = (Nothing, []) + removeExistingCookieFromCookieJarHelper c (c' : cs) + | c == c' = (Just c', cs) + | otherwise = (cookie', c' : cookie_jar'') + where (cookie', cookie_jar'') = removeExistingCookieFromCookieJarHelper c cs + +-- | Are we configured to reject cookies for domains such as \"com\"? +rejectPublicSuffixes :: Bool +rejectPublicSuffixes = True + +isPublicSuffix :: W.Ascii -> Bool +isPublicSuffix _ = False + +-- | This corresponds to the eviction algorithm described in Section 5.3 \"Storage Model\" +evictExpiredCookies :: CookieJar -- ^ Input cookie jar + -> UTCTime -- ^ Value that should be used as \"now\" + -> CookieJar -- ^ Filtered cookie jar +evictExpiredCookies cookie_jar' now = CJ $ filter (\ cookie -> cookie_expiry_time cookie >= now) $ expose cookie_jar' + +-- | This applies the 'computeCookieString' to a given Request +insertCookiesIntoRequest :: Req.Request m -- ^ The request to insert into + -> CookieJar -- ^ Current cookie jar + -> UTCTime -- ^ Value that should be used as \"now\" + -> (Req.Request m, CookieJar) -- ^ (Ouptut request, Updated cookie jar (last-access-time is updated)) +insertCookiesIntoRequest request cookie_jar now = (request {Req.requestHeaders = cookie_header : purgedHeaders}, cookie_jar') + where purgedHeaders = L.deleteBy (\ (a, _) (b, _) -> a == b) (CI.mk $ U.fromString "Cookie", BS.empty) $ Req.requestHeaders request + (cookie_string, cookie_jar') = computeCookieString request cookie_jar now True + cookie_header = (CI.mk $ U.fromString "Cookie", cookie_string) + +-- | This corresponds to the algorithm described in Section 5.4 \"The Cookie Header\" +computeCookieString :: Req.Request m -- ^ Input request + -> CookieJar -- ^ Current cookie jar + -> UTCTime -- ^ Value that should be used as \"now\" + -> Bool -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that) + -> (W.Ascii, CookieJar) -- ^ (Contents of a \"Cookie\" header, Updated cookie jar (last-access-time is updated)) +computeCookieString request cookie_jar now is_http_api = (output_line, cookie_jar') + where matching_cookie cookie = condition1 && condition2 && condition3 && condition4 + where condition1 + | cookie_host_only cookie = Req.host request == cookie_domain cookie + | otherwise = domainMatches (Req.host request) (cookie_domain cookie) + condition2 = pathMatches (Req.path request) (cookie_path cookie) + condition3 + | not (cookie_secure_only cookie) = True + | otherwise = Req.secure request + condition4 + | not (cookie_http_only cookie) = True + | otherwise = is_http_api + matching_cookies = filter matching_cookie $ expose cookie_jar + output_cookies = map (\ c -> (cookie_name c, cookie_value c)) $ L.sort matching_cookies + output_line = toByteString $ renderCookies $ output_cookies + folding_function cookie_jar'' cookie = case removeExistingCookieFromCookieJar cookie cookie_jar'' of + (Just c, cookie_jar''') -> insertIntoCookieJar (c {cookie_last_access_time = now}) cookie_jar''' + (Nothing, cookie_jar''') -> cookie_jar''' + cookie_jar' = foldl folding_function cookie_jar matching_cookies + +-- | This applies 'receiveSetCookie' to a given Response +updateCookieJar :: Res.Response a -- ^ Response received from server + -> Req.Request m -- ^ Request which generated the response + -> UTCTime -- ^ Value that should be used as \"now\" + -> CookieJar -- ^ Current cookie jar + -> (CookieJar, Res.Response a) -- ^ (Updated cookie jar with cookies from the Response, The response stripped of any \"Set-Cookie\" header) +updateCookieJar response request now cookie_jar = (cookie_jar', response {Res.responseHeaders = other_headers}) + where (set_cookie_headers, other_headers) = L.partition ((== (CI.mk $ U.fromString "Set-Cookie")) . fst) $ Res.responseHeaders response + set_cookie_data = map snd set_cookie_headers + set_cookies = map parseSetCookie set_cookie_data + cookie_jar' = foldl (\ cj sc -> receiveSetCookie sc request now True cj) cookie_jar set_cookies + +-- | This corresponds to the algorithm described in Section 5.3 \"Storage Model\" +receiveSetCookie :: SetCookie -- ^ The 'SetCookie' the cookie jar is receiving + -> Req.Request m -- ^ The request that originated the response that yielded the 'SetCookie' + -> UTCTime -- ^ Value that should be used as \"now\" + -> Bool -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that) + -> CookieJar -- ^ Input cookie jar to modify + -> CookieJar -- ^ Updated cookie jar +receiveSetCookie set_cookie request now is_http_api cookie_jar = case result of + Nothing -> cookie_jar + Just cookie_jar' -> cookie_jar' + where result :: Maybe CookieJar + result = do + cookie <- generateCookie + (cookie_jar', cookie') <- existanceTest cookie cookie_jar + return $ insertIntoCookieJar cookie' cookie_jar' + generateCookie :: Maybe Cookie + generateCookie = do + domain_sanitized <- sanitizeDomain $ step4 (setCookieDomain set_cookie) + domain_intermediate <- step5 domain_sanitized + (domain_final, host_only') <- step6 domain_intermediate + http_only' <- step10 + return $ Cookie { cookie_name = setCookieName set_cookie + , cookie_value = setCookieValue set_cookie + , cookie_expiry_time = getExpiryTime (setCookieExpires set_cookie) (setCookieMaxAge set_cookie) + , cookie_domain = domain_final + , cookie_path = getPath $ setCookiePath set_cookie + , cookie_creation_time = now + , cookie_last_access_time = now + , cookie_persistent = getPersistent + , cookie_host_only = host_only' + , cookie_secure_only = setCookieSecure set_cookie + , cookie_http_only = http_only' + } + sanitizeDomain domain' + | has_a_character && BS.singleton (BS.last domain') == U.fromString "." = Nothing + | has_a_character && BS.singleton (BS.head domain') == U.fromString "." = Just $ BS.tail domain' + | otherwise = Just $ domain' + where has_a_character = not (BS.null domain') + step4 (Just set_cookie_domain) = set_cookie_domain + step4 Nothing = BS.empty + step5 domain' + | firstCondition && domain' == (Req.host request) = return BS.empty + | firstCondition = Nothing + | otherwise = return domain' + where firstCondition = rejectPublicSuffixes && isPublicSuffix domain' + step6 domain' + | firstCondition && not (domainMatches (Req.host request) domain') = Nothing + | firstCondition = return (domain', False) + | otherwise = return (Req.host request, True) + where firstCondition = not $ BS.null domain' + step10 + | not is_http_api && setCookieHttpOnly set_cookie = Nothing + | otherwise = return $ setCookieHttpOnly set_cookie + getExpiryTime :: Maybe UTCTime -> Maybe DiffTime -> UTCTime + getExpiryTime _ (Just t) = (fromRational $ toRational t) `addUTCTime` now + getExpiryTime (Just t) Nothing = t + getExpiryTime Nothing Nothing= UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0) + getPath (Just p) = p + getPath Nothing = defaultPath request + getPersistent = isJust (setCookieExpires set_cookie) || isJust (setCookieMaxAge set_cookie) + existanceTest cookie cookie_jar' = existanceTestHelper cookie $ removeExistingCookieFromCookieJar cookie cookie_jar' + existanceTestHelper new_cookie (Just old_cookie, cookie_jar') + | not is_http_api && cookie_http_only old_cookie = Nothing + | otherwise = return (cookie_jar', new_cookie {cookie_creation_time = cookie_creation_time old_cookie}) + existanceTestHelper new_cookie (Nothing, cookie_jar') = return (cookie_jar', new_cookie) diff --git a/Network/HTTP/Conduit/Request.hs b/Network/HTTP/Conduit/Request.hs --- a/Network/HTTP/Conduit/Request.hs +++ b/Network/HTTP/Conduit/Request.hs @@ -215,6 +215,7 @@ | InvalidUrlException String String | TooManyRedirects | HttpParserException String + | HandshakeFailed deriving (Show, Typeable) instance Exception HttpException diff --git a/http-conduit.cabal b/http-conduit.cabal --- a/http-conduit.cabal +++ b/http-conduit.cabal @@ -1,5 +1,5 @@ name: http-conduit -version: 1.2.3 +version: 1.2.4 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -45,6 +45,8 @@ , lifted-base >= 0.1 && < 0.2 , socks >= 0.4 && < 0.5 , time + , cookie >= 0.4 && < 0.5 + , regex-compat if flag(network-bytestring) build-depends: network >= 2.2.1 && < 2.2.3 , network-bytestring >= 0.1.3 && < 0.1.4 @@ -58,11 +60,14 @@ Network.HTTP.Conduit.Manager Network.HTTP.Conduit.Chunk Network.HTTP.Conduit.Response + Network.HTTP.Conduit.Cookies + Network.HTTP.Conduit.Cookies.Internal ghc-options: -Wall test-suite test main-is: test/main.hs type: exitcode-stdio-1.0 + hs-source-dirs: ., test ghc-options: -Wall cpp-options: -DDEBUG @@ -99,6 +104,8 @@ , warp , socks , http-types + , cookie + , regex-compat source-repository head type: git diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -10,6 +10,7 @@ import Network.HTTP.Types import Control.Exception (try, SomeException) import Network.HTTP.Conduit.ConnInfo +import CookieTest (cookieTest) app :: Application app req = @@ -19,6 +20,7 @@ main :: IO () main = hspecX $ do + cookieTest describe "simpleHttp" $ do it "gets homepage" $ do tid <- forkIO $ run 3000 app