http-conduit 1.1.2.2 → 1.2.0
raw patch · 5 files changed
+170/−91 lines, 5 filesdep ~conduit
Dependency ranges changed: conduit
Files
- Network/HTTP/Conduit.hs +18/−16
- Network/HTTP/Conduit/Manager.hs +109/−23
- Network/HTTP/Conduit/Request.hs +0/−14
- Network/HTTP/Conduit/Response.hs +41/−36
- http-conduit.cabal +2/−2
Network/HTTP/Conduit.hs view
@@ -61,7 +61,6 @@ , def , method , secure- , checkCerts , host , port , path@@ -73,14 +72,17 @@ , decompress , redirectCount , checkStatus- -- *** Defaults- , defaultCheckCerts -- * Manager , Manager , newManager- , newManagerCount- , newManagerIO+ , closeManager , withManager+ -- ** Settings+ , ManagerSettings+ , managerConnCount+ , managerCheckCerts+ -- *** Defaults+ , defaultCheckCerts -- * Utility functions , parseUrl , applyBasicAuth@@ -112,7 +114,7 @@ import qualified Data.Conduit as C import Data.Conduit.Blaze (builderToByteString)-import Control.Monad.Trans.Resource (ResourceT, runResourceT, ResourceIO)+import Control.Monad.Trans.Resource (ResourceT, ResourceIO) import Control.Exception.Lifted (try, SomeException) import Network.HTTP.Conduit.Request@@ -128,13 +130,13 @@ -- second argument specifies which 'Manager' should be used. -- -- This function then returns a 'Response' with a--- 'C.BufferedSource'. The 'Response' contains the status code+-- 'C.Source'. The 'Response' contains the status code -- and headers that were sent back to us, and the--- 'C.BufferedSource' contains the body of the request. Note--- that this 'C.BufferedSource' allows you to have fully+-- '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.BufferedSource'+-- You may also directly connect the returned 'C.Source' -- into a 'C.Sink', perhaps a file or another socket. -- -- Note: Unlike previous versions, this function will perform redirects, as@@ -143,7 +145,7 @@ :: ResourceIO m => Request m -> Manager- -> ResourceT m (Response (C.BufferedSource m S.ByteString))+ -> ResourceT m (Response (C.Source m S.ByteString)) http req0 manager = do res@(Response status hs body) <- if redirectCount req0 == 0@@ -152,7 +154,8 @@ case checkStatus req0 status hs of Nothing -> return res Just exc -> do- C.bsourceClose body+ body' <- C.prepareSource body+ C.sourceClose body' liftBase $ throwIO exc where go 0 _ = liftBase $ throwIO TooManyRedirects@@ -197,7 +200,7 @@ :: ResourceIO m => Request m -> Manager- -> ResourceT m (Response (C.BufferedSource m S.ByteString))+ -> ResourceT m (Response (C.Source m S.ByteString)) httpRaw req m = do (connRelease, ci, isManaged) <- getConn req m bsrc <- C.bufferSource $ connSource ci@@ -226,7 +229,7 @@ -- function does /not/ utilize lazy I/O, and therefore the entire -- response body will live in memory. If you want constant memory -- usage, you'll need to use @conduit@ packages's--- 'C.BufferedSource' returned by 'http'.+-- 'C.Source' returned by 'http'. -- -- Note: Unlike previous versions, this function will perform redirects, as -- specified by the 'redirectCount' setting.@@ -247,7 +250,6 @@ -- you'll need to use the @conduit@ package and 'http' or -- 'httpRedirect' directly. simpleHttp :: MonadIO m => String -> m L.ByteString-simpleHttp url = liftIO $ runResourceT $ do+simpleHttp url = liftIO $ withManager $ \man -> do url' <- liftBase $ parseUrl url- man <- newManager fmap responseBody $ httpLbs url' man
Network/HTTP/Conduit/Manager.hs view
@@ -1,21 +1,22 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-} module Network.HTTP.Conduit.Manager ( Manager+ , ManagerSettings (..) , ConnKey (..) , newManager- , newManagerCount- , newManagerIO+ , closeManager , getConn , ConnReuse (..) , withManager , ConnRelease , ManagedConn (..)+ , defaultCheckCerts ) where import Prelude hiding (catch)-import Control.Applicative ((<$>)) import Data.Monoid (mappend) import System.IO (hClose, hFlush) import qualified Data.IORef as I@@ -42,13 +43,42 @@ import Data.Time (UTCTime, getCurrentTime, addUTCTime) import Network (connectTo, PortID (PortNumber))-import Data.Certificate.X509 (X509)+import Data.Certificate.X509 (X509, encodeCertificate) +import qualified Network.HTTP.Types as W+import Network.TLS.Extra (certificateVerifyChain, certificateVerifyDomain)+ import Network.HTTP.Conduit.ConnInfo import Network.HTTP.Conduit.Util (hGetSome) import Network.HTTP.Conduit.Parser (parserHeadersFromByteString) import Network.HTTP.Conduit.Request+import Data.Default+import Data.Maybe (mapMaybe) +-- | 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 :: W.Ascii -> [X509] -> IO TLSCertificateUsage+ -- ^ Check if the server certificate is valid. Only relevant for HTTPS.+ }++type X509Encoded = L.ByteString++instance Default ManagerSettings where+ def = ManagerSettings+ { managerConnCount = 10+ , managerCheckCerts = defaultCheckCerts+ }++-- | Check certificates using the operating system's certificate checker.+defaultCheckCerts :: W.Ascii -> [X509] -> IO TLSCertificateUsage+defaultCheckCerts host' certs =+ case certificateVerifyDomain (S8.unpack host') certs of+ CertificateUsageAccept -> certificateVerifyChain certs+ rejected -> return rejected+ -- | Keeps track of open connections for keep-alive. May be used -- concurrently by multiple threads. data Manager = Manager@@ -56,6 +86,11 @@ -- ^ @Nothing@ indicates that the manager is closed. , mMaxConns :: !Int -- ^ This is a per-@ConnKey@ value.+ , mCheckCerts :: W.Ascii -> [X509] -> IO TLSCertificateUsage+ -- ^ Check if a certificate is valid.+ , mCertCache :: !(I.IORef (Map.Map W.Ascii (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. } data NonEmptyList a =@@ -63,7 +98,7 @@ Cons !a !Int !UTCTime !(NonEmptyList a) -- | @ConnKey@ consists of a hostname, a port and a @Bool@--- specifying whether to use keepalive.+-- specifying whether to use SSL. data ConnKey = ConnKey !Text !Int !Bool deriving (Eq, Show, Ord) @@ -101,24 +136,19 @@ | maxCount > currCount = (Cons x (currCount + 1) now l, Nothing) | otherwise = (l, Just x) --- | Create a new 'Manager' with no open connections and a maximum of 10 open connections..-newManager :: ResourceIO m => ResourceT m Manager-newManager = newManagerCount 10---- | Create a new 'Manager' with the specified max connection count.-newManagerCount :: ResourceIO m => Int -> ResourceT m Manager-newManagerCount count = snd <$> withIO (newManagerIO count) closeManager---- | Create a 'Manager' which will never be destroyed.-newManagerIO :: Int -> IO Manager-newManagerIO count = do+-- | Create a 'Manager'. You must manually call 'closeManager' to shut it down.+newManager :: ManagerSettings -> IO Manager+newManager ms = do mapRef <- I.newIORef (Just Map.empty)- _ <- forkIO $ reap mapRef- return $ Manager mapRef count+ certCache <- I.newIORef Map.empty+ _ <- forkIO $ reap mapRef certCache+ return $ Manager mapRef (managerConnCount ms) (managerCheckCerts ms) certCache -- | Collect and destroy any stale connections.-reap :: I.IORef (Maybe (Map.Map ConnKey (NonEmptyList ConnInfo))) -> IO ()-reap mapRef =+reap :: I.IORef (Maybe (Map.Map ConnKey (NonEmptyList ConnInfo)))+ -> I.IORef (Map.Map W.Ascii (Map.Map X509Encoded UTCTime))+ -> IO ()+reap mapRef certCacheRef = mask_ loop where loop = do@@ -131,6 +161,7 @@ Just toDestroy -> do mapM_ safeConnClose toDestroy loop+ I.atomicModifyIORef certCacheRef $ \x -> (flushStaleCerts now x, ()) findStaleWrap _ Nothing = (Nothing, Nothing) findStaleWrap isNotStale (Just m) = let (x, y) = findStale isNotStale m@@ -151,6 +182,17 @@ 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 -> Just (host', Map.fromList $ take 10 pairs)+ flushStaleCerts'' (certs, expires)+ | expires > now = Just (certs, expires)+ | otherwise = Nothing+ neToList :: NonEmptyList a -> [(UTCTime, a)] neToList (One a t) = [(t, a)] neToList (Cons a _ t nelist) = (t, a) : neToList nelist@@ -168,8 +210,14 @@ 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+-- 'newManager'. withManager :: ResourceIO m => (Manager -> ResourceT m a) -> m a-withManager f = runResourceT $ newManager >>= f+withManager f = runResourceT $ do+ (_, manager) <- withIO (newManager def) closeManager+ f manager -- | Close all connections in a 'Manager'. Afterwards, the -- 'Manager' can be reused if desired.@@ -312,5 +360,43 @@ go = case (secure req, useProxy) of (False, _) -> getSocketConn- (True, False) -> getSslConn $ checkCerts req h- (True, True) -> getSslProxyConn (checkCerts req h) h (port req)+ (True, False) -> getSslConn $ checkCerts m h+ (True, True) -> getSslProxyConn (checkCerts m h) h (port req)++checkCerts :: Manager -> W.Ascii -> [X509] -> IO TLSCertificateUsage+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
Network/HTTP/Conduit/Request.hs view
@@ -9,7 +9,6 @@ , parseUrl , browserDecompress , HttpException (..)- , defaultCheckCerts , alwaysDecompress , addProxy , applyBasicAuth@@ -37,11 +36,7 @@ import qualified Data.ByteString.Lazy as L import qualified Network.HTTP.Types as W-import Data.Certificate.X509 (X509) -import Network.TLS (TLSCertificateUsage (CertificateUsageAccept))-import Network.TLS.Extra (certificateVerifyChain, certificateVerifyDomain)- import Control.Exception (Exception, SomeException, toException) import Control.Failure (Failure (failure)) import Codec.Binary.UTF8.String (encodeString)@@ -68,8 +63,6 @@ -- ^ HTTP request method, eg GET, POST. , secure :: Bool -- ^ Whether to use HTTPS (ie, SSL).- , checkCerts :: W.Ascii -> [X509] -> IO TLSCertificateUsage- -- ^ Check if the server certificate is valid. Only relevant for HTTPS. , host :: W.Ascii , port :: Int , path :: W.Ascii@@ -161,18 +154,11 @@ where s' = encodeString s -defaultCheckCerts :: W.Ascii -> [X509] -> IO TLSCertificateUsage-defaultCheckCerts host' certs =- case certificateVerifyDomain (S8.unpack host') certs of- CertificateUsageAccept -> certificateVerifyChain certs- rejected -> return rejected- instance Default (Request m) where def = Request { host = "localhost" , port = 80 , secure = False- , checkCerts = defaultCheckCerts , requestHeaders = [] , path = "/" , queryString = S8.empty
Network/HTTP/Conduit/Response.hs view
@@ -10,6 +10,7 @@ import Control.Arrow (first) import Data.Typeable (Typeable)+import Data.Monoid (mempty) import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L@@ -42,10 +43,10 @@ instance Functor Response where fmap f (Response status headers body) = Response status headers (f body) --- | Convert a 'Response' that has a 'C.BufferedSource' body to one with a lazy+-- | Convert a 'Response' that has a 'C.Source' body to one with a lazy -- 'L.ByteString' body. lbsResponse :: C.Resource m- => ResourceT m (Response (C.BufferedSource m S8.ByteString))+ => ResourceT m (Response (C.Source m S8.ByteString)) -> ResourceT m (Response L.ByteString) lbsResponse mres = do res <- mres@@ -58,51 +59,55 @@ => ConnRelease m -> Request m -> C.BufferedSource m S8.ByteString- -> ResourceT m (Response (C.BufferedSource m S8.ByteString))+ -> ResourceT m (Response (C.Source m S8.ByteString)) getResponse connRelease req@(Request {..}) bsrc = do ((_, sc, sm), hs) <- bsrc C.$$ sinkHeaders let s = W.Status sc sm let hs' = map (first CI.mk) hs let mcl = lookup "content-length" hs' >>= readDec . S8.unpack - -- RFC 2616 section 4.4_1 defines responses that must not include a body- body <- if hasNoBody method sc || mcl == Just 0- then do- -- FIXME clean up socket- C.bufferSource $ CL.sourceList []- else do- bsrc' <-- if ("transfer-encoding", "chunked") `elem` hs'- then C.bufferSource $ bsrc C.$= chunkedConduit rawBody- else- case mcl of- Just len -> C.bufferSource $ bsrc C.$= CB.isolate len- Nothing -> return bsrc- if needsGunzip req hs'- then C.bufferSource $ bsrc' C.$= CZ.ungzip- else return bsrc'- -- should we put this connection back into the connection manager? let toPut = Just "close" /= lookup "connection" hs' let cleanup = connRelease $ if toPut then Reuse else DontReuse - return $ Response s hs' $ addCleanup cleanup body+ -- 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+ return mempty+ else do+ let bsrc' =+ if ("transfer-encoding", "chunked") `elem` hs'+ then bsrc C.$= chunkedConduit rawBody+ else+ case mcl of+ Just len -> bsrc C.$= CB.isolate len+ Nothing -> C.unbufferSource bsrc+ let bsrc'' =+ if needsGunzip req hs'+ then bsrc' C.$= CZ.ungzip+ else bsrc'+ return $ addCleanup cleanup bsrc'' --- | Add some cleanup code to the given 'C.BufferedSource'. General purpose+ return $ Response s hs' body++-- | Add some cleanup code to the given 'C.Source'. General purpose -- function, could be included in conduit itself. addCleanup :: C.ResourceIO m => ResourceT m ()- -> C.BufferedSource m a- -> C.BufferedSource m a-addCleanup cleanup bsrc = C.BufferedSource- { C.bsourcePull = do- res <- C.bsourcePull bsrc- case res of- C.Closed -> cleanup- C.Open _ -> return ()- return res- , C.bsourceUnpull = C.bsourceUnpull bsrc- , C.bsourceClose = do- C.bsourceClose bsrc- cleanup- }+ -> C.Source m a+ -> C.Source m a+addCleanup cleanup (C.Source msrc) = C.Source $ do+ src <- msrc+ return C.PreparedSource+ { C.sourcePull = do+ res <- C.sourcePull src+ case res of+ C.Closed -> cleanup+ C.Open _ -> return ()+ return res+ , C.sourceClose = do+ C.sourceClose src+ cleanup+ }
http-conduit.cabal view
@@ -1,5 +1,5 @@ name: http-conduit-version: 1.1.2.2+version: 1.2.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -22,7 +22,7 @@ , bytestring >= 0.9.1.4 && < 0.10 , transformers >= 0.2 && < 0.3 , failure >= 0.1- , conduit >= 0.0 && < 0.1+ , conduit >= 0.1 , zlib-conduit >= 0.0 && < 0.1 , blaze-builder-conduit >= 0.0 && < 0.1 , attoparsec-conduit >= 0.0 && < 0.1