http-conduit 1.9.6 → 2.0.0
raw patch · 17 files changed
+165/−2668 lines, 17 filesdep +connectiondep +http-clientdep +http-client-conduitdep −network-bytestringdep ~arraydep ~asn1-datadep ~base64-bytestring
Dependencies added: connection, http-client, http-client-conduit, http-client-multipart, http-client-tls, http-conduit, warp-tls
Dependencies removed: network-bytestring
Dependency ranges changed: array, asn1-data, base64-bytestring, blaze-builder, blaze-builder-conduit, case-insensitive, certificate, containers, cookie, cprng-aes, failure, mime-types, monad-control, network, publicsuffixlist, socks, tls, tls-extra, transformers-base, utf8-string, void, wai, warp, zlib-conduit
Files
- Network/HTTP/Conduit.hs +54/−199
- Network/HTTP/Conduit/Chunk.hs +0/−66
- Network/HTTP/Conduit/ConnInfo.hs +0/−199
- Network/HTTP/Conduit/Cookies.hs +0/−233
- Network/HTTP/Conduit/Internal.hs +0/−101
- Network/HTTP/Conduit/Manager.hs +0/−518
- Network/HTTP/Conduit/MultipartFormData.hs +0/−221
- Network/HTTP/Conduit/Parser.hs +0/−95
- Network/HTTP/Conduit/Request.hs +0/−340
- Network/HTTP/Conduit/Response.hs +0/−207
- Network/HTTP/Conduit/Types.hs +0/−319
- Network/HTTP/Conduit/Util.hs +0/−84
- certificate.pem +15/−0
- http-conduit.cabal +16/−63
- key.pem +15/−0
- test/CookieTest.hs +2/−3
- test/main.hs +63/−20
Network/HTTP/Conduit.hs view
@@ -1,7 +1,6 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-} -- | 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@@ -118,10 +117,8 @@ , RequestBody (..) -- ** Request , Request- , def , method , secure- , clientCertificates , host , port , path@@ -129,7 +126,6 @@ , requestHeaders , requestBody , proxy- , socksProxy , hostAddress , rawBody , decompress@@ -138,6 +134,11 @@ , responseTimeout , cookieJar , getConnectionWrapper+ -- *** Request body+ , requestBodySource+ , requestBodySourceChunked+ , requestBodySourceIO+ , requestBodySourceChunkedIO -- * Response , Response , responseStatus@@ -154,12 +155,10 @@ -- ** Settings , ManagerSettings , conduitManagerSettings+ , mkManagerSettings , managerConnCount- , managerCheckCerts- , managerCertStore , managerResponseTimeout- -- *** Defaults- , defaultCheckCerts+ , managerTlsConnection -- * Cookies , Cookie(..) , CookieJar@@ -180,173 +179,34 @@ , 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+import qualified Data.ByteString.Lazy as L - responseTimeout' req- | rt == useDefaultTimeout = mResponseTimeout m- | otherwise = rt- where- rt = responseTimeout req+import Control.Applicative ((<$>))+import Control.Exception.Lifted (bracket)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.Trans.Resource - -- 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+import qualified Network.HTTP.Client as Client (httpLbs)+import Network.HTTP.Client.Conduit+import Network.HTTP.Client.Internal (createCookieJar,+ destroyCookieJar)+import Network.HTTP.Client.Internal (Manager, ManagerSettings,+ closeManager, managerConnCount,+ managerResponseTimeout,+ managerTlsConnection, newManager)+import Network.HTTP.Client (parseUrl, urlEncodedBody, applyBasicAuth)+import Network.HTTP.Client.Internal (addProxy, alwaysDecompress,+ browserDecompress)+import Network.HTTP.Client.Internal (getRedirectedRequest,+ lbsResponse)+import Network.HTTP.Client.TLS (mkManagerSettings,+ tlsManagerSettings)+import Network.HTTP.Client.Internal (Cookie (..), CookieJar (..),+ HttpException (..), Proxy (..),+ Request (..), RequestBody (..),+ Response (..)) -- | Download the specified 'Request', returning the results as a 'Response'. --@@ -365,26 +225,8 @@ -- -- 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+httpLbs :: MonadIO m => Request -> Manager -> m (Response L.ByteString)+httpLbs r m = liftIO $ Client.httpLbs r m -- | Download the specified URL, following any redirects, and -- return the response body.@@ -406,9 +248,22 @@ req <- liftIO $ parseUrl url responseBody <$> httpLbs (setConnectionClose req) man -setConnectionClose :: Request m -> Request m-setConnectionClose req = req{requestHeaders = ("Connection", "close") : requestHeaders req}---- | Since 1.9.6 conduitManagerSettings :: ManagerSettings-conduitManagerSettings = def+conduitManagerSettings = tlsManagerSettings++withManager :: (MonadIO m, MonadBaseControl IO m)+ => (Manager -> ResourceT m a)+ -> m a+withManager = withManagerSettings conduitManagerSettings++withManagerSettings :: (MonadIO m, MonadBaseControl IO m)+ => ManagerSettings+ -> (Manager -> ResourceT m a)+ -> m a+withManagerSettings set f = bracket+ (liftIO $ newManager set)+ (liftIO . closeManager)+ (runResourceT . f)++setConnectionClose :: Request -> Request+setConnectionClose req = req{requestHeaders = ("Connection", "close") : requestHeaders req}
− Network/HTTP/Conduit/Chunk.hs
@@ -1,66 +0,0 @@-{-# 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)
− Network/HTTP/Conduit/ConnInfo.hs
@@ -1,199 +0,0 @@-{-# 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) `E.catch`- \(_ :: E.IOException) -> return ()- }- 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
− Network/HTTP/Conduit/Cookies.hs
@@ -1,233 +0,0 @@--- | 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)
− Network/HTTP/Conduit/Internal.hs
@@ -1,101 +0,0 @@-{-# 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
− Network/HTTP/Conduit/Manager.hs
@@ -1,518 +0,0 @@-{-# 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, IOException)-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` \(_::IOException) -> 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
− Network/HTTP/Conduit/MultipartFormData.hs
@@ -1,221 +0,0 @@-{-# 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 \<input\>- , 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 "<m (RequestBody m)>"--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- }
− Network/HTTP/Conduit/Parser.hs
@@ -1,95 +0,0 @@-{-# 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)
− Network/HTTP/Conduit/Request.hs
@@ -1,340 +0,0 @@-{-# 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"
− Network/HTTP/Conduit/Response.hs
@@ -1,207 +0,0 @@-{-# 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
− Network/HTTP/Conduit/Types.hs
@@ -1,319 +0,0 @@-{-# 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--- <http://www.yesodweb.com/book/settings-types>.-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 "<Builder>"- showsPrec d (RequestBodySource l _) =- showParen (d>=11) $ showString "RequestBodySource " . showsPrec 11 l .- showString " <Source m Builder>"- showsPrec d (RequestBodySourceChunked _) =- showParen (d>=11) $ showString "RequestBodySource <Source m Builder>"---- | 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
− Network/HTTP/Conduit/Util.hs
@@ -1,84 +0,0 @@-{-# 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
+ certificate.pem view
@@ -0,0 +1,15 @@+-----BEGIN CERTIFICATE-----+MIICWDCCAcGgAwIBAgIJAJG1ZMlcMDW6MA0GCSqGSIb3DQEBBQUAMEUxCzAJBgNV+BAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5ldCBX+aWRnaXRzIFB0eSBMdGQwHhcNMTExMDIyMTk0MjU3WhcNMTExMTIxMTk0MjU3WjBF+MQswCQYDVQQGEwJBVTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50+ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKB+gQCfYZx7kV6ybogMyAf9MINm7Rwin5LKh+TpD1ZkbLgmqFVotQCdthgTK66SPXkx+EXGI27biNzacJhX7Ml7/4o8sp2GslYKUO46DYvgi/nnNX/bzA5cDJSSGK11eQEVs++p0GEZ/6Juhpx/oQwMDMgo0UHkiH8QtKI8ojXnFF2MsLNwIDAQABo1AwTjAdBgNV+HQ4EFgQUaA6FbOj/0VJMb4egNyIDZ/ZNV/YwHwYDVR0jBBgwFoAUaA6FbOj/0VJM+b4egNyIDZ/ZNV/YwDAYDVR0TBAUwAwEB/zANBgkqhkiG9w0BAQUFAAOBgQCTQyOk+D86Z+yzedXjTLI6FT8QugmQne1YQ8P0w37P76z2reagSvNee2e9B1oTHoPeKZMs0+k99oS9yJ/NOQ1Ms90P+q0yBVGxAs/gF65qKgE27YGXzNtNobj/D4OoxcFG+BsORw+VvYSBV4FiVy9RwJsr7AMqkUBcOEPCuJHgTx58w==+-----END CERTIFICATE-----
http-conduit.cabal view
@@ -1,5 +1,5 @@ name: http-conduit-version: 1.9.6+version: 2.0.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -18,79 +18,27 @@ , test/CookieTest.hs , multipart-example.bin , nyan.gif--flag network-bytestring- default: False--flag tls_1_1_3- default: True+ , certificate.pem+ , key.pem 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+ , http-client >= 0.2+ , http-client-tls+ , http-client-conduit 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+ main-is: main.hs type: exitcode-stdio-1.0- hs-source-dirs: ., test+ hs-source-dirs: test ghc-options: -Wall cpp-options: -DDEBUG@@ -121,8 +69,9 @@ , lifted-base , time , network- , wai < 2.0- , warp >= 1.3.6+ , wai >= 2.0 && < 2.1+ , warp >= 2.0 && < 2.1+ , warp-tls , socks , http-types , cookie@@ -137,7 +86,11 @@ , random , filepath , mime-types+ , http-client+ , http-conduit+ , connection+ , http-client-multipart source-repository head type: git- location: git://github.com/snoyberg/http-conduit.git+ location: git://github.com/snoyberg/http-client.git
+ key.pem view
@@ -0,0 +1,15 @@+-----BEGIN RSA PRIVATE KEY-----+MIICXAIBAAKBgQCfYZx7kV6ybogMyAf9MINm7Rwin5LKh+TpD1ZkbLgmqFVotQCd+thgTK66SPXkxEXGI27biNzacJhX7Ml7/4o8sp2GslYKUO46DYvgi/nnNX/bzA5cD+JSSGK11eQEVs+p0GEZ/6Juhpx/oQwMDMgo0UHkiH8QtKI8ojXnFF2MsLNwIDAQAB+AoGAR8pgAgjo7tZ60ccIUjOX/LSxB6d5J2Eu6wvNjk6qZD9OuWtOa7up/HigmZ63+CDMjQNI2/o6AOrWtEQkPYZNbibuifzg5V517nHGSqkqjoIgesAiwEsoKpeOgGTtM+MM08oHbJ9uOnDnEEnDBiE0iE3jCTDfmwjqDMpUhu9dZ1EAECQQDKVpzSSV3pzMOp+ixNxMpYxzcE+4K9jgM+MlxPBJSQhVrg/cRQWb26cKBi8LdSxF23hQTsFr+8qLwid+Ah2AgUOBAkEAyaaCjrNRCiHRpd6YzWZ6GKkxbUvxSuOKX3N7hDaE2OFzQTv2Li8B+5mrCsXnSZtOG+MBFdHU66UYie1OzDSDKtwJAKMsvkOID0ihbZmpIwDC/wUjHZkLs+eXY14hVvgShY0XPnb7r/nspWlZsr6Xyf/hhIKfr5yFrBMFMNPIJ5qjflgQJAWsyV+YTgxN4S+6BdxapvIQq58ySA3CGeo+Q4BAimibB4oTal4UpdsHZrZDB00toRs9Dlv+jN70pfGkuS+ZIkIvxQJBAKSf5qpXWp4oZcThkieAiMeAhG96xqRPXhPUxq6QF+YG+T4PF1sjlpZwqy7C+2oF3BqLP09mCW7YkH9Jgnl1zDF8=+-----END RSA PRIVATE KEY-----
test/CookieTest.hs view
@@ -4,8 +4,7 @@ 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 Network.HTTP.Client import qualified Network.HTTP.Conduit as HC import Data.ByteString.UTF8 import Data.Monoid@@ -15,7 +14,7 @@ import qualified Data.CaseInsensitive as CI import Web.Cookie -default_request :: HC.Request m+default_request :: HC.Request default_request = fromJust $ HC.parseUrl "http://www.google.com/" default_cookie :: Cookie
test/main.hs view
@@ -10,13 +10,12 @@ import Network.Wai.Handler.Warp (runSettings, defaultSettings, settingsPort, settingsBeforeMainLoop) import Network.HTTP.Conduit hiding (port) import qualified Network.HTTP.Conduit as NHC-import Network.HTTP.Conduit.MultipartFormData+import Network.HTTP.Client.MultipartFormData import Control.Concurrent (forkIO, killThread, putMVar, takeMVar, newEmptyMVar, threadDelay) import Network.HTTP.Types import Control.Exception.Lifted (try, SomeException, bracket, onException, IOException) import qualified Data.IORef as I import qualified Control.Exception as E (catch)-import Network.HTTP.Conduit.ConnInfo import Network (withSocketsDo) import Network.Socket (sClose) import qualified Network.BSD@@ -24,7 +23,7 @@ import Data.Conduit.Network (runTCPServer, serverSettings, HostPreference (..), appSink, appSource, bindPort, serverAfterBind, ServerSettings) import qualified Data.Conduit.Network import System.IO.Unsafe (unsafePerformIO)-import Data.Conduit (($$), yield, Flush (Chunk, Flush), runResourceT, await)+import Data.Conduit (($$), ($$+-), yield, Flush (Chunk, Flush), await) import Control.Monad (void, forever) import Control.Monad.IO.Class (liftIO) import Data.ByteString.UTF8 (fromString)@@ -35,11 +34,13 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.ByteString.Lazy as L-import Blaze.ByteString.Builder (fromByteString, toByteString)+import Blaze.ByteString.Builder (fromByteString) import System.IO-import Data.Monoid (mconcat) import Data.Time.Clock import Data.Time.Calendar+import qualified Network.Wai.Handler.WarpTLS as WT+import Network.Connection (settingDisableCertificateValidation)+import Data.Default (def) past :: UTCTime past = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0)@@ -82,7 +83,7 @@ [(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+ ["delayed"] -> return $ responseSource status200 [("foo", "bar")] $ do yield Flush liftIO $ threadDelay 30000000 yield $ Chunk $ fromByteString "Hello World!"@@ -118,6 +119,21 @@ killThread (const $ takeMVar baton >> f port) +withAppTls :: Application -> (Int -> IO ()) -> IO ()+withAppTls app' f = withAppTls' (const app') f++withAppTls' :: (Int -> Application) -> (Int -> IO ()) -> IO ()+withAppTls' app' f = do+ port <- getPort+ baton <- newEmptyMVar+ bracket+ (forkIO $ WT.runTLS WT.defaultTlsSettings 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]@@ -130,15 +146,15 @@ 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"+ Left (StatusCodeException _ _ _) -> return ()+ _ -> 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)+ (setCookieHeaders, _) = partition ((== setCookie) . fst) (NHC.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"]@@ -171,9 +187,18 @@ withManager $ \manager -> do response <- httpLbs (request {cookieJar = Nothing}) manager liftIO $ (responseCookieJar response) @?= def+ it "TLS" $ withAppTls app $ \port -> do+ request <- parseUrl $ "https://127.0.0.1:" ++ show port+ let set = mkManagerSettings+ def+ { settingDisableCertificateValidation = True+ }+ Nothing+ response <- withManagerSettings set $ httpLbs request+ responseBody response @?= "homepage" describe "manager" $ do it "closes all connections" $ withApp app $ \port1 -> withApp app $ \port2 -> do- clearSocketsList+ --FIXME 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@@ -181,7 +206,15 @@ _res1b <- http req1 manager _res2 <- http req2 manager return ()- requireAllSocketsClosed+ --FIXME requireAllSocketsClosed+ describe "http" $ do+ it "response body" $ withApp app $ \port -> do+ withManager $ \manager -> do+ req <- parseUrl $ "http://127.0.0.1:" ++ show port+ res1 <- http req manager+ bss <- responseBody res1 $$+- CL.consume+ res2 <- httpLbs req manager+ liftIO $ L.fromChunks bss `shouldBe` responseBody res2 describe "DOS protection" $ do it "overlong headers" $ overLongHeaders $ \port -> do withManager $ \manager -> do@@ -214,18 +247,21 @@ 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])+ void $ http req{redirectCount=5} manager) $ \e ->+ case e of+ TooManyRedirects redirs ->+ mapM_ go (zip redirs [5,4..0 :: Int])+ _ -> error $ show e 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+ src = sourceList bss lbs = L.fromChunks bss res <- httpLbs req1 { method = "POST"- , requestBody = RequestBodySourceChunked src+ , requestBody = requestBodySourceChunked src } manager liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200 let ts = S.concat . L.toChunks@@ -257,7 +293,7 @@ withManager $ \manager -> do eres <- try $ httpLbs req manager liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres- `shouldBe` Left (show InvalidChunkHeaders)+ `shouldBe` Left (show IncompleteHeaders) it "incomplete chunk" $ wrongLengthChunk2 $ \port -> do req <- parseUrl $ "http://127.0.0.1:" ++ show port withManager $ \manager -> do@@ -294,7 +330,7 @@ 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"+ _ -> 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@@ -304,7 +340,7 @@ describe "multipart/form-data" $ do it "formats correctly" $ do let bd = "---------------------------190723902820679116301912680260"- (RequestBodySource _ src) <- renderParts bd+ (RequestBodyStream _ givesPopper) <- renderParts bd [partBS "email" "" ,partBS "parent_id" "70488" ,partBS "captcha" ""@@ -312,7 +348,14 @@ ,partBS "text" $ TE.encodeUtf8 ">>72127\r\nМы работаем над этим." ,partFileSource "upload" "nyan.gif" ]- mfd <- fmap (toByteString . mconcat) $ runResourceT $ src $$ CL.consume+ ires <- I.newIORef S.empty+ let loop front popper = do+ bs <- popper+ if S.null bs+ then I.writeIORef ires $ S.concat $ front []+ else loop (front . (bs:)) popper+ givesPopper $ loop id+ mfd <- I.readIORef ires exam <- S.readFile "multipart-example.bin" mfd @?= exam @@ -339,7 +382,7 @@ 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+ withManagerSettings conduitManagerSettings { managerResponseTimeout = Just 1 } $ \man -> do eres1 <- try $ httpLbs req1 { NHC.path = "/delayed" } man case eres1 of Left (FailedConnectionException _ _) -> return ()