diff --git a/Network/HTTP/Conduit.hs b/Network/HTTP/Conduit.hs --- a/Network/HTTP/Conduit.hs +++ b/Network/HTTP/Conduit.hs @@ -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 diff --git a/Network/HTTP/Conduit/Manager.hs b/Network/HTTP/Conduit/Manager.hs --- a/Network/HTTP/Conduit/Manager.hs +++ b/Network/HTTP/Conduit/Manager.hs @@ -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 diff --git a/Network/HTTP/Conduit/Request.hs b/Network/HTTP/Conduit/Request.hs --- a/Network/HTTP/Conduit/Request.hs +++ b/Network/HTTP/Conduit/Request.hs @@ -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 diff --git a/Network/HTTP/Conduit/Response.hs b/Network/HTTP/Conduit/Response.hs --- a/Network/HTTP/Conduit/Response.hs +++ b/Network/HTTP/Conduit/Response.hs @@ -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 + } diff --git a/http-conduit.cabal b/http-conduit.cabal --- a/http-conduit.cabal +++ b/http-conduit.cabal @@ -1,5 +1,5 @@ name: http-conduit -version: 1.1.2.2 +version: 1.2.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -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