http-conduit-1.9.5.2/0000755000000000000000000000000012243461040012472 5ustar0000000000000000http-conduit-1.9.5.2/LICENSE0000644000000000000000000000253012243461040013477 0ustar0000000000000000The following license covers this documentation, and the source code, except where otherwise indicated. Copyright 2010, Michael Snoyman. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. http-conduit-1.9.5.2/multipart-example.bin0000644000000000000000000001025312243461040016637 0ustar0000000000000000-----------------------------190723902820679116301912680260 Content-Disposition: form-data; name="email" -----------------------------190723902820679116301912680260 Content-Disposition: form-data; name="parent_id" 70488 -----------------------------190723902820679116301912680260 Content-Disposition: form-data; name="captcha" -----------------------------190723902820679116301912680260 Content-Disposition: form-data; name="homeboard" 0chan.hk -----------------------------190723902820679116301912680260 Content-Disposition: form-data; name="text" >>72127 Мы работаем над этим. -----------------------------190723902820679116301912680260 Content-Disposition: form-data; name="upload"; filename="nyan.gif" Content-Type: image/gif GIF89a5̙33f3!  ! NETSCAPE2.0,4Ig֊`ef(#l D:07!c`2t:U5Xz,sFzن0q80@jr:Ntz=vi~z bvuz~yrN: J 1¶ JvǮ<1Icڅ1 7;" /-haG%ʐo9 Α(qŋ>\(# !  ,5p)R̺`aZi #l̘tD:0x%7!c`2tJU5Xzlm-F`^S`88Xs:N{wfv|mlJw|{ ks:1XLVv wtwѭO <ɐ(ѡŋ <\81 G !  ,59R'$chj 麌 t-3 i2pHprPJ}fl HM3@.[%+yN^0|rvuxCT|n&{ vP|'xCH&]R ){8ƸD| ʭEz ' O8@]* Z٠k{ Qa?ӏ#jpbBG?6!  ,5)R'Ŝh`钌 t-3i1aH,g8MolFBb8- maintainer: Michael Snoyman synopsis: HTTP client package with conduit interface and HTTPS support. description: This package uses conduit for parsing the actual contents of the HTTP connection. It also provides higher-level functions which allow you to avoid directly dealing with streaming data. See for more information. . The @Network.HTTP.Conduit.Browser@ module has been moved to category: Web, Conduit stability: Stable cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/book/http-conduit extra-source-files: test/main.hs , test/CookieTest.hs , multipart-example.bin , nyan.gif flag network-bytestring default: False flag tls_1_1_3 default: True library build-depends: base >= 4 && < 5 , bytestring >= 0.9.1.4 , transformers >= 0.2 , failure >= 0.1 , resourcet >= 0.3 && < 0.5 , conduit >= 0.5.5 && < 1.1 , zlib-conduit >= 0.5 && < 1.1 , blaze-builder-conduit >= 0.5 , utf8-string >= 0.3.4 , blaze-builder >= 0.2.1 , http-types >= 0.7 , mime-types >= 0.1 , cprng-aes >= 0.3 , tls >= 1.1.0 , tls-extra >= 0.5.0 , monad-control >= 0.3 , containers >= 0.2 , certificate >= 1.3 , case-insensitive >= 0.2 , base64-bytestring >= 0.1 , asn1-data >= 0.5.1 , data-default , text , transformers-base >= 0.4 , lifted-base >= 0.1 , socks >= 0.4 , time , cookie >= 0.4 , void >= 0.5.5 , regex-compat , mtl , deepseq , publicsuffixlist >= 0.0.3 && < 1.0 , array >= 0.3 , random , filepath if flag(network-bytestring) build-depends: network >= 2.2.1 && < 2.2.3 , network-bytestring >= 0.1.3 && < 0.1.4 else build-depends: network >= 2.3 if flag(tls_1_1_3) build-depends: tls >= 1.1.3 , cprng-aes >= 0.5.0 else build-depends: tls < 1.1.3 , cprng-aes < 0.5.0 exposed-modules: Network.HTTP.Conduit Network.HTTP.Conduit.Internal Network.HTTP.Conduit.MultipartFormData other-modules: Network.HTTP.Conduit.Parser Network.HTTP.Conduit.ConnInfo Network.HTTP.Conduit.Request Network.HTTP.Conduit.Util Network.HTTP.Conduit.Manager Network.HTTP.Conduit.Chunk Network.HTTP.Conduit.Response Network.HTTP.Conduit.Cookies Network.HTTP.Conduit.Types 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 build-depends: base >= 4 && < 5 , HUnit , hspec >= 1.3 , bytestring , transformers , failure , conduit , zlib-conduit , blaze-builder-conduit , utf8-string , blaze-builder , http-types , cprng-aes , tls , tls-extra , monad-control , containers , certificate , case-insensitive , base64-bytestring , asn1-data , data-default , text , transformers-base , lifted-base , time , network , wai , warp >= 1.3.6 , socks , http-types , cookie , regex-compat , network-conduit >= 0.6 , resourcet , void , deepseq , mtl , publicsuffixlist , array , random , filepath , mime-types source-repository head type: git location: git://github.com/snoyberg/http-conduit.git http-conduit-1.9.5.2/Setup.lhs0000644000000000000000000000021712243461040014302 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > import System.Cmd (system) > main :: IO () > main = defaultMain http-conduit-1.9.5.2/nyan.gif0000755000000000000000000000653612243461040014143 0ustar0000000000000000GIF89a5̙33f3!  ! NETSCAPE2.0,4Ig֊`ef(#l D:07!c`2t:U5Xz,sFzن0q80@jr:Ntz=vi~z bvuz~yrN: J 1¶ JvǮ<1Icڅ1 7;" /-haG%ʐo9 Α(qŋ>\(# !  ,5p)R̺`aZi #l̘tD:0x%7!c`2tJU5Xzlm-F`^S`88Xs:N{wfv|mlJw|{ ks:1XLVv wtwѭO <ɐ(ѡŋ <\81 G !  ,59R'$chj 麌 t-3 i2pHprPJ}fl HM3@.[%+yN^0|rvuxCT|n&{ vP|'xCH&]R ){8ƸD| ʭEz ' O8@]* Z٠k{ Qa?ӏ#jpbBG?6!  ,5)R'Ŝh`钌 t-3i1aH,g8MolFBb8- if maybe False ("example.com:" `S.isPrefixOf`) $ lookup "host" $ Wai.requestHeaders req then return $ responseLBS status200 [] "homepage for example.com" else return $ responseLBS status200 [] "homepage" ["cookies"] -> return $ responseLBS status200 [tastyCookie] "cookies" ["cookie_redir1"] -> return $ responseLBS status303 [tastyCookie, (hLocation, "/checkcookie")] "" ["checkcookie"] -> return $ case lookup hCookie $ Wai.requestHeaders req of Just "flavor=chocolate-chip" -> responseLBS status200 [] "nom-nom-nom" _ -> responseLBS status412 [] "Baaaw where's my chocolate?" ["infredir", i'] -> let i = read $ T.unpack i' :: Int in return $ responseLBS status303 [(hLocation, S.append "/infredir/" $ S8.pack $ show $ i+1)] (L8.pack $ show i) ["dump_cookies"] -> return $ responseLBS status200 [] $ L.fromChunks $ return $ maybe "" id $ lookup hCookie $ Wai.requestHeaders req ["delayed"] -> return $ ResponseSource status200 [("foo", "bar")] $ do yield Flush liftIO $ threadDelay 30000000 yield $ Chunk $ fromByteString "Hello World!" _ -> return $ responseLBS status404 [] "not found" where tastyCookie = (mk (fromString "Set-Cookie"), fromString "flavor=chocolate-chip;") nextPort :: I.IORef Int nextPort = unsafePerformIO $ I.newIORef 15452 getPort :: IO Int getPort = do port <- I.atomicModifyIORef nextPort $ \p -> (p + 1, p) esocket <- try $ bindPort port HostIPv4 case esocket of Left (_ :: IOException) -> getPort Right socket -> do sClose socket return port withApp :: Application -> (Int -> IO ()) -> IO () withApp app' f = withApp' (const app') f withApp' :: (Int -> Application) -> (Int -> IO ()) -> IO () withApp' app' f = do port <- getPort baton <- newEmptyMVar bracket (forkIO $ runSettings defaultSettings { settingsPort = port , settingsBeforeMainLoop = putMVar baton () } (app' port) `onException` putMVar baton ()) killThread (const $ takeMVar baton >> f port) main :: IO () main = withSocketsDo $ do mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr] hspec $ do cookieTest describe "simpleHttp" $ do it "gets homepage" $ withApp app $ \port -> do lbs <- simpleHttp $ "http://127.0.0.1:" ++ show port lbs @?= "homepage" it "throws exception on 404" $ withApp app $ \port -> do elbs <- try $ simpleHttp $ concat ["http://127.0.0.1:", show port, "/404"] case elbs of Left (_ :: SomeException) -> return () Right _ -> error "Expected an exception" describe "httpLbs" $ do it "preserves 'set-cookie' headers" $ withApp app $ \port -> do request <- parseUrl $ concat ["http://127.0.0.1:", show port, "/cookies"] withManager $ \manager -> do response <- httpLbs request manager let setCookie = mk (fromString "Set-Cookie") (setCookieHeaders, _) = partition ((== setCookie) . fst) (responseHeaders response) liftIO $ assertBool "response contains a 'set-cookie' header" $ length setCookieHeaders > 0 it "redirects set cookies" $ withApp app $ \port -> do request <- parseUrl $ concat ["http://127.0.0.1:", show port, "/cookie_redir1"] withManager $ \manager -> do response <- httpLbs request manager liftIO $ (responseBody response) @?= "nom-nom-nom" it "user-defined cookie jar works" $ withApp app $ \port -> do request <- parseUrl $ concat ["http://127.0.0.1:", show port, "/dump_cookies"] withManager $ \manager -> do response <- httpLbs (request {redirectCount = 1, cookieJar = Just cookie_jar}) manager liftIO $ (responseBody response) @?= "key=value" it "user-defined cookie jar is not ignored when redirection is disabled" $ withApp app $ \port -> do request <- parseUrl $ concat ["http://127.0.0.1:", show port, "/dump_cookies"] withManager $ \manager -> do response <- httpLbs (request {redirectCount = 0, cookieJar = Just cookie_jar}) manager liftIO $ (responseBody response) @?= "key=value" it "cookie jar is available in response" $ withApp app $ \port -> do request <- parseUrl $ concat ["http://127.0.0.1:", show port, "/cookies"] withManager $ \manager -> do response <- httpLbs (request {cookieJar = Just def}) manager liftIO $ (length $ destroyCookieJar $ responseCookieJar response) @?= 1 it "Cookie header isn't touched when no cookie jar supplied" $ withApp app $ \port -> do request <- parseUrl $ concat ["http://127.0.0.1:", show port, "/dump_cookies"] withManager $ \manager -> do let request_headers = (mk "Cookie", "key2=value2") : filter ((/= mk "Cookie") . fst) (NHC.requestHeaders request) response <- httpLbs (request {NHC.requestHeaders = request_headers, cookieJar = Nothing}) manager liftIO $ (responseBody response) @?= "key2=value2" it "Response cookie jar is nothing when request cookie jar is nothing" $ withApp app $ \port -> do request <- parseUrl $ concat ["http://127.0.0.1:", show port, "/cookies"] withManager $ \manager -> do response <- httpLbs (request {cookieJar = Nothing}) manager liftIO $ (responseCookieJar response) @?= def describe "manager" $ do it "closes all connections" $ withApp app $ \port1 -> withApp app $ \port2 -> do clearSocketsList withManager $ \manager -> do let Just req1 = parseUrl $ "http://127.0.0.1:" ++ show port1 let Just req2 = parseUrl $ "http://127.0.0.1:" ++ show port2 _res1a <- http req1 manager _res1b <- http req1 manager _res2 <- http req2 manager return () requireAllSocketsClosed describe "DOS protection" $ do it "overlong headers" $ overLongHeaders $ \port -> do withManager $ \manager -> do let Just req1 = parseUrl $ "http://127.0.0.1:" ++ show port res1 <- try $ http req1 manager case res1 of Left e -> liftIO $ show (e :: SomeException) @?= show OverlongHeaders _ -> error "Shouldn't have worked" it "not overlong headers" $ notOverLongHeaders $ \port -> do withManager $ \manager -> do let Just req1 = parseUrl $ "http://127.0.0.1:" ++ show port _ <- httpLbs req1 manager return () describe "redirects" $ do it "doesn't double escape" $ redir $ \port -> do withManager $ \manager -> do let go (encoded, final) = do let Just req1 = parseUrl $ concat ["http://127.0.0.1:", show port, "/redir/", encoded] res <- httpLbs req1 manager liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200 liftIO $ responseBody res @?= L.fromChunks [TE.encodeUtf8 final] mapM_ go [ ("hello world%2F", "hello world/") , ("%D7%A9%D7%9C%D7%95%D7%9D", "שלום") , ("simple", "simple") , ("hello%20world", "hello world") , ("hello%20world%3f%23", "hello world?#") ] it "TooManyRedirects: redirect request body is preserved" $ withApp app $ \port -> do let Just req = parseUrl $ concat ["http://127.0.0.1:", show port, "/infredir/0"] let go (res, i) = liftIO $ responseBody res @?= (L8.pack $ show i) E.catch (withManager $ \manager -> do void $ http req{redirectCount=5} manager) $ \(TooManyRedirects redirs) -> mapM_ go (zip redirs [5,4..0 :: Int]) describe "chunked request body" $ do it "works" $ echo $ \port -> do withManager $ \manager -> do let go bss = do let Just req1 = parseUrl $ "http://127.0.0.1:" ++ show port src = sourceList $ map fromByteString bss lbs = L.fromChunks bss res <- httpLbs req1 { method = "POST" , requestBody = RequestBodySourceChunked src } manager liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200 let ts = S.concat . L.toChunks liftIO $ ts (responseBody res) @?= ts lbs mapM_ go [ ["hello", "world"] , replicate 500 "foo\003\n\r" ] describe "no status message" $ do it "works" $ noStatusMessage $ \port -> do req <- parseUrl $ "http://127.0.0.1:" ++ show port withManager $ \manager -> do res <- httpLbs req manager liftIO $ do Network.HTTP.Conduit.responseStatus res `shouldBe` status200 responseBody res `shouldBe` "foo" describe "response body too short" $ do it "throws an exception" $ wrongLength $ \port -> do req <- parseUrl $ "http://127.0.0.1:" ++ show port withManager $ \manager -> do eres <- try $ httpLbs req manager liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres `shouldBe` Left (show $ ResponseBodyTooShort 50 18) describe "chunked response body" $ do it "no chunk terminator" $ wrongLengthChunk1 $ \port -> do req <- parseUrl $ "http://127.0.0.1:" ++ show port withManager $ \manager -> do eres <- try $ httpLbs req manager liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres `shouldBe` Left (show InvalidChunkHeaders) it "incomplete chunk" $ wrongLengthChunk2 $ \port -> do req <- parseUrl $ "http://127.0.0.1:" ++ show port withManager $ \manager -> do eres <- try $ httpLbs req manager liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres `shouldBe` Left (show InvalidChunkHeaders) it "invalid chunk" $ invalidChunk $ \port -> do req <- parseUrl $ "http://127.0.0.1:" ++ show port withManager $ \manager -> do eres <- try $ httpLbs req manager liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres `shouldBe` Left (show InvalidChunkHeaders) it "missing header" $ rawApp "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nabcd\r\n\r\n\r\n" $ \port -> do req <- parseUrl $ "http://127.0.0.1:" ++ show port withManager $ \manager -> do eres <- try $ httpLbs req manager liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres `shouldBe` Left (show InvalidChunkHeaders) it "junk header" $ rawApp "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nabcd\r\njunk\r\n\r\n" $ \port -> do req <- parseUrl $ "http://127.0.0.1:" ++ show port withManager $ \manager -> do eres <- try $ httpLbs req manager liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres `shouldBe` Left (show InvalidChunkHeaders) describe "redirect" $ do it "ignores large response bodies" $ do let app' port req = case pathInfo req of ["foo"] -> return $ responseLBS status200 [] "Hello World!" _ -> return $ ResponseSource status301 [("location", S8.pack $ "http://127.0.0.1:" ++ show port ++ "/foo")] $ forever $ yield $ Chunk $ fromByteString "hello\n" withApp' app' $ \port -> withManager $ \manager -> do req <- parseUrl $ "http://127.0.0.1:" ++ show port res <- httpLbs req manager liftIO $ do Network.HTTP.Conduit.responseStatus res `shouldBe` status200 responseBody res `shouldBe` "Hello World!" describe "multipart/form-data" $ do it "formats correctly" $ do let bd = "---------------------------190723902820679116301912680260" (RequestBodySource _ src) <- renderParts bd [partBS "email" "" ,partBS "parent_id" "70488" ,partBS "captcha" "" ,partBS "homeboard" "0chan.hk" ,partBS "text" $ TE.encodeUtf8 ">>72127\r\nМы работаем над этим." ,partFileSource "upload" "nyan.gif" ] mfd <- fmap (toByteString . mconcat) $ runResourceT $ src $$ CL.consume exam <- S.readFile "multipart-example.bin" mfd @?= exam describe "HTTP/1.0" $ do it "BaseHTTP" $ do let baseHTTP app' = do _ <- appSource app' $$ await yield "HTTP/1.0 200 OK\r\n\r\nThis is it!" $$ appSink app' withCApp baseHTTP $ \port -> withManager $ \manager -> do req <- parseUrl $ "http://127.0.0.1:" ++ show port res1 <- httpLbs req manager res2 <- httpLbs req manager liftIO $ res1 @?= res2 describe "hostAddress" $ do it "overrides host" $ withApp app $ \port -> do entry <- Network.BSD.getHostByName "127.0.0.1" req' <- parseUrl $ "http://example.com:" ++ show port let req = req' { hostAddress = Just $ Network.BSD.hostAddress entry } res <- withManager $ httpLbs req responseBody res @?= "homepage for example.com" describe "managerResponseTimeout" $ do it "works" $ withApp app $ \port -> do req1 <- parseUrl $ "http://localhost:" ++ show port let req2 = req1 { responseTimeout = Just 5000000 } withManagerSettings def { managerResponseTimeout = Just 1 } $ \man -> do eres1 <- try $ httpLbs req1 { NHC.path = "/delayed" } man case eres1 of Left (FailedConnectionException _ _) -> return () _ -> error "Did not time out" _ <- httpLbs req2 man return () describe "delayed body" $ do it "works" $ withApp app $ \port -> do req <- parseUrl $ "http://localhost:" ++ show port ++ "/delayed" withManager $ \man -> do _ <- http req man return () withCApp :: Data.Conduit.Network.Application IO -> (Int -> IO ()) -> IO () withCApp app' f = do port <- getPort baton <- newEmptyMVar let start = putMVar baton () settings :: ServerSettings IO settings = (serverSettings port HostAny :: ServerSettings IO) { serverAfterBind = const start } bracket (forkIO $ runTCPServer settings app' `onException` start) killThread (const $ takeMVar baton >> f port) overLongHeaders :: (Int -> IO ()) -> IO () overLongHeaders = withCApp $ \app' -> src $$ appSink app' where src = sourceList $ "HTTP/1.0 200 OK\r\nfoo: " : repeat "bar" notOverLongHeaders :: (Int -> IO ()) -> IO () notOverLongHeaders = withCApp $ \app' -> do appSource app' $$ CL.drop 1 src $$ appSink app' where src = sourceList $ [S.concat $ "HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\nContent-Length: 16384\r\n\r\n" : ( take 16384 $ repeat "x")] redir :: (Int -> IO ()) -> IO () redir = withApp' redirApp where redirApp port req = case pathInfo req of ["redir", foo] -> return $ responseLBS status301 [ ("Location", S8.pack (concat ["http://127.0.0.1:", show port, "/content/"]) `S.append` escape foo) ] "" ["content", foo] -> return $ responseLBS status200 [] $ L.fromChunks [TE.encodeUtf8 foo] _ -> return $ responseLBS status404 [] "" escape = S8.concatMap (S8.pack . encodeUrlChar) . TE.encodeUtf8 encodeUrlChar :: Char -> String encodeUrlChar c -- List of unreserved characters per RFC 3986 -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding | 'A' <= c && c <= 'Z' = [c] | 'a' <= c && c <= 'z' = [c] | '0' <= c && c <= '9' = [c] encodeUrlChar c@'-' = [c] encodeUrlChar c@'_' = [c] encodeUrlChar c@'.' = [c] encodeUrlChar c@'~' = [c] encodeUrlChar y = let (a, c) = fromEnum y `divMod` 16 b = a `mod` 16 showHex' x | x < 10 = toEnum $ x + (fromEnum '0') | x < 16 = toEnum $ x - 10 + (fromEnum 'A') | otherwise = error $ "Invalid argument to showHex: " ++ show x in ['%', showHex' b, showHex' c] echo :: (Int -> IO ()) -> IO () echo = withApp $ \req -> do bss <- Wai.requestBody req $$ CL.consume return $ responseLBS status200 [] $ L.fromChunks bss noStatusMessage :: (Int -> IO ()) -> IO () noStatusMessage = withCApp $ \app' -> src $$ appSink app' where src = yield "HTTP/1.0 200\r\nContent-Length: 3\r\n\r\nfoo: barbazbin" wrongLength :: (Int -> IO ()) -> IO () wrongLength = withCApp $ \app' -> do _ <- appSource app' $$ await src $$ appSink app' where src = do yield "HTTP/1.0 200 OK\r\nContent-Length: 50\r\n\r\n" yield "Not quite 50 bytes" wrongLengthChunk1 :: (Int -> IO ()) -> IO () wrongLengthChunk1 = withCApp $ \app' -> do _ <- appSource app' $$ await src $$ appSink app' where src = yield "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nWiki\r\n" wrongLengthChunk2 :: (Int -> IO ()) -> IO () wrongLengthChunk2 = withCApp $ \app' -> do _ <- appSource app' $$ await src $$ appSink app' where src = yield "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nWiki\r\n5\r\npedia\r\nE\r\nin\r\n\r\nch\r\n" invalidChunk :: (Int -> IO ()) -> IO () invalidChunk = withCApp $ \app' -> do _ <- appSource app' $$ await src $$ appSink app' where src = yield "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nabcd\r\ngarbage\r\nef\r\n0\r\n\r\n" rawApp :: S8.ByteString -> (Int -> IO ()) -> IO () rawApp bs = withCApp $ \app' -> do _ <- appSource app' $$ await src $$ appSink app' where src = yield bs http-conduit-1.9.5.2/test/CookieTest.hs0000644000000000000000000010102012243461040016050 0ustar0000000000000000module CookieTest (cookieTest) where import Prelude hiding (exp) import Test.Hspec import qualified Data.ByteString as BS import Test.HUnit hiding (path) import Network.HTTP.Conduit.Cookies import Network.HTTP.Conduit.Types import qualified Network.HTTP.Conduit as HC import Data.ByteString.UTF8 import Data.Monoid import Data.Maybe import Data.Time.Clock import Data.Time.Calendar import qualified Data.CaseInsensitive as CI import Web.Cookie default_request :: HC.Request m default_request = fromJust $ HC.parseUrl "http://www.google.com/" default_cookie :: Cookie default_cookie = Cookie { cookie_name = fromString "name" , cookie_value = fromString "value" , cookie_expiry_time = default_time , cookie_domain = fromString "www.google.com" , cookie_path = fromString "/" , cookie_creation_time = default_time , cookie_last_access_time = default_time , cookie_persistent = False , cookie_host_only = False , cookie_secure_only = False , cookie_http_only = False } default_time :: UTCTime default_time = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0) default_diff_time :: DiffTime default_diff_time = secondsToDiffTime 1209600 default_set_cookie :: SetCookie default_set_cookie = def { setCookieName = fromString "name" , setCookieValue = fromString "value" , setCookiePath = Just $ fromString "/" , setCookieExpires = Just default_time , setCookieMaxAge = Just default_diff_time , setCookieDomain = Just $ fromString "www.google.com" , setCookieHttpOnly = False , setCookieSecure = False } testValidIp :: Test testValidIp = TestCase $ assertBool "Couldn't parse valid IP address" $ isIpAddress $ fromString "1.2.3.4" testIpNumTooHigh :: Test testIpNumTooHigh = TestCase $ assertBool "One of the digits in the IP address is too large" $ not $ isIpAddress $ fromString "501.2.3.4" testTooManySegmentsInIp :: Test testTooManySegmentsInIp = TestCase $ assertBool "Too many segments in the ip address" $ not $ isIpAddress $ fromString "1.2.3.4.5" testCharsInIp :: Test testCharsInIp = TestCase $ assertBool "Chars are not allowed in IP addresses" $ not $ isIpAddress $ fromString "1.2a3.4.5" testDomainMatchesSuccess :: Test testDomainMatchesSuccess = TestCase $ assertBool "Domains should match" $ domainMatches (fromString "www.google.com") (fromString "google.com") testSameDomain :: Test testSameDomain = TestCase $ assertBool "Same domain should match" $ domainMatches domain domain where domain = fromString "www.google.com" testSiblingDomain :: Test testSiblingDomain = TestCase $ assertBool "Sibling domain should not match" $ not $ domainMatches (fromString "www.google.com") (fromString "secure.google.com") testParentDomain :: Test testParentDomain = TestCase $ assertBool "Parent domain should fail" $ not $ domainMatches (fromString "google.com") (fromString "www.google.com") testNaiveSuffixDomain :: Test testNaiveSuffixDomain = TestCase $ assertBool "Naively checking for suffix for domain matching should fail" $ not $ domainMatches (fromString "agoogle.com") (fromString "google.com") testDefaultPath :: Test testDefaultPath = TestCase $ assertEqual "Getting default path from a request" (fromString "/") (defaultPath default_request) testShortDefaultPath :: Test testShortDefaultPath = TestCase $ assertEqual "Getting default path from a short path" (fromString "/") (defaultPath $ default_request {HC.path = fromString "/search"}) testPopulatedDefaultPath :: Test testPopulatedDefaultPath = TestCase $ assertEqual "Getting default path from a request with a path" (fromString "/search") (defaultPath $ default_request {HC.path = fromString "/search/term"}) testParamsDefaultPath :: Test testParamsDefaultPath = TestCase $ assertEqual "Getting default path from a request with a path and GET params" (fromString "/search") (defaultPath $ default_request {HC.path = fromString "/search/term?var=val"}) testDefaultPathEndingInSlash :: Test testDefaultPathEndingInSlash = TestCase $ assertEqual "Getting default path that ends in a slash" (fromString "/search/term") (defaultPath $ default_request {HC.path = fromString "/search/term/"}) testSamePathsMatch :: Test testSamePathsMatch = TestCase $ assertBool "The same path should match" $ pathMatches path' path' where path' = fromString "/a/path" testPathSlashAtEnd :: Test testPathSlashAtEnd = TestCase $ assertBool "Putting the slash at the end should still match paths" $ pathMatches (fromString "/a/path/to/here") (fromString "/a/path/") testPathNoSlashAtEnd :: Test testPathNoSlashAtEnd = TestCase $ assertBool "Not putting the slash at the end should still match paths" $ pathMatches (fromString "/a/path/to/here") (fromString "/a/path") testDivergingPaths :: Test testDivergingPaths = TestCase $ assertBool "Diverging paths don't match" $ not $ pathMatches (fromString "/a/path/to/here") (fromString "/a/different/path") testCookieEqualitySuccess :: Test testCookieEqualitySuccess = TestCase $ assertEqual "The same cookies should be equal" cookie cookie where cookie = default_cookie testCookieEqualityResiliance :: Test testCookieEqualityResiliance = TestCase $ assertEqual "Cookies should still be equal if extra options are changed" (default_cookie {cookie_persistent = True}) (default_cookie {cookie_host_only = True}) testDomainChangesEquality :: Test testDomainChangesEquality = TestCase $ assertBool "Changing the domain should make cookies not equal" $ default_cookie /= (default_cookie {cookie_domain = fromString "/search"}) testRemoveCookie :: Test testRemoveCookie = TestCase $ assertEqual "Removing a cookie works" (Just default_cookie, createCookieJar []) (removeExistingCookieFromCookieJar default_cookie $ createCookieJar [default_cookie]) testRemoveNonexistantCookie :: Test testRemoveNonexistantCookie = TestCase $ assertEqual "Removing a nonexistant cookie doesn't work" (Nothing, createCookieJar [default_cookie]) (removeExistingCookieFromCookieJar (default_cookie {cookie_name = fromString "key2"}) $ createCookieJar [default_cookie]) testRemoveCorrectCookie :: Test testRemoveCorrectCookie = TestCase $ assertEqual "Removing only the correct cookie" (Just search_for, createCookieJar [red_herring]) (removeExistingCookieFromCookieJar search_for $ createCookieJar [red_herring, search_for]) where search_for = default_cookie {cookie_name = fromString "name1"} red_herring = default_cookie {cookie_name = fromString "name2"} testEvictExpiredCookies :: Test testEvictExpiredCookies = TestCase $ assertEqual "Evicting expired cookies works" (createCookieJar [a, c]) (evictExpiredCookies (createCookieJar [a, b, c, d]) middle) where a = default_cookie { cookie_name = fromString "a" , cookie_expiry_time = UTCTime (ModifiedJulianDay 3) (secondsToDiffTime 0) } b = default_cookie { cookie_name = fromString "b" , cookie_expiry_time = UTCTime (ModifiedJulianDay 1) (secondsToDiffTime 0) } c = default_cookie { cookie_name = fromString "c" , cookie_expiry_time = UTCTime (ModifiedJulianDay 3) (secondsToDiffTime 0) } d = default_cookie { cookie_name = fromString "d" , cookie_expiry_time = UTCTime (ModifiedJulianDay 1) (secondsToDiffTime 0) } middle = UTCTime (ModifiedJulianDay 2) (secondsToDiffTime 0) testEvictNoCookies :: Test testEvictNoCookies = TestCase $ assertEqual "Evicting empty cookie jar" (createCookieJar []) (evictExpiredCookies (createCookieJar []) middle) where middle = UTCTime (ModifiedJulianDay 2) (secondsToDiffTime 0) testComputeCookieStringUpdateLastAccessTime :: Test testComputeCookieStringUpdateLastAccessTime = TestCase $ assertEqual "Updates last access time upon using cookies" (fromString "name=value", out_cookie_jar) (computeCookieString request cookie_jar now True) where request = default_request cookie_jar = createCookieJar [default_cookie] now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) out_cookie_jar = createCookieJar [default_cookie {cookie_last_access_time = now}] testComputeCookieStringHostOnly :: Test testComputeCookieStringHostOnly = TestCase $ assertEqual "Host only cookies should match host exactly" (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) where request = default_request cookie_jar = createCookieJar [default_cookie {cookie_host_only = True}] testComputeCookieStringHostOnlyFilter :: Test testComputeCookieStringHostOnlyFilter = TestCase $ assertEqual "Host only cookies shouldn't match subdomain" (fromString "", cookie_jar) (computeCookieString request cookie_jar default_time True) where request = default_request {HC.host = fromString "sub1.sub2.google.com"} cookie_jar = createCookieJar [default_cookie { cookie_host_only = True , cookie_domain = fromString "sub2.google.com" } ] testComputeCookieStringDomainMatching :: Test testComputeCookieStringDomainMatching = TestCase $ assertEqual "Domain matching works for new requests" (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) where request = default_request {HC.host = fromString "sub1.sub2.google.com"} cookie_jar = createCookieJar [default_cookie {cookie_domain = fromString "sub2.google.com"}] testComputeCookieStringPathMatching :: Test testComputeCookieStringPathMatching = TestCase $ assertEqual "Path matching works for new requests" (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) where request = default_request {HC.path = fromString "/a/path/to/nowhere"} cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}] testComputeCookieStringPathMatchingFails :: Test testComputeCookieStringPathMatchingFails = TestCase $ assertEqual "Path matching fails when it should" (fromString "", cookie_jar) (computeCookieString request cookie_jar default_time True) where request = default_request {HC.path = fromString "/a/different/path/to/nowhere"} cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}] testComputeCookieStringPathMatchingWithParms :: Test testComputeCookieStringPathMatchingWithParms = TestCase $ assertEqual "Path matching succeeds when request has GET params" (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) where request = default_request {HC.path = fromString "/a/path/to/nowhere?var=val"} cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}] testComputeCookieStringSecure :: Test testComputeCookieStringSecure = TestCase $ assertEqual "Secure flag filters properly" (fromString "", cookie_jar) (computeCookieString default_request cookie_jar default_time True) where cookie_jar = createCookieJar [default_cookie {cookie_secure_only = True}] testComputeCookieStringHttpOnly :: Test testComputeCookieStringHttpOnly = TestCase $ assertEqual "http-only flag filters properly" (fromString "", cookie_jar) (computeCookieString default_request cookie_jar default_time False) where cookie_jar = createCookieJar [default_cookie {cookie_http_only = True}] testComputeCookieStringSort :: Test testComputeCookieStringSort = TestCase $ assertEqual "Sorting works correctly" (fromString "c1=v1;c3=v3;c4=v4;c2=v2", cookie_jar_out) format_output where now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 11) cookie_jar = createCookieJar [ default_cookie { cookie_name = fromString "c1" , cookie_value = fromString "v1" , cookie_path = fromString "/all/encompassing/request" } , default_cookie { cookie_name = fromString "c2" , cookie_value = fromString "v2" , cookie_path = fromString "/all" } , default_cookie { cookie_name = fromString "c3" , cookie_value = fromString "v3" , cookie_path = fromString "/all/encompassing" , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) } , default_cookie { cookie_name = fromString "c4" , cookie_value = fromString "v4" , cookie_path = fromString "/all/encompassing" , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2) } ] cookie_jar_out = createCookieJar [ default_cookie { cookie_name = fromString "c1" , cookie_value = fromString "v1" , cookie_path = fromString "/all/encompassing/request" , cookie_last_access_time = now } , default_cookie { cookie_name = fromString "c2" , cookie_value = fromString "v2" , cookie_path = fromString "/all" , cookie_last_access_time = now } , default_cookie { cookie_name = fromString "c3" , cookie_value = fromString "v3" , cookie_path = fromString "/all/encompassing" , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) , cookie_last_access_time = now } , default_cookie { cookie_name = fromString "c4" , cookie_value = fromString "v4" , cookie_path = fromString "/all/encompassing" , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2) , cookie_last_access_time = now } ] request = default_request {HC.path = fromString "/all/encompassing/request/path"} format_output = computeCookieString request cookie_jar default_time False testInsertCookiesIntoRequestWorks :: Test testInsertCookiesIntoRequestWorks = TestCase $ assertEqual "Inserting cookies works" [(CI.mk $ fromString "Cookie", fromString "key=val")] out_headers where out_headers = HC.requestHeaders req (req, _) = insertCookiesIntoRequest req' cookie_jar default_time cookie_jar = createCookieJar [ default_cookie { cookie_name = fromString "key" , cookie_value = fromString "val" } ] req' = default_request {HC.requestHeaders = [(CI.mk $ fromString "Cookie", fromString "otherkey=otherval")]} testReceiveSetCookie :: Test testReceiveSetCookie = TestCase $ assertEqual "Receiving a Set-Cookie" (createCookieJar [default_cookie]) (receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) testReceiveSetCookieTrailingDot :: Test testReceiveSetCookieTrailingDot = TestCase $ assertEqual "Receiving a Set-Cookie with a trailing domain dot" (createCookieJar []) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "www.google.com."} testReceiveSetCookieLeadingDot :: Test testReceiveSetCookieLeadingDot = TestCase $ assertEqual "Receiving a Set-Cookie with a leading domain dot" (createCookieJar [default_cookie]) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString ".www.google.com"} testReceiveSetCookieNoDomain :: Test testReceiveSetCookieNoDomain = TestCase $ assertEqual "Receiving cookie without domain" (createCookieJar [default_cookie]) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) where set_cookie = default_set_cookie {setCookieDomain = Nothing} testReceiveSetCookieEmptyDomain :: Test testReceiveSetCookieEmptyDomain = TestCase $ assertEqual "Receiving cookie with empty domain" (createCookieJar [default_cookie]) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) where set_cookie = default_set_cookie {setCookieDomain = Just BS.empty} -- Can't test public suffixes until that module is written testReceiveSetCookieNonMatchingDomain :: Test testReceiveSetCookieNonMatchingDomain = TestCase $ assertEqual "Receiving cookie with non-matching domain" (createCookieJar []) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "www.wikipedia.org"} testReceiveSetCookieHostOnly :: Test testReceiveSetCookieHostOnly = TestCase $ assertBool "Checking host-only flag gets set" $ cookie_host_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] where set_cookie = default_set_cookie {setCookieDomain = Nothing} testReceiveSetCookieHostOnlyNotSet :: Test testReceiveSetCookieHostOnlyNotSet = TestCase $ assertBool "Checking host-only flag doesn't get set" $ not $ cookie_host_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "google.com"} testReceiveSetCookieHttpOnly :: Test testReceiveSetCookieHttpOnly = TestCase $ assertBool "Checking http-only flag gets set" $ cookie_http_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] where set_cookie = default_set_cookie {setCookieHttpOnly = True} testReceiveSetCookieHttpOnlyNotSet :: Test testReceiveSetCookieHttpOnlyNotSet = TestCase $ assertBool "Checking http-only flag doesn't get set" $ not $ cookie_http_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] where set_cookie = default_set_cookie {setCookieHttpOnly = False} testReceiveSetCookieHttpOnlyDrop :: Test testReceiveSetCookieHttpOnlyDrop = TestCase $ assertEqual "Checking non http request gets dropped" (createCookieJar []) (receiveSetCookie set_cookie default_request default_time False $ createCookieJar []) where set_cookie = default_set_cookie {setCookieHttpOnly = True} testReceiveSetCookieName :: Test testReceiveSetCookieName = TestCase $ assertEqual "Name gets set correctly" (fromString "name") (cookie_name $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) testReceiveSetCookieValue :: Test testReceiveSetCookieValue = TestCase $ assertEqual "Value gets set correctly" (fromString "value") (cookie_value $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) testReceiveSetCookieExpiry :: Test testReceiveSetCookieExpiry = TestCase $ assertEqual "Expiry gets set correctly" now_plus_diff_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) where now_plus_diff_time = ((fromRational $ toRational default_diff_time) `addUTCTime` default_time) testReceiveSetCookieNoMaxAge :: Test testReceiveSetCookieNoMaxAge = TestCase $ assertEqual "Expiry is based on the given value" default_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie cookie_without_max_age default_request default_time True $ createCookieJar []) where cookie_without_max_age = default_set_cookie {setCookieMaxAge = Nothing} testReceiveSetCookieNoExpiry :: Test testReceiveSetCookieNoExpiry = TestCase $ assertEqual "Expiry is based on max age" now_plus_diff_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie cookie_without_expiry default_request default_time True $ createCookieJar []) where now_plus_diff_time = ((fromRational $ toRational default_diff_time) `addUTCTime` default_time) cookie_without_expiry = default_set_cookie {setCookieExpires = Nothing} testReceiveSetCookieNoExpiryNoMaxAge :: Test testReceiveSetCookieNoExpiryNoMaxAge = TestCase $ assertBool "Expiry is set to a future date" $ default_time < (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie basic_cookie default_request default_time True $ createCookieJar []) where basic_cookie = default_set_cookie { setCookieExpires = Nothing, setCookieMaxAge = Nothing } testReceiveSetCookiePath :: Test testReceiveSetCookiePath = TestCase $ assertEqual "Path gets set correctly" (fromString "/a/path") (cookie_path $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) where set_cookie = default_set_cookie {setCookiePath = Just $ fromString "/a/path"} testReceiveSetCookieNoPath :: Test testReceiveSetCookieNoPath = TestCase $ assertEqual "Path gets set correctly when nonexistant" (fromString "/a/path/to") (cookie_path $ head $ destroyCookieJar $ receiveSetCookie set_cookie request default_time True $ createCookieJar []) where set_cookie = default_set_cookie {setCookiePath = Nothing} request = default_request {HC.path = fromString "/a/path/to/nowhere"} testReceiveSetCookieCreationTime :: Test testReceiveSetCookieCreationTime = TestCase $ assertEqual "Creation time gets set correctly" now (cookie_creation_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar []) where now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) testReceiveSetCookieAccessTime :: Test testReceiveSetCookieAccessTime = TestCase $ assertEqual "Last access time gets set correctly" now (cookie_last_access_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar []) where now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) testReceiveSetCookiePersistent :: Test testReceiveSetCookiePersistent = TestCase $ assertBool "Persistent flag gets set correctly" $ cookie_persistent $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] where set_cookie = default_set_cookie {setCookieExpires = Just default_time} testReceiveSetCookieSecure :: Test testReceiveSetCookieSecure = TestCase $ assertBool "Secure flag gets set correctly" $ cookie_secure_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] where set_cookie = default_set_cookie {setCookieSecure = True} testReceiveSetCookieMaxAge :: Test testReceiveSetCookieMaxAge = TestCase $ assertEqual "Max-Age gets set correctly" total (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request now True $ createCookieJar []) where set_cookie = default_set_cookie { setCookieExpires = Nothing , setCookieMaxAge = Just $ secondsToDiffTime 10 } now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) total = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 22) testReceiveSetCookiePreferMaxAge :: Test testReceiveSetCookiePreferMaxAge = TestCase $ assertEqual "Max-Age is preferred over Expires" total (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request now True $ createCookieJar []) where set_cookie = default_set_cookie { setCookieExpires = Just exp , setCookieMaxAge = Just $ secondsToDiffTime 10 } exp = UTCTime (ModifiedJulianDay 11) (secondsToDiffTime 5) now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) total = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 22) testReceiveSetCookieExisting :: Test testReceiveSetCookieExisting = TestCase $ assertEqual "Existing cookie gets updated" t (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [default_cookie]) where set_cookie = default_set_cookie { setCookieExpires = Just t , setCookieMaxAge = Nothing } t = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) testReceiveSetCookieExistingCreation :: Test testReceiveSetCookieExistingCreation = TestCase $ assertEqual "Creation time gets updated in existing cookie" default_time (cookie_creation_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar [default_cookie]) where now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) testReceiveSetCookieExistingHttpOnly :: Test testReceiveSetCookieExistingHttpOnly = TestCase $ assertEqual "Existing http-only cookie gets dropped" default_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time False $ createCookieJar [existing_cookie]) where existing_cookie = default_cookie {cookie_http_only = True} testMonoidPreferRecent :: Test testMonoidPreferRecent = TestCase $ assertEqual "Monoid prefers more recent cookies" (cct $ createCookieJar [c2]) (cct $ createCookieJar [c1] `mappend` createCookieJar [c2]) where c1 = default_cookie {cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1)} c2 = default_cookie {cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2)} cct cj = cookie_creation_time $ head $ destroyCookieJar cj ipParseTests :: Spec ipParseTests = do it "Valid IP" testValidIp it "Digit Too High" testIpNumTooHigh it "Too Many Segments" testTooManySegmentsInIp it "Chars in IP" testCharsInIp domainMatchingTests :: Spec domainMatchingTests = do it "Should Match" testDomainMatchesSuccess it "Same Domain" testSameDomain it "Sibling Domain" testSiblingDomain it "Parent Domain" testParentDomain it "Checking for Naive suffix-check" testNaiveSuffixDomain defaultPathTests :: Spec defaultPathTests = do it "Basic default path test" testDefaultPath it "Basic populated default path" testPopulatedDefaultPath it "Default path from request with GET params works" testParamsDefaultPath it "Getting a default path that ends in a slash" testDefaultPathEndingInSlash it "Getting a short default path" testShortDefaultPath pathMatchingTests :: Spec pathMatchingTests = do it "Same paths match" testSamePathsMatch it "Putting slash at end" testPathSlashAtEnd it "Not putting slash at end" testPathNoSlashAtEnd it "Diverging paths don't match" testDivergingPaths equalityTests :: Spec equalityTests = do it "The same cookie should be equal to itself" testCookieEqualitySuccess it "Changing extra options shouldn't change equality" testCookieEqualityResiliance it "Changing a cookie's domain should change its equality" testDomainChangesEquality removeTests :: Spec removeTests = do it "Removing a cookie works" testRemoveCookie it "Removing a nonexistant cookie doesn't work" testRemoveNonexistantCookie it "Removing the correct cookie" testRemoveCorrectCookie evictionTests :: Spec evictionTests = do it "Testing eviction" testEvictExpiredCookies it "Evicting from empty cookie jar" testEvictNoCookies sendingTests :: Spec sendingTests = do it "Updates last access time upon using cookies" testComputeCookieStringUpdateLastAccessTime it "Host-only flag matches exact host" testComputeCookieStringHostOnly it "Host-only flag doesn't match subdomain" testComputeCookieStringHostOnlyFilter it "Domain matching works properly" testComputeCookieStringDomainMatching it "Path matching works" testComputeCookieStringPathMatching it "Path matching fails when it should" testComputeCookieStringPathMatchingFails it "Path matching succeeds when request has GET params" testComputeCookieStringPathMatchingWithParms it "Secure flag filters correctly" testComputeCookieStringSecure it "Http-only flag filters correctly" testComputeCookieStringHttpOnly it "Sorting works correctly" testComputeCookieStringSort it "Inserting cookie header works" testInsertCookiesIntoRequestWorks receivingTests :: Spec receivingTests = do it "Can receive set-cookie" testReceiveSetCookie it "Receiving a Set-Cookie with a trailing dot on the domain" testReceiveSetCookieTrailingDot it "Receiving a Set-Cookie with a leading dot on the domain" testReceiveSetCookieLeadingDot it "Set-Cookie with no domain" testReceiveSetCookieNoDomain it "Set-Cookie with empty domain" testReceiveSetCookieEmptyDomain it "Set-Cookie with non-matching domain" testReceiveSetCookieNonMatchingDomain it "Host-only flag gets set" testReceiveSetCookieHostOnly it "Host-only flag doesn't get set" testReceiveSetCookieHostOnlyNotSet it "Http-only flag gets set" testReceiveSetCookieHttpOnly it "Http-only flag doesn't get set" testReceiveSetCookieHttpOnlyNotSet it "Checking non http request gets dropped" testReceiveSetCookieHttpOnlyDrop it "Name gets set correctly" testReceiveSetCookieName it "Value gets set correctly" testReceiveSetCookieValue it "Expiry gets set correctly" testReceiveSetCookieExpiry it "Expiry gets set based on max age if no expiry is given" testReceiveSetCookieNoExpiry it "Expiry gets set based on given value if no max age is given" testReceiveSetCookieNoMaxAge it "Expiry gets set to a future date if no expiry and no max age are given" testReceiveSetCookieNoExpiryNoMaxAge it "Path gets set correctly when nonexistant" testReceiveSetCookieNoPath it "Path gets set correctly" testReceiveSetCookiePath it "Creation time gets set correctly" testReceiveSetCookieCreationTime it "Last access time gets set correctly" testReceiveSetCookieAccessTime it "Persistent flag gets set correctly" testReceiveSetCookiePersistent it "Existing cookie gets updated" testReceiveSetCookieExisting it "Creation time gets updated in existing cookie" testReceiveSetCookieExistingCreation it "Existing http-only cookie gets dropped" testReceiveSetCookieExistingHttpOnly it "Secure flag gets set correctly" testReceiveSetCookieSecure it "Max-Age flag gets set correctly" testReceiveSetCookieMaxAge it "Max-Age is preferred over Expires" testReceiveSetCookiePreferMaxAge monoidTests :: Spec monoidTests = do it "Monoid prefers more recent cookies" testMonoidPreferRecent cookieTest :: Spec cookieTest = do describe "ipParseTests" ipParseTests describe "domainMatchingTests" domainMatchingTests describe "defaultPathTests" defaultPathTests describe "pathMatchingTests" pathMatchingTests describe "equalityTests" equalityTests describe "removeTests" removeTests describe "evictionTests" evictionTests describe "sendingTests" sendingTests describe "receivingTests" receivingTests describe "monoidTest" monoidTests http-conduit-1.9.5.2/Network/0000755000000000000000000000000012243461040014123 5ustar0000000000000000http-conduit-1.9.5.2/Network/HTTP/0000755000000000000000000000000012243461040014702 5ustar0000000000000000http-conduit-1.9.5.2/Network/HTTP/Conduit.hs0000644000000000000000000003537312243461040016656 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} -- | This module contains everything you need to initiate HTTP connections. If -- you want a simple interface based on URLs, you can use 'simpleHttp'. If you -- want raw power, 'http' is the underlying workhorse of this package. Some -- examples: -- -- > -- Just download an HTML document and print it. -- > import Network.HTTP.Conduit -- > import qualified Data.ByteString.Lazy as L -- > -- > main = simpleHttp "http://www.haskell.org/" >>= L.putStr -- -- This example uses interleaved IO to write the response body to a file in -- constant memory space. -- -- > import Data.Conduit.Binary (sinkFile) -- > import Network.HTTP.Conduit -- > import qualified Data.Conduit as C -- > -- > main :: IO () -- > main = do -- > request <- parseUrl "http://google.com/" -- > withManager $ \manager -> do -- > response <- http request manager -- > responseBody response C.$$+- sinkFile "google.html" -- -- The following headers are automatically set by this module, and should not -- be added to 'requestHeaders': -- -- * Cookie -- -- * Content-Length -- -- * Transfer-Encoding -- -- Note: In previous versions, the Host header would be set by this module in -- all cases. Starting from 1.6.1, if a Host header is present in -- @requestHeaders@, it will be used in place of the header this module would -- have generated. This can be useful for calling a server which utilizes -- virtual hosting. -- -- Use `cookieJar` If you want to supply cookies with your request: -- -- > {-# LANGUAGE OverloadedStrings #-} -- > import Network.HTTP.Conduit -- > import Network -- > import Data.Time.Clock -- > import Data.Time.Calendar -- > import qualified Control.Exception as E -- > -- > past :: UTCTime -- > past = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0) -- > -- > future :: UTCTime -- > future = UTCTime (ModifiedJulianDay 562000) (secondsToDiffTime 0) -- > -- > cookie :: Cookie -- > cookie = Cookie { cookie_name = "password_hash" -- > , cookie_value = "abf472c35f8297fbcabf2911230001234fd2" -- > , cookie_expiry_time = future -- > , cookie_domain = "example.com" -- > , cookie_path = "/" -- > , cookie_creation_time = past -- > , cookie_last_access_time = past -- > , cookie_persistent = False -- > , cookie_host_only = False -- > , cookie_secure_only = False -- > , cookie_http_only = False -- > } -- > -- > main = withSocketsDo $ do -- > request' <- parseUrl "http://example.com/secret-page" -- > let request = request' { cookieJar = Just $ createCookieJar [cookie] } -- > E.catch (withManager $ httpLbs request) -- > (\(StatusCodeException s _ _) -> -- > if statusCode==403 then putStrLn "login failed" else return ()) -- -- Any network code on Windows requires some initialization, and the network -- library provides withSocketsDo to perform it. Therefore, proper usage of -- this library will always involve calling that function at some point. The -- best approach is to simply call them at the beginning of your main function, -- such as: -- -- > import Network.HTTP.Conduit -- > import qualified Data.ByteString.Lazy as L -- > import Network (withSocketsDo) -- > -- > main = withSocketsDo -- > $ simpleHttp "http://www.haskell.org/" >>= L.putStr -- > -- > Cookies are implemented according to RFC 6265. -- -- Note that by default, the functions in this package will throw exceptions -- for non-2xx status codes. If you would like to avoid this, you should use -- 'checkStatus', e.g.: -- -- > import Data.Conduit.Binary (sinkFile) -- > import Network.HTTP.Conduit -- > import qualified Data.Conduit as C -- > import Network -- > -- > main :: IO () -- > main = withSocketsDo $ do -- > request' <- parseUrl "http://www.yesodweb.com/does-not-exist" -- > let request = request' { checkStatus = \_ _ -> Nothing } -- > res <- withManager $ httpLbs request -- > print res module Network.HTTP.Conduit ( -- * Perform a request simpleHttp , httpLbs , http -- * Datatypes , Proxy (..) , RequestBody (..) -- ** Request , Request , def , method , secure , clientCertificates , host , port , path , queryString , requestHeaders , requestBody , proxy , socksProxy , hostAddress , rawBody , decompress , redirectCount , checkStatus , responseTimeout , cookieJar , getConnectionWrapper -- * Response , Response , responseStatus , responseVersion , responseHeaders , responseBody , responseCookieJar -- * Manager , Manager , newManager , closeManager , withManager , withManagerSettings -- ** Settings , ManagerSettings , managerConnCount , managerCheckCerts , managerCertStore , managerResponseTimeout -- *** Defaults , defaultCheckCerts -- * Cookies , Cookie(..) , CookieJar , createCookieJar , destroyCookieJar -- * Utility functions , parseUrl , applyBasicAuth , addProxy , lbsResponse , getRedirectedRequest -- * Decompression predicates , alwaysDecompress , browserDecompress -- * Request bodies -- | "Network.HTTP.Conduit.MultipartFormData" provides an API for building -- form-data request bodies. , urlEncodedBody -- * Exceptions , HttpException (..) #if DEBUG -- * Debug , printOpenSockets #endif ) where import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Network.HTTP.Types as W import Data.Default (def) import Control.Exception.Lifted (throwIO, try, IOException, handle, fromException, toException) import qualified Network.TLS as TLS import Control.Applicative import Control.Monad ((<=<)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Resource import qualified Data.Conduit as C import Data.Conduit.Blaze (builderToByteString) 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 import Network.HTTP.Conduit.Internal (httpRedirect, applyCheckStatus) import Network.HTTP.Conduit.Types -- | The most low-level function for initiating an HTTP request. -- -- The first argument to this function gives a full specification -- on the request: the host to connect to, whether to use SSL, -- headers, etc. Please see 'Request' for full details. The -- second argument specifies which 'Manager' should be used. -- -- This function then returns a 'Response' with a -- 'C.Source'. The 'Response' contains the status code -- and headers that were sent back to us, and the -- 'C.Source' contains the body of the request. Note -- that this 'C.Source' allows you to have fully -- interleaved IO actions during your HTTP download, making it -- possible to download very large responses in constant memory. -- You may also directly connect the returned 'C.Source' -- into a 'C.Sink', perhaps a file or another socket. -- -- An important note: the response body returned by this function represents a -- live HTTP connection. As such, if you do not use the response body, an open -- socket will be retained until the containing @ResourceT@ block exits. If you -- do not need the response body, it is recommended that you explicitly shut -- down the connection immediately, using the pattern: -- -- > responseBody res $$+- return () -- -- As a more thorough example, consider the following program. Without the -- explicit response body closing, the program will run out of file descriptors -- around the 1000th request (depending on the operating system limits). -- -- > import Control.Monad (replicateM_) -- > import Control.Monad.IO.Class (liftIO) -- > import Data.Conduit (($$+-)) -- > import Network (withSocketsDo) -- > import Network.HTTP.Conduit -- > -- > main = withSocketsDo $ withManager $ \manager -> do -- > req <- parseUrl "http://localhost/" -- > mapM_ (worker manager req) [1..5000] -- > -- > worker manager req i = do -- > res <- http req manager -- > responseBody res $$+- return () -- The important line -- > liftIO $ print (i, responseStatus res) -- -- Note: Unlike previous versions, this function will perform redirects, as -- specified by the 'redirectCount' setting. http :: (MonadResource m, MonadBaseControl IO m) => Request m -> Manager -> m (Response (C.ResumableSource m S.ByteString)) http req0 manager = wrapIOException $ do res <- if redirectCount req0 == 0 then httpRaw req0 manager else go (redirectCount req0) req0 maybe (return res) throwIO =<< applyCheckStatus (checkStatus req0) res where go count req' = httpRedirect count (\req -> do res <- httpRaw req manager let mreq = getRedirectedRequest req (responseHeaders res) (responseCookieJar res) (W.statusCode (responseStatus res)) return (res, mreq)) id req' -- | Get a 'Response' without any redirect following. httpRaw :: (MonadBaseControl IO m, MonadResource m) => Request m -> Manager -> m (Response (C.ResumableSource m S.ByteString)) httpRaw req' m = do (req, cookie_jar') <- case cookieJar req' of Just cj -> do now <- liftIO getCurrentTime return $ insertCookiesIntoRequest req' (evictExpiredCookies cj now) now Nothing -> return (req', def) (timeout', (connRelease, ci, isManaged)) <- getConnectionWrapper req (responseTimeout' req) (failedConnectionException req) (getConn req m) let src = connSource ci -- Originally, we would only test for exceptions when sending the request, -- not on calling @getResponse@. However, some servers seem to close -- connections after accepting the request headers, so we need to check for -- exceptions in both. ex <- try $ do requestBuilder req C.$$ builderToByteString C.=$ connSink ci getResponse connRelease timeout' req src case (ex, isManaged) of -- Connection was reused, and might have been closed. Try again (Left e, Reused) | isRetryableException e -> do connRelease DontReuse http req m -- Not reused, or a non-retry, so this is a real exception (Left e, _) -> liftIO $ throwIO e -- Everything went ok, so the connection is good. If any exceptions get -- thrown in the response body, just throw them as normal. (Right res, _) -> case cookieJar req' of Just _ -> do now' <- liftIO getCurrentTime let (cookie_jar, _) = updateCookieJar res req now' cookie_jar' return $ res {responseCookieJar = cookie_jar} Nothing -> return res where responseTimeout' req | rt == useDefaultTimeout = mResponseTimeout m | otherwise = rt where rt = responseTimeout req -- Exceptions for which we should retry our request if we were reusing an -- already open connection. In the case of IOExceptions, for example, we -- assume that the connection was closed on the server and therefore open a -- new one. isRetryableException e | ((fromException e)::(Maybe TLS.TLSError))==Just TLS.Error_EOF = True | otherwise = case fromException e of Just (_ :: IOException) -> True _ -> case fromException e of -- Note: Some servers will timeout connections by accepting -- the incoming packets for the new request, but closing -- the connection as soon as we try to read. To make sure -- we open a new connection under these circumstances, we -- check for the NoResponseDataReceived exception. Just NoResponseDataReceived -> True _ -> False -- | Download the specified 'Request', returning the results as a 'Response'. -- -- This is a simplified version of 'http' for the common case where you simply -- want the response data as a simple datatype. If you want more power, such as -- interleaved actions on the response body during download, you'll need to use -- 'http' directly. This function is defined as: -- -- @httpLbs = 'lbsResponse' <=< 'http'@ -- -- Even though the 'Response' contains a lazy bytestring, this -- function does /not/ utilize lazy I/O, and therefore the entire -- response body will live in memory. If you want constant memory -- usage, you'll need to use @conduit@ packages's -- 'C.Source' returned by 'http'. -- -- Note: Unlike previous versions, this function will perform redirects, as -- specified by the 'redirectCount' setting. httpLbs :: (MonadBaseControl IO m, MonadResource m) => Request m -> Manager -> m (Response L.ByteString) httpLbs r = wrapIOException . (lbsResponse <=< http r) wrapIOException :: MonadBaseControl IO m => m a -> m a wrapIOException = handle $ throwIO . wrapper where wrapper se = case fromException se of Just e -> toException $ InternalIOException e Nothing -> case fromException se of Just TLS.Terminated{} -> toException $ TlsException se Nothing -> case fromException se of Just TLS.HandshakeFailed{} -> toException $ TlsException se Nothing -> case fromException se of Just TLS.ConnectionNotEstablished -> toException $ TlsException se Nothing -> se -- | Download the specified URL, following any redirects, and -- return the response body. -- -- This function will 'throwIO' an 'HttpException' for any -- response with a non-2xx status code (besides 3xx redirects up -- to a limit of 10 redirects). It uses 'parseUrl' to parse the -- input. This function essentially wraps 'httpLbs'. -- -- Note: Even though this function returns a lazy bytestring, it -- does /not/ utilize lazy I/O, and therefore the entire response -- body will live in memory. If you want constant memory usage, -- you'll need to use the @conduit@ package and 'http' directly. -- -- Note: This function creates a new 'Manager'. It should be avoided -- in production code. simpleHttp :: MonadIO m => String -> m L.ByteString simpleHttp url = liftIO $ withManager $ \man -> do req <- liftIO $ parseUrl url responseBody <$> httpLbs (setConnectionClose req) man setConnectionClose :: Request m -> Request m setConnectionClose req = req{requestHeaders = ("Connection", "close") : requestHeaders req} http-conduit-1.9.5.2/Network/HTTP/Conduit/0000755000000000000000000000000012243461040016307 5ustar0000000000000000http-conduit-1.9.5.2/Network/HTTP/Conduit/Response.hs0000644000000000000000000001735412243461040020453 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Network.HTTP.Conduit.Response ( Response (..) , getRedirectedRequest , getResponse , lbsResponse ) where import Control.Arrow (first) import Control.Monad (liftM) import Control.Exception (throwIO) import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import qualified Data.CaseInsensitive as CI import Data.Default (def) import Data.Conduit import Data.Conduit.Internal (ResumableSource (..), Pipe (..)) import qualified Data.Conduit.Zlib as CZ import qualified Data.Conduit.List as CL import qualified Network.HTTP.Types as W import Network.URI (parseURIReference) import Network.HTTP.Conduit.Types (Response (..), CookieJar) import Network.HTTP.Conduit.Manager import Network.HTTP.Conduit.Request import Network.HTTP.Conduit.Util import Network.HTTP.Conduit.Chunk import Network.HTTP.Conduit.Parser (sinkHeaders) import Data.Void (Void, absurd) import System.Timeout.Lifted (timeout) #if MIN_VERSION_conduit(1, 0, 0) import Data.Conduit.Internal (ConduitM (..)) #endif -- | If a request is a redirection (status code 3xx) this function will create -- a new request from the old request, the server headers returned with the -- redirection, and the redirection code itself. This function returns 'Nothing' -- if the code is not a 3xx, there is no 'location' header included, or if the -- redirected response couldn't be parsed with 'parseUrl'. -- -- If a user of this library wants to know the url chain that results from a -- specific request, that user has to re-implement the redirect-following logic -- themselves. An example of that might look like this: -- -- > myHttp req man = do -- > (res, redirectRequests) <- (`runStateT` []) $ -- > 'httpRedirect' -- > 9000 -- > (\req' -> do -- > res <- http req'{redirectCount=0} man -- > modify (\rqs -> req' : rqs) -- > return (res, getRedirectedRequest req' (responseHeaders res) (responseCookieJar res) (W.statusCode (responseStatus res)) -- > ) -- > 'lift' -- > req -- > applyCheckStatus (checkStatus req) res -- > return redirectRequests getRedirectedRequest :: Request m -> W.ResponseHeaders -> CookieJar -> Int -> Maybe (Request m) getRedirectedRequest req hs cookie_jar code | 300 <= code && code < 400 = do l' <- lookup "location" hs req' <- setUriRelative req =<< parseURIReference (S8.unpack l') return $ if code == 302 || code == 303 -- According to the spec, this should *only* be for status code -- 303. However, almost all clients mistakenly implement it for -- 302 as well. So we have to be wrong like everyone else... then req' { method = "GET" , requestBody = RequestBodyBS "" , cookieJar = cookie_jar' } else req' {cookieJar = cookie_jar'} | otherwise = Nothing where cookie_jar' = fmap (const cookie_jar) $ cookieJar req -- | Convert a 'Response' that has a 'Source' body to one with a lazy -- 'L.ByteString' body. lbsResponse :: Monad m => Response (ResumableSource m S8.ByteString) -> m (Response L.ByteString) lbsResponse res = do bss <- responseBody res $$+- CL.consume return res { responseBody = L.fromChunks bss } -- | This function can\'t be a Conduit, since it would lose leftovers. checkHeaderLength :: MonadResource m => Int -> Pipe S8.ByteString S8.ByteString Void u m r -> Pipe S8.ByteString S8.ByteString Void u m r checkHeaderLength len NeedInput{} | len <= 0 = liftIO $ throwIO OverlongHeaders checkHeaderLength len (NeedInput pushI closeI) = NeedInput (\bs -> checkHeaderLength (len - S8.length bs) (pushI bs)) closeI checkHeaderLength len (PipeM msink) = PipeM (liftM (checkHeaderLength len) msink) checkHeaderLength _ s@Done{} = s checkHeaderLength _ (HaveOutput _ _ o) = absurd o checkHeaderLength len (Leftover p i) = Leftover (checkHeaderLength (len + S.length i) p) i getResponse :: (MonadResource m, MonadBaseControl IO m) => ConnRelease m -> Maybe Int -> Request m -> Source m S8.ByteString -> m (Response (ResumableSource m S8.ByteString)) getResponse connRelease timeout'' req@(Request {..}) src1 = do let timeout' = case timeout'' of Nothing -> id Just useconds -> \ma -> do x <- timeout useconds ma case x of Nothing -> liftIO $ throwIO ResponseTimeout Just y -> return y (src2, ((vbs, sc, sm), hs)) <- timeout' $ src1 $$+ #if MIN_VERSION_conduit(1, 0, 0) ConduitM (checkHeaderLength 4096 $ unConduitM sinkHeaders) #else (checkHeaderLength 4096 sinkHeaders) #endif let version = if vbs == "1.1" then W.http11 else W.http10 let s = W.Status sc sm let hs' = map (first CI.mk) hs let mcl = lookup "content-length" hs' >>= readDec . S8.unpack -- should we put this connection back into the connection manager? let toPut = Just "close" /= lookup "connection" hs' && vbs /= "1.0" let cleanup bodyConsumed = connRelease $ if toPut && bodyConsumed then Reuse else DontReuse -- RFC 2616 section 4.4_1 defines responses that must not include a body body <- if hasNoBody method sc || mcl == Just 0 then do cleanup True (rsrc, ()) <- return () $$+ return () return rsrc else do let isChunked = ("transfer-encoding", "chunked") `elem` hs' src3 = if isChunked then fmapResume ($= chunkedConduit rawBody) src2 else case mcl of Just len -> fmapResume ($= requireLength len) src2 Nothing -> src2 src4 = if needsGunzip req hs' then fmapResume ($= (if isChunked then ungzipChunked else CZ.ungzip)) src3 else src3 return $ addCleanup' cleanup src4 return $ Response s version hs' body def where -- When a body is both chunked and gzipped, we need to flush each chunk -- immediately to ensure streaming behavior. ungzipChunked = CL.concatMap (\x -> [Chunk x, Flush]) =$= CZ.decompressFlush (CZ.WindowBits 31) =$= awaitForever unChunk where unChunk Flush = return () unChunk (Chunk x) = yield x fmapResume f (ResumableSource src m) = ResumableSource (f src) m addCleanup' f (ResumableSource src m) = ResumableSource (addCleanup f src) (m >> f False) -- | Ensure that the stream has exactly the given length. requireLength :: MonadIO m => Int -> Conduit S.ByteString m S.ByteString requireLength total = loop total where loop 0 = return () loop i = await >>= maybe (liftIO $ throwIO $ ResponseBodyTooShort (fromIntegral total) (fromIntegral $ total - i)) go where go bs = case compare i l of EQ -> yield bs LT -> do let (x, y) = S.splitAt i bs leftover y yield x GT -> yield bs >> loop (i - l) where l = S.length bs http-conduit-1.9.5.2/Network/HTTP/Conduit/Internal.hs0000644000000000000000000000746312243461040020431 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} module Network.HTTP.Conduit.Internal ( getUri , setUri , setUriRelative -- * Redirect loop , httpRedirect , applyCheckStatus -- * Cookie functions , updateCookieJar , receiveSetCookie , generateCookie , insertCheckedCookie , insertCookiesIntoRequest , computeCookieString , evictExpiredCookies ) where import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as S8 import Control.Exception (SomeException, toException, fromException) import Control.Exception.Lifted (throwIO) import Control.Monad.Trans.Resource import qualified Data.Conduit as C import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.Internal as CI import Data.Conduit.List (sinkNull) import Network.HTTP.Conduit.Request import Network.HTTP.Conduit.Response import Network.HTTP.Conduit.Cookies import Network.HTTP.Conduit.Types import Network.HTTP.Types -- | Redirect loop httpRedirect :: (MonadBaseControl IO m, MonadResource m, Monad m1) => Int -- ^ 'redirectCount' -> (Request m1 -> m (Response (C.ResumableSource m1 S.ByteString), Maybe (Request m1))) -- ^ function which performs a request and returns a response, and possibly another request if there's a redirect. -> (forall a. m1 a -> m a) -- ^ 'liftResourceT' -> Request m1 -> m (Response (C.ResumableSource m1 S.ByteString)) httpRedirect count0 http' lift' req0 = go count0 req0 [] where go (-1) _ ress = throwIO . TooManyRedirects =<< lift' (mapM lbsResponse ress) go count req' ress = do (res, mreq) <- http' req' case mreq of Just req -> do -- Allow the original connection to return to the -- connection pool immediately by flushing the body. -- If the response body is too large, don't flush, but -- instead just close the connection. let maxFlush = 1024 readMay bs = case S8.readInt bs of Just (i, bs') | S.null bs' -> Just i _ -> Nothing sink = case lookup "content-length" (responseHeaders res) >>= readMay of Just i | i > maxFlush -> return () _ -> CB.isolate maxFlush C.=$ sinkNull lift' $ responseBody res C.$$+- sink -- And now perform the actual redirect go (count - 1) req (res:ress) Nothing -> return res -- | Apply 'Request'\'s 'checkStatus' and return resulting exception if any. applyCheckStatus :: (MonadResource m, MonadBaseControl IO m) => (Status -> ResponseHeaders -> CookieJar -> Maybe SomeException) -> Response (C.ResumableSource m S.ByteString) -> m (Maybe SomeException) applyCheckStatus checkStatus' res = case checkStatus' (responseStatus res) (responseHeaders res) (responseCookieJar res) of Nothing -> return Nothing Just exc -> do exc' <- case fromException exc of Just (StatusCodeException s hdrs cookie_jar) -> do lbs <- (responseBody res) C.$$+- CB.take 1024 return $ toException $ StatusCodeException s (hdrs ++ [("X-Response-Body-Start", toStrict' lbs)]) cookie_jar _ -> do let CI.ResumableSource _ final = (responseBody res) final return exc return (Just exc') where #if MIN_VERSION_bytestring(0,10,0) toStrict' = L.toStrict #else toStrict' = S.concat . L.toChunks #endif http-conduit-1.9.5.2/Network/HTTP/Conduit/Cookies.hs0000644000000000000000000003246312243461040020247 0ustar0000000000000000-- | This module implements the algorithms described in RFC 6265 for the Network.HTTP.Conduit library. module Network.HTTP.Conduit.Cookies where import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as S8 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 qualified Network.PublicSuffixList.Lookup as PSL import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import qualified Network.HTTP.Conduit.Request as Req import qualified Network.HTTP.Conduit.Response as Res import Network.HTTP.Conduit.Types slash :: Integral a => a slash = 47 -- '/' isIpAddress :: BS.ByteString -> 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 :: BS.ByteString -> BS.ByteString -> 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 -> BS.ByteString 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 :: BS.ByteString -> BS.ByteString -> Bool pathMatches requestPath cookiePath | cookiePath == path' = True | cookiePath `BS.isPrefixOf` path' && BS.singleton (BS.last cookiePath) == U.fromString "/" = True | cookiePath `BS.isPrefixOf` path' && BS.singleton (BS.head remainder) == U.fromString "/" = True | otherwise = False where remainder = BS.drop (BS.length cookiePath) requestPath path' = case S8.uncons requestPath of Just ('/', _) -> requestPath _ -> '/' `S8.cons` requestPath 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 :: BS.ByteString -> Bool isPublicSuffix = PSL.isSuffix . decodeUtf8With lenientDecode -- | 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 | BS.null cookie_string = (request, cookie_jar') | otherwise = (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) -> (BS.ByteString, 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\" -- This function consists of calling 'generateCookie' followed by 'insertCheckedCookie'. -- Use this function if you plan to do both in a row. -- 'generateCookie' and 'insertCheckedCookie' are only provided for more fine-grained control. 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 (do cookie <- generateCookie set_cookie request now is_http_api return $ insertCheckedCookie cookie cookie_jar is_http_api) of Just cj -> cj Nothing -> cookie_jar -- | Insert a cookie created by generateCookie into the cookie jar (or not if it shouldn't be allowed in) insertCheckedCookie :: Cookie -- ^ The 'SetCookie' the cookie jar is receiving -> CookieJar -- ^ Input cookie jar to modify -> Bool -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that) -> CookieJar -- ^ Updated (or not) cookie jar insertCheckedCookie c cookie_jar is_http_api = case (do (cookie_jar', cookie') <- existanceTest c cookie_jar return $ insertIntoCookieJar cookie' cookie_jar') of Just cj -> cj Nothing -> cookie_jar where 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) -- | Turn a SetCookie into a Cookie, if it is valid generateCookie :: SetCookie -- ^ The 'SetCookie' we are encountering -> 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) -> Maybe Cookie -- ^ The optional output cookie generateCookie set_cookie request now is_http_api = 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' } where 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 && has_a_character && isPublicSuffix domain' has_a_character = not (BS.null 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 (365000 `addDays` utctDay now) (secondsToDiffTime 0) getPath (Just p) = p getPath Nothing = defaultPath request getPersistent = isJust (setCookieExpires set_cookie) || isJust (setCookieMaxAge set_cookie) http-conduit-1.9.5.2/Network/HTTP/Conduit/Request.hs0000644000000000000000000002751612243461040020306 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Network.HTTP.Conduit.Request ( Request (..) , RequestBody (..) , ContentType , Proxy (..) , parseUrl , setUriRelative , getUri , setUri , browserDecompress , HttpException (..) , alwaysDecompress , addProxy , applyBasicAuth , urlEncodedBody , needsGunzip , requestBuilder , useDefaultTimeout ) where import Data.Maybe (fromMaybe, isJust) import Data.Monoid (mempty, mappend) import Data.String (IsString(..)) import Data.Default (Default (def)) import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString) import Blaze.ByteString.Builder.Char8 (fromChar) import qualified Data.Conduit as C import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import qualified Network.HTTP.Types as W import Network.URI (URI (..), URIAuth (..), parseURI, relativeTo, escapeURIString, isAllowedInURI) import Control.Monad.IO.Class (liftIO) import Control.Exception.Lifted (Exception, toException, throw, throwIO) import Control.Failure (Failure (failure)) import qualified Data.CaseInsensitive as CI import qualified Data.ByteString.Base64 as B64 import Network.HTTP.Conduit.Types (Request (..), RequestBody (..), ContentType, Proxy (..), HttpException (..)) import Network.HTTP.Conduit.Chunk (chunkIt) import Network.HTTP.Conduit.Util (readDec, (<>)) import System.Timeout.Lifted (timeout) import Data.Time.Clock -- | Convert a URL into a 'Request'. -- -- This defaults some of the values in 'Request', such as setting 'method' to -- GET and 'requestHeaders' to @[]@. -- -- Since this function uses 'Failure', the return monad can be anything that is -- an instance of 'Failure', such as 'IO' or 'Maybe'. parseUrl :: Failure HttpException m => String -> m (Request m') parseUrl s = case parseURI (encode s) of Just uri -> setUri def uri Nothing -> failure $ InvalidUrlException s "Invalid URL" where encode = escapeURIString isAllowedInURI -- | Add a 'URI' to the request. If it is absolute (includes a host name), add -- it as per 'setUri'; if it is relative, merge it with the existing request. setUriRelative :: Failure HttpException m => Request m' -> URI -> m (Request m') setUriRelative req uri = #if MIN_VERSION_network(2,4,0) setUri req $ uri `relativeTo` getUri req #else case uri `relativeTo` getUri req of Just uri' -> setUri req uri' Nothing -> failure $ InvalidUrlException (show uri) "Invalid URL" #endif -- | Extract a 'URI' from the request. getUri :: Request m' -> URI getUri req = URI { uriScheme = if secure req then "https:" else "http:" , uriAuthority = Just URIAuth { uriUserInfo = "" , uriRegName = S8.unpack $ host req , uriPort = ':' : show (port req) } , uriPath = S8.unpack $ path req , uriQuery = S8.unpack $ queryString req , uriFragment = "" } -- | Validate a 'URI', then add it to the request. setUri :: Failure HttpException m => Request m' -> URI -> m (Request m') setUri req uri = do sec <- parseScheme uri auth <- maybe (failUri "URL must be absolute") return $ uriAuthority uri if not . null $ uriUserInfo auth then failUri "URL auth not supported; use applyBasicAuth instead" else return () port' <- parsePort sec auth return req { host = S8.pack $ uriRegName auth , port = port' , secure = sec , path = S8.pack $ if null $ uriPath uri then "/" else uriPath uri , queryString = S8.pack $ uriQuery uri } where failUri :: Failure HttpException m => String -> m a failUri = failure . InvalidUrlException (show uri) parseScheme URI{uriScheme = scheme} = case scheme of "http:" -> return False "https:" -> return True _ -> failUri "Invalid scheme" parsePort sec URIAuth{uriPort = portStr} = case portStr of -- If the user specifies a port, then use it ':':rest -> maybe (failUri "Invalid port") return (readDec rest) -- Otherwise, use the default port _ -> case sec of False {- HTTP -} -> return 80 True {- HTTPS -} -> return 443 instance Show (Request m) where show x = unlines [ "Request {" , " host = " ++ show (host x) , " port = " ++ show (port x) , " secure = " ++ show (secure x) , " clientCertificates = " ++ show (clientCertificates x) , " requestHeaders = " ++ show (requestHeaders x) , " path = " ++ show (path x) , " queryString = " ++ show (queryString x) , " requestBody = " ++ show (requestBody x) , " method = " ++ show (method x) , " proxy = " ++ show (proxy x) , " rawBody = " ++ show (rawBody x) , " redirectCount = " ++ show (redirectCount x) , " responseTimeout = " ++ show (responseTimeout x) , "}" ] -- | Magic value to be placed in a 'Request' to indicate that we should use the -- timeout value in the @Manager@. -- -- Since 1.9.3 useDefaultTimeout :: Maybe Int useDefaultTimeout = Just (-3425) instance Default (Request m) where def = Request { host = "localhost" , port = 80 , secure = False , clientCertificates = [] , requestHeaders = [] , path = "/" , queryString = S8.empty , requestBody = RequestBodyLBS L.empty , method = "GET" , proxy = Nothing , socksProxy = Nothing , hostAddress = Nothing , rawBody = False , decompress = browserDecompress , redirectCount = 10 , checkStatus = \s@(W.Status sci _) hs cookie_jar -> if 200 <= sci && sci < 300 then Nothing else Just $ toException $ StatusCodeException s hs cookie_jar , responseTimeout = useDefaultTimeout , getConnectionWrapper = \mtimeout exc f -> case mtimeout of Nothing -> fmap ((,) Nothing) f Just timeout' -> do before <- liftIO getCurrentTime mres <- timeout timeout' f case mres of Nothing -> throwIO exc Just res -> do now <- liftIO getCurrentTime let timeSpentMicro = diffUTCTime now before * 1000000 remainingTime = round $ fromIntegral timeout' - timeSpentMicro if remainingTime <= 0 then throwIO exc else return (Just remainingTime, res) , cookieJar = Just def } instance IsString (Request m) where fromString s = case parseUrl s of Left e -> throw (e :: HttpException) Right r -> r -- | Always decompress a compressed stream. alwaysDecompress :: ContentType -> Bool alwaysDecompress = const True -- | Decompress a compressed stream unless the content-type is 'application/x-tar'. browserDecompress :: ContentType -> Bool browserDecompress = (/= "application/x-tar") -- | Add a Basic Auth header (with the specified user name and password) to the -- given Request. Ignore error handling: -- -- applyBasicAuth "user" "pass" $ fromJust $ parseUrl url applyBasicAuth :: S.ByteString -> S.ByteString -> Request m -> Request m applyBasicAuth user passwd req = req { requestHeaders = authHeader : requestHeaders req } where authHeader = (CI.mk "Authorization", basic) basic = S8.append "Basic " (B64.encode $ S8.concat [ user, ":", passwd ]) -- | Add a proxy to the Request so that the Request when executed will use -- the provided proxy. addProxy :: S.ByteString -> Int -> Request m -> Request m addProxy hst prt req = req { proxy = Just $ Proxy hst prt } -- FIXME add a helper for generating POST bodies -- | Add url-encoded parameters to the 'Request'. -- -- This sets a new 'requestBody', adds a content-type request header and -- changes the 'method' to POST. urlEncodedBody :: Monad m => [(S.ByteString, S.ByteString)] -> Request m' -> Request m urlEncodedBody headers req = req { requestBody = RequestBodyLBS body , method = "POST" , requestHeaders = (ct, "application/x-www-form-urlencoded") : filter (\(x, _) -> x /= ct) (requestHeaders req) } where ct = "Content-Type" body = L.fromChunks . return $ W.renderSimpleQuery False headers needsGunzip :: Request m -> [W.Header] -- ^ response headers -> Bool needsGunzip req hs' = not (rawBody req) && ("content-encoding", "gzip") `elem` hs' && decompress req (fromMaybe "" $ lookup "content-type" hs') requestBuilder :: Monad m => Request m -> C.Source m Builder requestBuilder req = bodySource where (contentLength, bodySource) = case requestBody req of RequestBodyLBS lbs -> (Just $ L.length lbs, C.yield $ builder `mappend` fromLazyByteString lbs) RequestBodyBS bs -> (Just $ fromIntegral $ S.length bs, C.yield $ builder `mappend` fromByteString bs) RequestBodyBuilder i b -> (Just $ i, C.yield $ builder `mappend` b) RequestBodySource i source -> (Just i, C.yield builder >> source) RequestBodySourceChunked source -> (Nothing, C.yield builder >> (source C.$= chunkIt)) hh | port req == 80 && not (secure req) = host req | port req == 443 && secure req = host req | otherwise = host req <> S8.pack (':' : show (port req)) requestProtocol | secure req = fromByteString "https://" | otherwise = fromByteString "http://" requestHostname | isJust (proxy req) = requestProtocol <> fromByteString hh | otherwise = mempty contentLengthHeader (Just contentLength') = if method req `elem` ["GET", "HEAD"] && contentLength' == 0 then id else (:) ("Content-Length", S8.pack $ show contentLength') contentLengthHeader Nothing = (:) ("Transfer-Encoding", "chunked") acceptEncodingHeader = case lookup "Accept-Encoding" $ requestHeaders req of Nothing -> (("Accept-Encoding", "gzip"):) Just "" -> filter (\(k, _) -> k /= "Accept-Encoding") Just _ -> id hostHeader x = case lookup "Host" x of Nothing -> ("Host", hh) : x Just{} -> x headerPairs :: W.RequestHeaders headerPairs = hostHeader $ acceptEncodingHeader $ contentLengthHeader contentLength $ requestHeaders req builder :: Builder builder = fromByteString (method req) <> fromByteString " " <> requestHostname <> (case S8.uncons $ path req of Just ('/', _) -> fromByteString $ path req _ -> fromChar '/' <> fromByteString (path req)) <> (case S8.uncons $ queryString req of Nothing -> mempty Just ('?', _) -> fromByteString $ queryString req _ -> fromChar '?' <> fromByteString (queryString req)) <> fromByteString " HTTP/1.1\r\n" <> foldr (\a b -> headerPairToBuilder a <> b) (fromByteString "\r\n") headerPairs headerPairToBuilder (k, v) = fromByteString (CI.original k) <> fromByteString ": " <> fromByteString v <> fromByteString "\r\n" http-conduit-1.9.5.2/Network/HTTP/Conduit/Manager.hs0000644000000000000000000004625412243461040020230 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} module Network.HTTP.Conduit.Manager ( Manager , mResponseTimeout , ManagerSettings (..) , ConnKey (..) , ConnHost (..) , newManager , closeManager , getConn , ConnReuse (..) , withManager , withManagerSettings , ConnRelease , ManagedConn (..) , defaultCheckCerts , failedConnectionException ) where #if !MIN_VERSION_base(4,6,0) import Prelude hiding (catch) #endif import Data.Monoid (mappend) import System.IO (hClose, hFlush, IOMode(..)) import qualified Data.IORef as I import qualified Data.Map as Map import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import qualified Blaze.ByteString.Builder as Blaze import Data.Text (Text) import qualified Data.Text as T import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Exception (mask_, SomeException, catch, throwIO, fromException) import Control.Monad.Trans.Resource ( ResourceT, runResourceT, MonadResource , MonadThrow, MonadUnsafeIO , allocate, resourceMask, register, release ) import Control.Concurrent (forkIO, threadDelay) import Data.Time (UTCTime (..), Day (..), DiffTime, getCurrentTime, addUTCTime) import Control.DeepSeq (deepseq) import qualified Network.Socket as NS import Data.Certificate.X509 (X509, encodeCertificate) import Data.CertificateStore (CertificateStore) import System.Certificate.X509 (getSystemCertificateStore) import Network.TLS (PrivateKey) import Network.TLS.Extra (certificateVerifyChain, certificateVerifyDomain) import Network.HTTP.Conduit.ConnInfo import Network.HTTP.Conduit.Types import Network.HTTP.Conduit.Util (hGetSome) import Network.HTTP.Conduit.Parser (sinkHeaders) import Network.Socks5 (SocksConf) import Data.Default import Data.Maybe (mapMaybe) import System.IO (Handle) import System.Mem.Weak (Weak, deRefWeak) import Data.Conduit (($$), yield, runException) -- | Settings for a @Manager@. Please use the 'def' function and then modify -- individual settings. data ManagerSettings = ManagerSettings { managerConnCount :: Int -- ^ Number of connections to a single host to keep alive. Default: 10. , managerCheckCerts :: CertificateStore -> S8.ByteString -> [X509] -> IO CertificateUsage -- ^ Check if the server certificate is valid. Only relevant for HTTPS. , managerCertStore :: IO CertificateStore -- ^ Load up the certificate store. By default uses the system store. , managerResponseTimeout :: Maybe Int -- ^ Default timeout (in microseconds) to be applied to requests which do -- not provide a timeout value. -- -- Default is 5 seconds -- -- Since 1.9.3 } type X509Encoded = L.ByteString instance Default ManagerSettings where def = ManagerSettings { managerConnCount = 10 , managerCheckCerts = defaultCheckCerts , managerCertStore = getSystemCertificateStore , managerResponseTimeout = Just 5000000 } -- | Check certificates using the operating system's certificate checker. defaultCheckCerts :: CertificateStore -> S8.ByteString -> [X509] -> IO CertificateUsage defaultCheckCerts certStore host' certs = case certificateVerifyDomain (S8.unpack host') certs of CertificateUsageAccept -> certificateVerifyChain certStore certs rejected -> return rejected -- | Keeps track of open connections for keep-alive. -- If possible, you should share a single 'Manager' between multiple threads and requests. data Manager = Manager { mConns :: !(I.IORef (Maybe (Map.Map ConnKey (NonEmptyList ConnInfo)))) -- ^ @Nothing@ indicates that the manager is closed. , mMaxConns :: !Int -- ^ This is a per-@ConnKey@ value. , mCheckCerts :: S8.ByteString -> [X509] -> IO CertificateUsage -- ^ Check if a certificate is valid. , mCertCache :: !(I.IORef (Map.Map S8.ByteString (Map.Map X509Encoded UTCTime))) -- ^ Cache of validated certificates. The @UTCTime@ gives the expiration -- time for the validity of the certificate. The @Ascii@ is the hostname. , mResponseTimeout :: !(Maybe Int) -- ^ Copied from 'managerResponseTimeout' } data NonEmptyList a = One !a !UTCTime | Cons !a !Int !UTCTime !(NonEmptyList a) -- | Hostname or resolved host address. data ConnHost = HostName !Text | HostAddress !NS.HostAddress deriving (Eq, Show, Ord) -- | @ConnKey@ consists of a hostname, a port and a @Bool@ -- specifying whether to use SSL. data ConnKey = ConnKey !ConnHost !Int !Bool deriving (Eq, Show, Ord) takeSocket :: Manager -> ConnKey -> IO (Maybe ConnInfo) takeSocket man key = I.atomicModifyIORef (mConns man) go where go Nothing = (Nothing, Nothing) go (Just m) = case Map.lookup key m of Nothing -> (Just m, Nothing) Just (One a _) -> (Just $ Map.delete key m, Just a) Just (Cons a _ _ rest) -> (Just $ Map.insert key rest m, Just a) putSocket :: Manager -> ConnKey -> ConnInfo -> IO () putSocket man key ci = do now <- getCurrentTime msock <- I.atomicModifyIORef (mConns man) (go now) maybe (return ()) connClose msock where go _ Nothing = (Nothing, Just ci) go now (Just m) = case Map.lookup key m of Nothing -> (Just $ Map.insert key (One ci now) m, Nothing) Just l -> let (l', mx) = addToList now (mMaxConns man) ci l in (Just $ Map.insert key l' m, mx) -- | Add a new element to the list, up to the given maximum number. If we're -- already at the maximum, return the new value as leftover. addToList :: UTCTime -> Int -> a -> NonEmptyList a -> (NonEmptyList a, Maybe a) addToList _ i x l | i <= 1 = (l, Just x) addToList now _ x l@One{} = (Cons x 2 now l, Nothing) addToList now maxCount x l@(Cons _ currCount _ _) | maxCount > currCount = (Cons x (currCount + 1) now l, Nothing) | otherwise = (l, Just x) -- | Create a 'Manager'. You must manually call 'closeManager' to shut it down. -- -- Creating a new 'Manager' is an expensive operation, you are advised to share -- a single 'Manager' between requests instead. newManager :: ManagerSettings -> IO Manager newManager ms = do icertStore <- I.newIORef Nothing let getCertStore = do mcertStore <- I.readIORef icertStore case mcertStore of Nothing -> do certStore <- managerCertStore ms I.writeIORef icertStore $ Just certStore return certStore Just x -> return x mapRef <- I.newIORef (Just Map.empty) wmapRef <- I.mkWeakIORef mapRef $ closeManager' mapRef certCache <- I.newIORef Map.empty _ <- forkIO $ reap wmapRef certCache let manager = Manager { mConns = mapRef , mMaxConns = managerConnCount ms , mCheckCerts = \x y -> getCertStore >>= \cs -> managerCheckCerts ms cs x y , mCertCache = certCache , mResponseTimeout = managerResponseTimeout ms } return manager -- | Collect and destroy any stale connections. reap :: Weak (I.IORef (Maybe (Map.Map ConnKey (NonEmptyList ConnInfo)))) -> I.IORef (Map.Map S8.ByteString (Map.Map X509Encoded UTCTime)) -> IO () reap wmapRef certCacheRef = mask_ loop where loop = do threadDelay (5 * 1000 * 1000) mmapRef <- deRefWeak wmapRef case mmapRef of Nothing -> return () -- manager is closed Just mapRef -> goMapRef mapRef goMapRef mapRef = do now <- getCurrentTime let isNotStale time = 30 `addUTCTime` time >= now mtoDestroy <- I.atomicModifyIORef mapRef (findStaleWrap isNotStale) case mtoDestroy of Nothing -> return () -- manager is closed Just toDestroy -> do mapM_ safeConnClose toDestroy !() <- I.atomicModifyIORef certCacheRef $ \x -> let y = flushStaleCerts now x in y `seq` (y, ()) loop findStaleWrap _ Nothing = (Nothing, Nothing) findStaleWrap isNotStale (Just m) = let (x, y) = findStale isNotStale m in (Just x, Just y) findStale isNotStale = findStale' id id . Map.toList where findStale' destroy keep [] = (Map.fromList $ keep [], destroy []) findStale' destroy keep ((connkey, nelist):rest) = findStale' destroy' keep' rest where -- Note: By definition, the timestamps must be in descending order, -- so we don't need to traverse the whole list. (notStale, stale) = span (isNotStale . fst) $ neToList nelist destroy' = destroy . (map snd stale++) keep' = case neFromList notStale of Nothing -> keep Just x -> keep . ((connkey, x):) flushStaleCerts now = Map.fromList . mapMaybe flushStaleCerts' . Map.toList where flushStaleCerts' (host', inner) = case mapMaybe flushStaleCerts'' $ Map.toList inner of [] -> Nothing pairs -> let x = take 10 pairs in x `seqPairs` Just (host', Map.fromList x) flushStaleCerts'' (certs, expires) | expires > now = Just (certs, expires) | otherwise = Nothing seqPairs :: [(L.ByteString, UTCTime)] -> b -> b seqPairs [] b = b seqPairs (p:ps) b = p `seqPair` ps `seqPairs` b seqPair :: (L.ByteString, UTCTime) -> b -> b seqPair (lbs, utc) b = lbs `seqLBS` utc `seqUTC` b seqLBS :: L.ByteString -> b -> b seqLBS lbs b = L.length lbs `seq` b seqUTC :: UTCTime -> b -> b seqUTC (UTCTime day dt) b = day `seqDay` dt `seqDT` b seqDay :: Day -> b -> b seqDay (ModifiedJulianDay i) b = i `deepseq` b seqDT :: DiffTime -> b -> b seqDT = seq neToList :: NonEmptyList a -> [(UTCTime, a)] neToList (One a t) = [(t, a)] neToList (Cons a _ t nelist) = (t, a) : neToList nelist neFromList :: [(UTCTime, a)] -> Maybe (NonEmptyList a) neFromList [] = Nothing neFromList [(t, a)] = Just (One a t) neFromList xs = Just . snd . go $ xs where go [] = error "neFromList.go []" go [(t, a)] = (2, One a t) go ((t, a):rest) = let (i, rest') = go rest i' = i + 1 in i' `seq` (i', Cons a i t rest') -- | Create a new manager, use it in the provided function, and then release it. -- -- This function uses the default manager settings. For more control, use -- 'withManagerSettings'. withManager :: ( MonadIO m , MonadBaseControl IO m , MonadThrow m , MonadUnsafeIO m ) => (Manager -> ResourceT m a) -> m a withManager f = runResourceT $ do (_, manager) <- allocate (newManager def) closeManager f manager -- | Create a new manager with provided settings, use it in the provided function, and then release it. withManagerSettings :: ( MonadIO m , MonadBaseControl IO m , MonadThrow m , MonadUnsafeIO m ) => ManagerSettings -> (Manager -> ResourceT m a) -> m a withManagerSettings s f = runResourceT $ do (_, manager) <- allocate (newManager s) closeManager f manager -- | Close all connections in a 'Manager'. Afterwards, the 'Manager' -- can be reused if desired. -- -- Note that this doesn't affect currently in-flight connections, -- meaning you can safely use it without hurting any queries you may -- have concurrently running. closeManager :: Manager -> IO () closeManager = closeManager' . mConns closeManager' :: I.IORef (Maybe (Map.Map ConnKey (NonEmptyList ConnInfo))) -> IO () closeManager' connsRef = mask_ $ do m <- I.atomicModifyIORef connsRef $ \x -> (Nothing, x) mapM_ (nonEmptyMapM_ safeConnClose) $ maybe [] Map.elems m safeConnClose :: ConnInfo -> IO () safeConnClose ci = connClose ci `catch` \(_::SomeException) -> return () nonEmptyMapM_ :: Monad m => (a -> m ()) -> NonEmptyList a -> m () nonEmptyMapM_ f (One x _) = f x nonEmptyMapM_ f (Cons x _ _ l) = f x >> nonEmptyMapM_ f l getSocketConn :: Maybe NS.HostAddress -> String -> Int -> Maybe SocksConf -- ^ optional socks proxy -> IO ConnInfo getSocketConn hostAddress' host' port' socksProxy' = getSocket hostAddress' host' port' socksProxy' >>= socketConn desc where desc = socketDesc host' port' "unsecured" socketDesc :: String -> Int -> String -> String socketDesc h p t = unwords [h, show p, t] getSslConn :: ([X509] -> IO CertificateUsage) -> [(X509, Maybe PrivateKey)] -> Maybe NS.HostAddress -> String -- ^ host -> Int -- ^ port -> Maybe SocksConf -- ^ optional socks proxy -> IO ConnInfo getSslConn checkCert clientCerts hostAddress' host' port' socksProxy' = connectionTo hostAddress' host' port' socksProxy' >>= sslClientConn desc host' checkCert clientCerts where desc = socketDesc host' port' "secured" getSslProxyConn :: ([X509] -> IO CertificateUsage) -> [(X509, Maybe PrivateKey)] -> S8.ByteString -- ^ Target host -> Int -- ^ Target port -> Maybe NS.HostAddress -> String -- ^ Proxy host -> Int -- ^ Proxy port -> Maybe SocksConf -- ^ optional SOCKS proxy -> IO ConnInfo getSslProxyConn checkCert clientCerts thost tport phostAddr phost pport socksProxy' = doConnect >>= sslClientConn desc phost checkCert clientCerts where desc = socketDesc phost pport "secured-proxy" doConnect = do h <- connectionTo phostAddr phost pport socksProxy' L.hPutStr h $ Blaze.toLazyByteString connectRequest hFlush h r <- hGetSome h 2048 case runException $ yield r $$ sinkHeaders of Right ((_, 200, _), _) -> return h Right ((_, _, msg), _) -> hClose h >> proxyError (Left msg) Left s -> do hClose h proxyError $ case fromException s of Just he -> Right he Nothing -> Left $ S8.pack $ show s connectRequest = Blaze.fromByteString "CONNECT " `mappend` Blaze.fromByteString thost `mappend` Blaze.fromByteString (S8.pack (':' : show tport)) `mappend` Blaze.fromByteString " HTTP/1.1\r\n\r\n" proxyError s = throwIO $ ProxyConnectException thost tport s -- | This function needs to acquire a @ConnInfo@- either from the @Manager@ or -- via I\/O, and register it with the @ResourceT@ so it is guaranteed to be -- either released or returned to the manager. getManagedConn :: MonadResource m => Manager -> ConnKey -> IO ConnInfo -> m (ConnRelease m, ConnInfo, ManagedConn) -- We want to avoid any holes caused by async exceptions, so let's mask. getManagedConn man key open = resourceMask $ \restore -> do -- Try to take the socket out of the manager. mci <- liftIO $ takeSocket man key (ci, isManaged) <- case mci of -- There wasn't a matching connection in the manager, so create a -- new one. Nothing -> do ci <- restore $ liftIO open return (ci, Fresh) -- Return the existing one Just ci -> return (ci, Reused) -- When we release this connection, we can either reuse it (put it back in -- the manager) or not reuse it (close the socket). We set up a mutable -- reference to track what we want to do. By default, we say not to reuse -- it, that way if an exception is thrown, the connection won't be reused. toReuseRef <- liftIO $ I.newIORef DontReuse -- Now register our release action. releaseKey <- register $ do toReuse <- I.readIORef toReuseRef -- Determine what action to take based on the value stored in the -- toReuseRef variable. case toReuse of Reuse -> putSocket man key ci DontReuse -> connClose ci -- When the connection is explicitly released, we update our toReuseRef to -- indicate what action should be taken, and then call release. let connRelease x = do liftIO $ I.writeIORef toReuseRef x release releaseKey return (connRelease, ci, isManaged) -- | Create an exception to be thrown if the connection for the given request -- fails. failedConnectionException :: Request m -> HttpException failedConnectionException req = FailedConnectionException host' port' where (_, host', port') = getConnDest req getConnDest :: Request m -> (Bool, String, Int) getConnDest req = case proxy req of Just p -> (True, S8.unpack (proxyHost p), proxyPort p) Nothing -> (False, S8.unpack $ host req, port req) getConn :: MonadResource m => Request m -> Manager -> m (ConnRelease m, ConnInfo, ManagedConn) getConn req m = getManagedConn m (ConnKey connKeyHost connport (secure req)) $ go connaddr connhost connport (socksProxy req) where h = host req (useProxy, connhost, connport) = getConnDest req (connaddr, connKeyHost) = case (hostAddress req, useProxy, socksProxy req) of (Just ha, False, Nothing) -> (Just ha, HostAddress ha) _ -> (Nothing, HostName $ T.pack connhost) go = case (secure req, useProxy) of (False, _) -> getSocketConn (True, False) -> getSslConn (checkCerts m h) (clientCertificates req) (True, True) -> getSslProxyConn (checkCerts m h) (clientCertificates req) h (port req) checkCerts :: Manager -> S8.ByteString -> [X509] -> IO CertificateUsage checkCerts man host' certs = do #if DEBUG putStrLn $ "checkCerts for host: " ++ show host' #endif cache <- I.readIORef $ mCertCache man case Map.lookup host' cache >>= Map.lookup encoded of Nothing -> do #if DEBUG putStrLn $ concat ["checkCerts ", show host', " no cached certs found"] #endif res <- mCheckCerts man host' certs case res of CertificateUsageAccept -> do #if DEBUG putStrLn $ concat ["checkCerts ", show host', " valid cert, adding to cache"] #endif now <- getCurrentTime -- keep it valid for 1 hour let expire = (60 * 60) `addUTCTime` now I.atomicModifyIORef (mCertCache man) $ addValidCerts expire _ -> return () return res Just _ -> do #if DEBUG putStrLn $ concat ["checkCerts ", show host', " cert already cached"] #endif return CertificateUsageAccept where encoded = L.concat $ map encodeCertificate certs addValidCerts expire cache = (Map.insert host' inner cache, ()) where inner = case Map.lookup host' cache of Nothing -> Map.singleton encoded expire Just m -> Map.insert encoded expire m connectionTo :: Maybe NS.HostAddress -> NS.HostName -> Int -> Maybe SocksConf -> IO Handle connectionTo hostAddress' host' port' socksConf' = getSocket hostAddress' host' port' socksConf' >>= flip NS.socketToHandle ReadWriteMode http-conduit-1.9.5.2/Network/HTTP/Conduit/Chunk.hs0000644000000000000000000000417012243461040017715 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} module Network.HTTP.Conduit.Chunk ( chunkedConduit , chunkIt ) where import Numeric (showHex) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Blaze.ByteString.Builder.HTTP import qualified Blaze.ByteString.Builder as Blaze import Data.Conduit import qualified Data.Conduit.Binary as CB import Control.Monad (when, unless) import Control.Exception (assert) import Data.Maybe (fromMaybe) import Network.HTTP.Conduit.Types (HttpException (InvalidChunkHeaders)) chunkedConduit :: MonadThrow m => Bool -- ^ send the headers as well, necessary for a proxy -> Conduit S.ByteString m S.ByteString chunkedConduit sendHeaders = do mi <- getLen i <- maybe (monadThrow InvalidChunkHeaders) return mi when sendHeaders $ yield $ S8.pack $ showHex i "\r\n" CB.isolate i CB.drop 2 when sendHeaders $ yield $ S8.pack "\r\n" unless (i == 0) $ chunkedConduit sendHeaders where getLen = start Nothing where start i = await >>= maybe (return i) (go i) go i bs = case S.uncons bs of Nothing -> start i Just (w, bs') -> case toI w of Just i' -> go (Just $ fromMaybe 0 i * 16 + i') bs' Nothing -> do stripNewLine bs return i stripNewLine bs = case S.uncons $ S.dropWhile (/= 10) bs of Just (10, bs') -> leftover bs' Just _ -> assert False $ await >>= maybe (return ()) stripNewLine Nothing -> await >>= maybe (return ()) stripNewLine toI w | 48 <= w && w <= 57 = Just $ fromIntegral w - 48 | 65 <= w && w <= 70 = Just $ fromIntegral w - 55 | 97 <= w && w <= 102 = Just $ fromIntegral w - 87 | otherwise = Nothing chunkIt :: Monad m => Conduit Blaze.Builder m Blaze.Builder chunkIt = await >>= maybe (yield chunkedTransferTerminator) (\x -> yield (chunkedTransferEncoding x) >> chunkIt) http-conduit-1.9.5.2/Network/HTTP/Conduit/Util.hs0000644000000000000000000000513712243461040017566 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} module Network.HTTP.Conduit.Util ( hGetSome , (<>) , readDec , hasNoBody , fromStrict ) where import Data.Monoid (Monoid, mappend) import qualified Data.ByteString.Char8 as S8 #if MIN_VERSION_bytestring(0,10,0) import Data.ByteString.Lazy (fromStrict) #else import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as S #endif import qualified Data.Text as T import qualified Data.Text.Read #if MIN_VERSION_base(4,3,0) import Data.ByteString (hGetSome) #else import GHC.IO.Handle.Types import System.IO (hWaitForInput, hIsEOF) import System.IO.Error (mkIOError, illegalOperationErrorType) -- | Like 'hGet', except that a shorter 'ByteString' may be returned -- if there are not enough bytes immediately available to satisfy the -- whole request. 'hGetSome' only blocks if there is no data -- available, and EOF has not yet been reached. hGetSome :: Handle -> Int -> IO S.ByteString hGetSome hh i | i > 0 = let loop = do s <- S.hGetNonBlocking hh i if not (S.null s) then return s else do eof <- hIsEOF hh if eof then return s else hWaitForInput hh (-1) >> loop -- for this to work correctly, the -- Handle should be in binary mode -- (see GHC ticket #3808) in loop | i == 0 = return S.empty | otherwise = illegalBufferSize hh "hGetSome" i illegalBufferSize :: Handle -> String -> Int -> IO a illegalBufferSize handle fn sz = ioError (mkIOError illegalOperationErrorType msg (Just handle) Nothing) --TODO: System.IO uses InvalidArgument here, but it's not exported :-( where msg = fn ++ ": illegal ByteString size " ++ showsPrec 9 sz [] #endif infixr 5 <> (<>) :: Monoid m => m -> m -> m (<>) = mappend readDec :: Integral i => String -> Maybe i readDec s = case Data.Text.Read.decimal $ T.pack s of Right (i, t) | T.null t -> Just i _ -> Nothing hasNoBody :: S8.ByteString -- ^ request method -> Int -- ^ status code -> Bool hasNoBody "HEAD" _ = True hasNoBody _ 204 = True hasNoBody _ 304 = True hasNoBody _ i = 100 <= i && i < 200 #if !MIN_VERSION_bytestring(0,10,0) {-# INLINE fromStrict #-} fromStrict :: S.ByteString -> L.ByteString fromStrict x = L.fromChunks [x] #endif http-conduit-1.9.5.2/Network/HTTP/Conduit/Parser.hs0000644000000000000000000000575212243461040020110 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} module Network.HTTP.Conduit.Parser ( sinkHeaders ) where import Prelude hiding (take, takeWhile) import Control.Applicative import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.Conduit (Sink, MonadThrow (monadThrow), (=$)) import Control.Monad (when, unless) import Network.HTTP.Conduit.Types (HttpException (..)) import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL type Header = (S.ByteString, S.ByteString) type Status = (S.ByteString, Int, S.ByteString) -- | New version of @sinkHeaders@ that doesn't use attoparsec. Should create -- more meaningful exceptions. -- -- Since 1.8.7 sinkHeaders :: (MonadThrow m) => Sink S.ByteString m (Status, [Header]) sinkHeaders = do status <- getStatusLine headers <- parseHeaders id return (status, headers) where getStatusLine = do -- Ensure that there is some data coming in. If not, we want to signal -- this as a connection problem and not a protocol problem. mx <- CL.peek case mx of Nothing -> monadThrow NoResponseDataReceived Just _ -> return () status@(_, code, _) <- sinkLine >>= parseStatus if code == 100 then newline ExpectedBlankAfter100Continue >> getStatusLine else return status newline exc = do line <- sinkLine unless (S.null line) $ monadThrow exc sinkLine = do bs <- fmap (killCR . S.concat) $ CB.takeWhile (/= charLF) =$ CL.consume CB.drop 1 return bs charLF = 10 charCR = 13 charSpace = 32 charColon = 58 killCR bs | S.null bs = bs | S.last bs == charCR = S.init bs | otherwise = bs parseStatus :: MonadThrow m => S.ByteString -> m Status parseStatus bs = do let (ver, bs2) = S.breakByte charSpace bs (code, bs3) = S.breakByte charSpace $ S.dropWhile (== charSpace) bs2 msg = S.dropWhile (== charSpace) bs3 case (,) <$> parseVersion ver <*> parseCode code of Just (ver', code') -> return (ver', code', msg) _ -> monadThrow $ InvalidStatusLine bs stripPrefixBS x y | x `S.isPrefixOf` y = Just $ S.drop (S.length x) y | otherwise = Nothing parseVersion = stripPrefixBS "HTTP/" parseCode bs = case S8.readInt bs of Just (i, "") -> Just i _ -> Nothing parseHeaders front = do line <- sinkLine if S.null line then return $ front [] else do header <- parseHeader line parseHeaders $ front . (header:) parseHeader :: MonadThrow m => S.ByteString -> m Header parseHeader bs = do let (key, bs2) = S.breakByte charColon bs when (S.null bs2) $ monadThrow $ InvalidHeader bs return (strip key, strip $ S.drop 1 bs2) strip = S.dropWhile (== charSpace) . fst . S.spanEnd (== charSpace) http-conduit-1.9.5.2/Network/HTTP/Conduit/MultipartFormData.hs0000644000000000000000000002135712243461040022252 0ustar0000000000000000{-# LANGUAGE CPP, OverloadedStrings #-} -- | This module handles building multipart/form-data. Example usage: -- -- > {-# LANGUAGE OverloadedStrings #-} -- > import Network -- > import Network.HTTP.Conduit -- > import Network.HTTP.Conduit.MultipartFormData -- > -- > import Data.Text.Encoding as TE -- > -- > import Control.Monad -- > -- > main = withSocketsDo $ withManager $ \m -> do -- > req1 <- parseUrl "http://random-cat-photo.net/cat.jpg" -- > res <- httpLbs req1 m -- > req2 <- parseUrl "http://example.org/~friedrich/blog/addPost.hs" -- > flip httpLbs m =<< -- > (formDataBody [partBS "title" "Bleaurgh" -- > ,partBS "text" $ TE.encodeUtf8 "矢田矢田矢田矢田矢田" -- > ,partFileSource "file1" "/home/friedrich/Photos/MyLittlePony.jpg" -- > ,partFileRequestBody "file2" "cat.jpg" $ RequestBodyLBS $ responseBody res] -- > req2) module Network.HTTP.Conduit.MultipartFormData ( -- * Part type Part(..) -- * Constructing parts ,partBS ,partLBS ,partFile ,partFileSource ,partFileSourceChunked ,partFileRequestBody ,partFileRequestBodyM -- * Building form data ,formDataBody ,formDataBodyPure ,formDataBodyWithBoundary -- * Boundary ,webkitBoundary ,webkitBoundaryPure -- * Misc ,renderParts ,renderPart ) where import Network.HTTP.Conduit.Request import Network.HTTP.Conduit.Util import Network.Mime import Network.HTTP.Types (hContentType, methodPost) import Blaze.ByteString.Builder import qualified Data.Conduit.List as CL import qualified Data.Conduit.Binary as CB import Data.Conduit import Data.Text import qualified Data.Text.Encoding as TE import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString as BS import Control.Monad.Trans.State.Strict (state, runState) import Control.Monad.IO.Class import System.FilePath import System.Random import Data.Array.Base import System.IO import Data.Bits import Data.Word import Data.Functor.Identity import Data.Monoid (Monoid(..)) import Control.Monad -- | A single part of a multipart message. data Part m m' = Part { partName :: Text -- ^ Name of the corresponding \ , partFilename :: Maybe String -- ^ A file name, if this is an attached file , partContentType :: Maybe MimeType -- ^ Content type , partGetBody :: m (RequestBody m') -- ^ Action in m which returns the body -- of a message. } instance Show (Part m m') where showsPrec d (Part n f c _) = showParen (d>=11) $ showString "Part " . showsPrec 11 n . showString " " . showsPrec 11 f . showString " " . showsPrec 11 c . showString " " . showString "" partBS :: (Monad m, Monad m') => Text -> BS.ByteString -> Part m m' partBS n b = Part n mempty mempty $ return $ RequestBodyBS b partLBS :: (Monad m, Monad m') => Text -> BL.ByteString -> Part m m' partLBS n b = Part n mempty mempty $ return $ RequestBodyLBS b -- | Make a 'Part' from a file, the entire file will reside in memory at once. -- If you want constant memory usage use 'partFileSource' partFile :: (MonadIO m, Monad m') => Text -> FilePath -> Part m m' partFile n f = partFileRequestBodyM n f $ do liftM RequestBodyBS $ liftIO $ BS.readFile f -- | Stream 'Part' from a file. partFileSource :: (MonadIO m, MonadResource m') => Text -> FilePath -> Part m m' partFileSource n f = partFileRequestBodyM n f $ do size <- liftIO $ withBinaryFile f ReadMode hFileSize return $ RequestBodySource (fromInteger size) $ CB.sourceFile f $= CL.map fromByteString -- | 'partFileSourceChunked' will read a file and send it in chunks. -- -- Note that not all servers support this. Only use 'partFileSourceChunked' -- if you know the server you're sending to supports chunked request bodies. partFileSourceChunked :: (Monad m, MonadResource m') => Text -> FilePath -> Part m m' partFileSourceChunked n f = partFileRequestBody n f $ do RequestBodySourceChunked $ CB.sourceFile f $= CL.map fromByteString -- | Construct a 'Part' from form name, filepath and a 'RequestBody' -- -- > partFileRequestBody "who_calls" "caller.json" $ RequestBodyBS "{\"caller\":\"Jason J Jason\"}" -- -- > -- empty upload form -- > partFileRequestBody "file" mempty mempty partFileRequestBody :: (Monad m, Monad m') => Text -> FilePath -> RequestBody m' -> Part m m' partFileRequestBody n f rqb = partFileRequestBodyM n f $ return rqb -- | Construct a 'Part' from action returning the 'RequestBody' -- -- > partFileRequestBodyM "cat_photo" "haskell-the-cat.jpg" $ do -- > size <- fromInteger <$> withBinaryFile "haskell-the-cat.jpg" ReadMode hFileSize -- > return $ RequestBodySource size $ CB.sourceFile "haskell-the-cat.jpg" $= CL.map fromByteString partFileRequestBodyM :: Monad m' => Text -> FilePath -> m (RequestBody m') -> Part m m' partFileRequestBodyM n f rqb = Part n (Just f) (Just $ defaultMimeLookup $ pack f) rqb {-# INLINE cp #-} cp :: BS.ByteString -> RequestBody m cp bs = RequestBodyBuilder (fromIntegral $ BS.length bs) $ copyByteString bs renderPart :: (Monad m, Monad m') => BS.ByteString -> Part m m' -> m (RequestBody m') renderPart boundary (Part name mfilename mcontenttype get) = liftM render get where render renderBody = cp "--" <> cp boundary <> cp "\r\n" <> cp "Content-Disposition: form-data; name=\"" <> RequestBodyBS (TE.encodeUtf8 name) <> (case mfilename of Just f -> cp "\"; filename=\"" <> RequestBodyBS (TE.encodeUtf8 $ pack $ takeFileName f) _ -> mempty) <> cp "\"" <> (case mcontenttype of Just ct -> cp "\r\n" <> cp "Content-Type: " <> cp ct _ -> mempty) <> cp "\r\n\r\n" <> renderBody <> cp "\r\n" -- | Combine the 'Part's to form multipart/form-data body renderParts :: (Monad m, Monad m') => BS.ByteString -> [Part m m'] -> m (RequestBody m') renderParts boundary parts = (fin . mconcat) `liftM` mapM (renderPart boundary) parts where fin = (<> cp "--" <> cp boundary <> cp "--\r\n") -- | Generate a boundary simillar to those generated by WebKit-based browsers. webkitBoundary :: IO BS.ByteString webkitBoundary = getStdRandom webkitBoundaryPure webkitBoundaryPure :: RandomGen g => g -> (BS.ByteString, g) webkitBoundaryPure g = (`runState` g) $ do fmap (BS.append prefix . BS.pack . Prelude.concat) $ replicateM 4 $ do randomness <- state $ random return [unsafeAt alphaNumericEncodingMap $ randomness `shiftR` 24 .&. 0x3F ,unsafeAt alphaNumericEncodingMap $ randomness `shiftR` 16 .&. 0x3F ,unsafeAt alphaNumericEncodingMap $ randomness `shiftR` 8 .&. 0x3F ,unsafeAt alphaNumericEncodingMap $ randomness .&. 0x3F] where prefix = "----WebKitFormBoundary" alphaNumericEncodingMap :: UArray Int Word8 alphaNumericEncodingMap = listArray (0, 63) [0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0x4A, 0x4B, 0x4C, 0x4D, 0x4E, 0x4F, 0x50, 0x51, 0x52, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59, 0x5A, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F, 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0x41, 0x42] -- | Add form data to the 'Request'. -- -- This sets a new 'requestBody', adds a content-type request header and changes the method to POST. formDataBody :: (MonadIO m, Monad m') => [Part m m'] -> Request m' -> m (Request m') formDataBody a b = do boundary <- liftIO webkitBoundary formDataBodyWithBoundary boundary a b -- | Add form data to request without doing any IO. Your form data should only -- contain pure parts ('partBS', 'partLBS', 'partFileRequestBody'). You'll have -- to supply your own boundary (for example one generated by 'webkitBoundary') formDataBodyPure :: Monad m => BS.ByteString -> [Part Identity m] -> Request m -> Request m formDataBodyPure = \boundary parts req -> runIdentity $ formDataBodyWithBoundary boundary parts req -- | Add form data with supplied boundary formDataBodyWithBoundary :: (Monad m, Monad m') => BS.ByteString -> [Part m m'] -> Request m' -> m (Request m') formDataBodyWithBoundary boundary parts req = do body <- renderParts boundary parts return $ req { method = methodPost , requestHeaders = (hContentType, "multipart/form-data; boundary=" <> boundary) : Prelude.filter (\(x, _) -> x /= hContentType) (requestHeaders req) , requestBody = body } http-conduit-1.9.5.2/Network/HTTP/Conduit/Types.hs0000644000000000000000000003065412243461040017757 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} module Network.HTTP.Conduit.Types ( Request (..) , RequestBody (..) , ContentType , Proxy (..) , HttpException (..) , Response (..) , ConnRelease , ConnReuse (..) , ManagedConn (..) , Cookie (..) , CookieJar (..) ) where import Data.Int (Int64) import Data.Word (Word64) import Data.Typeable (Typeable) import Blaze.ByteString.Builder import qualified Data.Conduit as C import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.Time.Clock import Data.Default import qualified Data.List as DL import qualified Network.HTTP.Types as W import qualified Network.Socket as NS import Network.Socks5 (SocksConf) import Control.Exception (Exception, SomeException, IOException) import Data.Certificate.X509 (X509) import Network.TLS (PrivateKey) import Network.HTTP.Conduit.ConnInfo (ConnInfo) import Network.HTTP.Conduit.Util import Data.Monoid (Monoid(..)) type ContentType = S.ByteString -- | All information on how to connect to a host and what should be sent in the -- HTTP request. -- -- If you simply wish to download from a URL, see 'parseUrl'. -- -- The constructor for this data type is not exposed. Instead, you should use -- either the 'def' method to retrieve a default instance, or 'parseUrl' to -- construct from a URL, and then use the records below to make modifications. -- This approach allows http-conduit to add configuration options without -- breaking backwards compatibility. -- -- For example, to construct a POST request, you could do something like: -- -- > initReq <- parseUrl "http://www.example.com/path" -- > let req = initReq -- > { method = "POST" -- > } -- -- For more information, please see -- . data Request m = Request { method :: W.Method -- ^ HTTP request method, eg GET, POST. , secure :: Bool -- ^ Whether to use HTTPS (ie, SSL). , clientCertificates :: [(X509, Maybe PrivateKey)] -- ^ SSL client certificates , host :: S.ByteString , port :: Int , path :: S.ByteString -- ^ Everything from the host to the query string. , queryString :: S.ByteString , requestHeaders :: W.RequestHeaders -- ^ Custom HTTP request headers -- -- As already stated in the introduction, the Content-Length and Host -- headers are set automatically by this module, and shall not be added to -- requestHeaders. -- -- Moreover, the Accept-Encoding header is set implicitly to gzip for -- convenience by default. This behaviour can be overridden if needed, by -- setting the header explicitly to a different value. In order to omit the -- Accept-Header altogether, set it to the empty string \"\". If you need an -- empty Accept-Header (i.e. requesting the identity encoding), set it to a -- non-empty white-space string, e.g. \" \". See RFC 2616 section 14.3 for -- details about the semantics of the Accept-Header field. If you request a -- content-encoding not supported by this module, you will have to decode -- it yourself (see also the 'decompress' field). -- -- Note: Multiple header fields with the same field-name will result in -- multiple header fields being sent and therefore it\'s the responsibility -- of the client code to ensure that the rules from RFC 2616 section 4.2 -- are honoured. , requestBody :: RequestBody m , proxy :: Maybe Proxy -- ^ Optional HTTP proxy. , socksProxy :: Maybe SocksConf -- ^ Optional SOCKS proxy. , hostAddress :: Maybe NS.HostAddress -- ^ Optional resolved host address. -- -- Since 1.8.9 , rawBody :: Bool -- ^ If @True@, a chunked and\/or gzipped body will not be -- decoded. Use with caution. , decompress :: ContentType -> Bool -- ^ Predicate to specify whether gzipped data should be -- decompressed on the fly (see 'alwaysDecompress' and -- 'browserDecompress'). Default: browserDecompress. , redirectCount :: Int -- ^ How many redirects to follow when getting a resource. 0 means follow -- no redirects. Default value: 10. , checkStatus :: W.Status -> W.ResponseHeaders -> CookieJar -> Maybe SomeException -- ^ Check the status code. Note that this will run after all redirects are -- performed. Default: return a @StatusCodeException@ on non-2XX responses. , responseTimeout :: Maybe Int -- ^ Number of microseconds to wait for a response. If @Nothing@, will wait -- indefinitely. Default: 5 seconds. , getConnectionWrapper :: forall n. (C.MonadResource n, C.MonadBaseControl IO n) => Maybe Int -> HttpException -> n (ConnRelease n, ConnInfo, ManagedConn) -> n (Maybe Int, (ConnRelease n, ConnInfo, ManagedConn)) -- ^ Wraps the calls for getting new connections. This can be useful for -- instituting some kind of timeouts. The first argument is the value of -- @responseTimeout@. Second argument is the exception to be thrown on -- failure. -- -- Default: If @responseTimeout@ is @Nothing@, does nothing. Otherwise, -- institutes timeout, and returns remaining time for @responseTimeout@. -- -- Since 1.8.8 , cookieJar :: Maybe CookieJar -- ^ A user-defined cookie jar. -- If 'Nothing', no cookie handling will take place, \"Cookie\" headers -- in 'requestHeaders' will be sent raw, and 'responseCookieJar' will be -- empty. -- -- Since 1.9.0 } data ConnReuse = Reuse | DontReuse type ConnRelease m = ConnReuse -> m () data ManagedConn = Fresh | Reused -- | When using one of the -- 'RequestBodySource' \/ 'RequestBodySourceChunked' constructors, -- you must ensure -- that the 'Source' can be called multiple times. Usually this -- is not a problem. -- -- The 'RequestBodySourceChunked' will send a chunked request -- body, note that not all servers support this. Only use -- 'RequestBodySourceChunked' if you know the server you're -- sending to supports chunked request bodies. data RequestBody m = RequestBodyLBS L.ByteString | RequestBodyBS S.ByteString | RequestBodyBuilder Int64 Builder | RequestBodySource Int64 (C.Source m Builder) | RequestBodySourceChunked (C.Source m Builder) -- | Define a HTTP proxy, consisting of a hostname and port number. data Proxy = Proxy { proxyHost :: S.ByteString -- ^ The host name of the HTTP proxy. , proxyPort :: Int -- ^ The port number of the HTTP proxy. } deriving (Show, Read, Eq, Ord, Typeable) data HttpException = StatusCodeException W.Status W.ResponseHeaders CookieJar | InvalidUrlException String String | TooManyRedirects [Response L.ByteString] -- ^ List of encountered responses containing redirects in reverse chronological order; including last redirect, which triggered the exception and was not followed. | UnparseableRedirect (Response L.ByteString) -- ^ Response containing unparseable redirect. | TooManyRetries | HttpParserException String | HandshakeFailed | OverlongHeaders | ResponseTimeout | FailedConnectionException String Int -- ^ host/port | ExpectedBlankAfter100Continue | InvalidStatusLine S.ByteString | InvalidHeader S.ByteString | InternalIOException IOException | ProxyConnectException S.ByteString Int (Either S.ByteString HttpException) -- ^ host/port | NoResponseDataReceived | TlsException SomeException | ResponseBodyTooShort Word64 Word64 -- ^ Expected size/actual size. -- -- Since 1.9.4 | InvalidChunkHeaders -- ^ -- -- Since 1.9.4 deriving (Show, Typeable) instance Exception HttpException -- | A simple representation of the HTTP response created by 'lbsConsumer'. data Response body = Response { responseStatus :: W.Status -- ^ Status code of the response. , responseVersion :: W.HttpVersion -- ^ HTTP version used by the server. , responseHeaders :: W.ResponseHeaders -- ^ Response headers sent by the server. , responseBody :: body -- ^ Response body sent by the server. , responseCookieJar :: CookieJar -- ^ Cookies set on the client after interacting with the server. If -- cookies have been disabled by setting 'cookieJar' to @Nothing@, then -- this will always be empty. } deriving (Show, Eq, Typeable) -- This corresponds to the description of a cookie detailed in Section 5.3 \"Storage Model\" data Cookie = Cookie { cookie_name :: S.ByteString , cookie_value :: S.ByteString , cookie_expiry_time :: UTCTime , cookie_domain :: S.ByteString , cookie_path :: S.ByteString , 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 (Read, Show) newtype CookieJar = CJ { expose :: [Cookie] } deriving (Read, 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 | S.length (cookie_path c1) > S.length (cookie_path c2) = LT | S.length (cookie_path c1) < S.length (cookie_path c2) = GT | cookie_creation_time c1 > cookie_creation_time c2 = GT | otherwise = LT instance Default CookieJar where def = CJ [] instance Eq CookieJar where (==) cj1 cj2 = (DL.sort $ expose cj1) == (DL.sort $ expose cj2) -- | Since 1.9 instance Monoid CookieJar where mempty = def (CJ a) `mappend` (CJ b) = CJ (DL.nub $ DL.sortBy compare' $ a `mappend` b) where compare' c1 c2 = -- inverse so that recent cookies are kept by nub over older if cookie_creation_time c1 > cookie_creation_time c2 then LT else GT -- | Since 1.1.2. instance Functor Response where fmap f response = response {responseBody = f (responseBody response)} -- | Since 1.8.7 instance Show (RequestBody m) where showsPrec d (RequestBodyBS a) = showParen (d>=11) $ showString "RequestBodyBS " . showsPrec 11 a showsPrec d (RequestBodyLBS a) = showParen (d>=11) $ showString "RequestBodyLBS " . showsPrec 11 a showsPrec d (RequestBodyBuilder l _) = showParen (d>=11) $ showString "RequestBodyBuilder " . showsPrec 11 l . showString " " . showString "" showsPrec d (RequestBodySource l _) = showParen (d>=11) $ showString "RequestBodySource " . showsPrec 11 l . showString " " showsPrec d (RequestBodySourceChunked _) = showParen (d>=11) $ showString "RequestBodySource " -- | Since 1.8.7 instance Monad m => Monoid (RequestBody m) where mempty = RequestBodyLBS mempty mappend a b = case (simplify a, simplify b) of (SBuilder l1 b1, SBuilder l2 b2) -> RequestBodyBuilder (l1 + l2) (b1 <> b2) (SBuilder l1 b1, SSource l2 s2) -> RequestBodySource (l1 + l2) (C.yield b1 <> s2) (SSource l1 s1, SBuilder l2 b2) -> RequestBodySource (l1 + l2) (s1 <> C.yield b2) (SSource l1 s1, SSource l2 s2) -> RequestBodySource (l1 + l2) (s1 <> s2) (a', b') -> RequestBodySourceChunked (toChunked a' <> toChunked b') data Simplified m = SBuilder Int64 Builder | SSource Int64 (C.Source m Builder) | SChunked (C.Source m Builder) simplify :: Monad m => RequestBody m -> Simplified m simplify (RequestBodyBS a) = SBuilder (fromIntegral $ S.length a) (fromByteString a) simplify (RequestBodyLBS a) = SBuilder (fromIntegral $ L.length a) (fromLazyByteString a) simplify (RequestBodyBuilder l a) = SBuilder l a simplify (RequestBodySource l a) = SSource l a simplify (RequestBodySourceChunked a) = SChunked a toChunked :: Monad m => Simplified m -> C.Source m Builder toChunked (SBuilder _ b) = C.yield b toChunked (SSource _ s) = s toChunked (SChunked s) = s http-conduit-1.9.5.2/Network/HTTP/Conduit/ConnInfo.hs0000644000000000000000000001350312243461040020356 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-} module Network.HTTP.Conduit.ConnInfo ( ConnInfo , connClose , connSink , connSource , sslClientConn , socketConn , CertificateRejectReason(..) , CertificateUsage(..) , getSocket #if DEBUG , printOpenSockets , requireAllSocketsClosed , clearSocketsList #endif ) where import Control.Exception (IOException, bracketOnError, throwIO) import qualified Control.Exception as E import System.IO (Handle, hClose) import Control.Monad.IO.Class (liftIO) import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Network (PortID(..)) import Network.Socket (Socket, sClose, AddrInfo) import Network.Socket.ByteString (recv, sendAll) import qualified Network.Socket as NS import Network.Socks5 (socksConnectWith, SocksConf) import Network.TLS import Network.TLS.Extra (ciphersuite_all) import Data.Certificate.X509 (X509) import Crypto.Random.AESCtr (makeSystem) import Data.Conduit #if DEBUG import qualified Data.IntMap as IntMap import qualified Data.IORef as I import System.IO.Unsafe (unsafePerformIO) #endif data ConnInfo = ConnInfo { connRead :: IO ByteString , connWrite :: ByteString -> IO () , connClose :: IO () } connSink :: MonadResource m => ConnInfo -> Sink ByteString m () connSink ConnInfo { connWrite = write } = self where self = await >>= maybe (return ()) (\x -> liftIO (write x) >> self) connSource :: MonadResource m => ConnInfo -> Source m ByteString connSource ConnInfo { connRead = read' } = self where self = do bs <- liftIO read' if S.null bs then return () else yield bs >> self #if DEBUG allOpenSockets :: I.IORef (Int, IntMap.IntMap String) allOpenSockets = unsafePerformIO $ I.newIORef (0, IntMap.empty) addSocket :: String -> IO Int addSocket desc = I.atomicModifyIORef allOpenSockets $ \(next, m) -> ((next + 1, IntMap.insert next desc m), next) removeSocket :: Int -> IO () removeSocket i = I.atomicModifyIORef allOpenSockets $ \(next, m) -> ((next, IntMap.delete i m), ()) printOpenSockets :: IO () printOpenSockets = do (_, m) <- I.readIORef allOpenSockets putStrLn "\n\nOpen sockets:" if IntMap.null m then putStrLn "** No open sockets!" else mapM_ putStrLn $ IntMap.elems m requireAllSocketsClosed :: IO () requireAllSocketsClosed = do (_, m) <- I.readIORef allOpenSockets if IntMap.null m then return () else error $ unlines $ "requireAllSocketsClosed: there are open sockets" : IntMap.elems m clearSocketsList :: IO () clearSocketsList = I.writeIORef allOpenSockets (0, IntMap.empty) #endif socketConn :: String -> Socket -> IO ConnInfo socketConn _desc sock = do #if DEBUG i <- addSocket _desc #endif return ConnInfo { connRead = recv sock 4096 , connWrite = sendAll sock , connClose = do #if DEBUG removeSocket i #endif sClose sock } sslClientConn :: String -> String -> ([X509] -> IO CertificateUsage) -> [(X509, Maybe PrivateKey)] -> Handle -> IO ConnInfo sslClientConn _desc host onCerts clientCerts h = do #if DEBUG i <- addSocket _desc #endif let setCParams cparams = cparams { onCertificateRequest = const (return clientCerts) , clientUseServerName = Just host } tcp = updateClientParams setCParams $ defaultParamsClient { pConnectVersion = TLS10 , pAllowedVersions = [ TLS10, TLS11, TLS12 ] , pCiphers = ciphersuite_all , onCertificatesRecv = onCerts , pCertificates = clientCerts } gen <- makeSystem istate <- contextNewOnHandle h tcp gen handshake istate return ConnInfo { connRead = recvD istate , connWrite = sendData istate . L.fromChunks . (:[]) , connClose = do #if DEBUG removeSocket i #endif bye istate `E.finally` hClose h } where recvD istate = E.handle onEOF $ do x <- recvData istate if S.null x then recvD istate else return x onEOF Error_EOF = return S.empty onEOF e = throwIO e getSocket :: Maybe NS.HostAddress -> String -> Int -> Maybe SocksConf -> IO NS.Socket getSocket _ host' port' (Just socksConf) = do socksConnectWith socksConf host' (PortNumber $ fromIntegral port') getSocket hostAddress' host' port' Nothing = do let hints = NS.defaultHints { NS.addrFlags = [NS.AI_ADDRCONFIG] , NS.addrSocketType = NS.Stream } addrs <- case hostAddress' of Nothing -> NS.getAddrInfo (Just hints) (Just host') (Just $ show port') Just ha -> return [NS.AddrInfo { NS.addrFlags = [] , NS.addrFamily = NS.AF_INET , NS.addrSocketType = NS.Stream , NS.addrProtocol = 6 -- tcp , NS.addrAddress = NS.SockAddrInet (toEnum port') ha , NS.addrCanonName = Nothing }] firstSuccessful addrs $ \addr -> bracketOnError (NS.socket (NS.addrFamily addr) (NS.addrSocketType addr) (NS.addrProtocol addr)) (NS.sClose) (\sock -> do NS.setSocketOption sock NS.NoDelay 1 NS.connect sock (NS.addrAddress addr) return sock) firstSuccessful :: [AddrInfo] -> (AddrInfo -> IO a) -> IO a firstSuccessful [] _ = error "getAddrInfo returned empty list" firstSuccessful (a:as) cb = cb a `E.catch` \(e :: IOException) -> case as of [] -> throwIO e _ -> firstSuccessful as cb