summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMichaelSnoyman <>2012-01-19 09:47:02 (GMT)
committerhdiff <hdiff@luite.com>2012-01-19 09:47:02 (GMT)
commit42e9c5eb37b80dd22e62165764ad63c48139fe83 (patch)
treee5d455c76666fdcee3708d2da9c6eab7360ecef0
parent0085862a6685bd21987bff242e6ce3b9ab91b9fc (diff)
version 1.2.01.2.0
-rw-r--r--Network/HTTP/Conduit.hs34
-rw-r--r--Network/HTTP/Conduit/Manager.hs132
-rw-r--r--Network/HTTP/Conduit/Request.hs14
-rw-r--r--Network/HTTP/Conduit/Response.hs77
-rw-r--r--http-conduit.cabal4
5 files changed, 170 insertions, 91 deletions
diff --git a/Network/HTTP/Conduit.hs b/Network/HTTP/Conduit.hs
index c5d4828..794a62a 100644
--- a/Network/HTTP/Conduit.hs
+++ b/Network/HTTP/Conduit.hs
@@ -61,7 +61,6 @@ module Network.HTTP.Conduit
, def
, method
, secure
- , checkCerts
, host
, port
, path
@@ -73,14 +72,17 @@ module Network.HTTP.Conduit
, 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 Control.Monad.IO.Class (MonadIO (liftIO))
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 @@ import Network.HTTP.Conduit.ConnInfo
-- 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 @@ http
:: 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 @@ http req0 manager = do
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 @@ httpRaw
:: 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 @@ httpRaw req m = do
-- 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 @@ httpLbs r = lbsResponse . http r
-- 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
index ee25db1..8889504 100644
--- 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,12 +43,41 @@ import Control.Concurrent (forkIO, threadDelay)
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.
@@ -56,6 +86,11 @@ data Manager = Manager
-- ^ @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 @@ data NonEmptyList a =
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 @@ addToList now maxCount x l@(Cons _ currCount _ _)
| 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 @@ reap mapRef =
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 @@ reap mapRef =
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 @@ neFromList xs =
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 @@ getConn req m =
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
index 5dea705..e6e8876 100644
--- a/Network/HTTP/Conduit/Request.hs
+++ b/Network/HTTP/Conduit/Request.hs
@@ -9,7 +9,6 @@ module Network.HTTP.Conduit.Request
, parseUrl
, browserDecompress
, HttpException (..)
- , defaultCheckCerts
, alwaysDecompress
, addProxy
, applyBasicAuth
@@ -37,10 +36,6 @@ import qualified Data.ByteString.Char8 as S8
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))
@@ -68,8 +63,6 @@ data Request m = Request
-- ^ 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 @@ parseUrl1 full sec s =
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
index 59d0510..5c6fd23 100644
--- a/Network/HTTP/Conduit/Response.hs
+++ b/Network/HTTP/Conduit/Response.hs
@@ -10,6 +10,7 @@ module Network.HTTP.Conduit.Response
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 @@ data Response body = Response
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 @@ getResponse :: ResourceIO m
=> 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''
+
+ return $ Response s hs' body
--- | Add some cleanup code to the given 'C.BufferedSource'. General purpose
+-- | 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
index 43d7326..9acffb2 100644
--- 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 <michael@snoyman.com>
@@ -22,7 +22,7 @@ library
, 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