summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMichaelSnoyman <>2014-01-27 08:05:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-01-27 08:05:00 (GMT)
commitace1b486fd017ff2200aea1f823c38dd56d8b307 (patch)
tree41743845d9509eb329323beb11bfa0503ba30e11
parentd9d272fbce2afc48b185f1d56acc6e924b247016 (diff)
version 2.0.0.42.0.0.4
-rw-r--r--Network/HTTP/Conduit.hs278
-rw-r--r--Network/HTTP/Conduit/Chunk.hs66
-rw-r--r--Network/HTTP/Conduit/ConnInfo.hs199
-rw-r--r--Network/HTTP/Conduit/Cookies.hs233
-rw-r--r--Network/HTTP/Conduit/Internal.hs101
-rw-r--r--Network/HTTP/Conduit/Manager.hs518
-rw-r--r--Network/HTTP/Conduit/MultipartFormData.hs221
-rw-r--r--Network/HTTP/Conduit/Parser.hs95
-rw-r--r--Network/HTTP/Conduit/Request.hs340
-rw-r--r--Network/HTTP/Conduit/Response.hs207
-rw-r--r--Network/HTTP/Conduit/Types.hs319
-rw-r--r--Network/HTTP/Conduit/Util.hs84
-rw-r--r--certificate.pem15
-rw-r--r--http-conduit.cabal83
-rw-r--r--key.pem15
-rw-r--r--test/CookieTest.hs5
-rw-r--r--test/main.hs83
17 files changed, 193 insertions, 2669 deletions
diff --git a/Network/HTTP/Conduit.hs b/Network/HTTP/Conduit.hs
index a87ce45..16ef9a5 100644
--- a/Network/HTTP/Conduit.hs
+++ b/Network/HTTP/Conduit.hs
@@ -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
@@ -108,6 +107,22 @@
-- > let request = request' { checkStatus = \_ _ -> Nothing }
-- > res <- withManager $ httpLbs request
-- > print res
+--
+-- By default, when connecting to websites using HTTPS, functions in this
+-- package will throw an exception if the TLS certificate doesn't validate. To
+-- continue the HTTPS transaction even if the TLS cerficate validation fails,
+-- you should use 'mkManagerSetttings' as follows:
+--
+-- > import Network.Connection (TLSSettings (..))
+-- > import Network.HTTP.Conduit
+-- >
+-- > main :: IO ()
+-- > main = do
+-- > request <- parseUrl "https://github.com/"
+-- > let settings = mkManagerSettings (TLSSettingsSimple True False False) Nothing
+-- > res <- withManagerSettings settings $ httpLbs request
+-- > print res
+
module Network.HTTP.Conduit
( -- * Perform a request
simpleHttp
@@ -118,10 +133,8 @@ module Network.HTTP.Conduit
, RequestBody (..)
-- ** Request
, Request
- , def
, method
, secure
- , clientCertificates
, host
, port
, path
@@ -129,7 +142,6 @@ module Network.HTTP.Conduit
, requestHeaders
, requestBody
, proxy
- , socksProxy
, hostAddress
, rawBody
, decompress
@@ -138,6 +150,11 @@ module Network.HTTP.Conduit
, responseTimeout
, cookieJar
, getConnectionWrapper
+ -- *** Request body
+ , requestBodySource
+ , requestBodySourceChunked
+ , requestBodySourceIO
+ , requestBodySourceChunkedIO
-- * Response
, Response
, responseStatus
@@ -154,12 +171,10 @@ module Network.HTTP.Conduit
-- ** Settings
, ManagerSettings
, conduitManagerSettings
+ , mkManagerSettings
, managerConnCount
- , managerCheckCerts
- , managerCertStore
, managerResponseTimeout
- -- *** Defaults
- , defaultCheckCerts
+ , managerTlsConnection
-- * Cookies
, Cookie(..)
, CookieJar
@@ -180,173 +195,36 @@ module Network.HTTP.Conduit
, 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.ByteString as S
+import qualified Data.ByteString.Lazy as L
+import Data.Conduit (ResumableSource, ($$+-))
+import qualified Data.Conduit.List as CL
-import qualified Data.Conduit as C
-import Data.Conduit.Blaze (builderToByteString)
+import Control.Applicative ((<$>))
+import Control.Exception.Lifted (bracket)
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Control.Monad.Trans.Resource
-import Data.Time.Clock
-
-import Network.HTTP.Conduit.Request
-import Network.HTTP.Conduit.Response
-import Network.HTTP.Conduit.Manager
-import Network.HTTP.Conduit.ConnInfo
-import Network.HTTP.Conduit.Cookies
-import Network.HTTP.Conduit.Internal (httpRedirect, applyCheckStatus)
-import Network.HTTP.Conduit.Types
-
--- | The most low-level function for initiating an HTTP request.
---
--- The first argument to this function gives a full specification
--- on the request: the host to connect to, whether to use SSL,
--- headers, etc. Please see 'Request' for full details. The
--- second argument specifies which 'Manager' should be used.
---
--- This function then returns a 'Response' with a
--- 'C.Source'. The 'Response' contains the status code
--- and headers that were sent back to us, and the
--- 'C.Source' contains the body of the request. Note
--- that this 'C.Source' allows you to have fully
--- interleaved IO actions during your HTTP download, making it
--- possible to download very large responses in constant memory.
--- You may also directly connect the returned 'C.Source'
--- into a 'C.Sink', perhaps a file or another socket.
---
--- An important note: the response body returned by this function represents a
--- live HTTP connection. As such, if you do not use the response body, an open
--- socket will be retained until the containing @ResourceT@ block exits. If you
--- do not need the response body, it is recommended that you explicitly shut
--- down the connection immediately, using the pattern:
---
--- > responseBody res $$+- return ()
---
--- As a more thorough example, consider the following program. Without the
--- explicit response body closing, the program will run out of file descriptors
--- around the 1000th request (depending on the operating system limits).
---
--- > import Control.Monad (replicateM_)
--- > import Control.Monad.IO.Class (liftIO)
--- > import Data.Conduit (($$+-))
--- > import Network (withSocketsDo)
--- > import Network.HTTP.Conduit
--- >
--- > main = withSocketsDo $ withManager $ \manager -> do
--- > req <- parseUrl "http://localhost/"
--- > mapM_ (worker manager req) [1..5000]
--- >
--- > worker manager req i = do
--- > res <- http req manager
--- > responseBody res $$+- return () -- The important line
--- > liftIO $ print (i, responseStatus res)
---
--- Note: Unlike previous versions, this function will perform redirects, as
--- specified by the 'redirectCount' setting.
-http
- :: (MonadResource m, MonadBaseControl IO m)
- => Request m
- -> Manager
- -> m (Response (C.ResumableSource m S.ByteString))
-http req0 manager = wrapIOException $ do
- res <-
- if redirectCount req0 == 0
- then httpRaw req0 manager
- else go (redirectCount req0) req0
- maybe (return res) throwIO =<< applyCheckStatus (checkStatus req0) res
- where
- go count req' = httpRedirect
- count
- (\req -> do
- res <- httpRaw req manager
- let mreq = getRedirectedRequest req (responseHeaders res) (responseCookieJar res) (W.statusCode (responseStatus res))
- return (res, mreq))
- id
- req'
-
--- | Get a 'Response' without any redirect following.
-httpRaw
- :: (MonadBaseControl IO m, MonadResource m)
- => Request m
- -> Manager
- -> m (Response (C.ResumableSource m S.ByteString))
-httpRaw req' m = do
- (req, cookie_jar') <- case cookieJar req' of
- Just cj -> do
- now <- liftIO getCurrentTime
- return $ insertCookiesIntoRequest req' (evictExpiredCookies cj now) now
- Nothing -> return (req', def)
- (timeout', (connRelease, ci, isManaged)) <- getConnectionWrapper
- req
- (responseTimeout' req)
- (failedConnectionException req)
- (getConn req m)
- let src = connSource ci
-
- -- Originally, we would only test for exceptions when sending the request,
- -- not on calling @getResponse@. However, some servers seem to close
- -- connections after accepting the request headers, so we need to check for
- -- exceptions in both.
- ex <- try $ do
- requestBuilder req C.$$ builderToByteString C.=$ connSink ci
-
- getResponse connRelease timeout' req src
-
- case (ex, isManaged) of
- -- Connection was reused, and might have been closed. Try again
- (Left e, Reused) | isRetryableException e -> do
- connRelease DontReuse
- http req m
- -- Not reused, or a non-retry, so this is a real exception
- (Left e, _) -> liftIO $ throwIO e
- -- Everything went ok, so the connection is good. If any exceptions get
- -- thrown in the response body, just throw them as normal.
- (Right res, _) -> case cookieJar req' of
- Just _ -> do
- now' <- liftIO getCurrentTime
- let (cookie_jar, _) = updateCookieJar res req now' cookie_jar'
- return $ res {responseCookieJar = cookie_jar}
- Nothing -> return res
- where
-
- responseTimeout' req
- | rt == useDefaultTimeout = mResponseTimeout m
- | otherwise = rt
- where
- rt = responseTimeout req
-
- -- Exceptions for which we should retry our request if we were reusing an
- -- already open connection. In the case of IOExceptions, for example, we
- -- assume that the connection was closed on the server and therefore open a
- -- new one.
- isRetryableException e
- | ((fromException e)::(Maybe TLS.TLSError))==Just TLS.Error_EOF = True
- | otherwise = case fromException e of
- Just (_ :: IOException) -> True
- _ ->
- case fromException e of
- -- Note: Some servers will timeout connections by accepting
- -- the incoming packets for the new request, but closing
- -- the connection as soon as we try to read. To make sure
- -- we open a new connection under these circumstances, we
- -- check for the NoResponseDataReceived exception.
- Just NoResponseDataReceived -> True
- _ -> False
+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)
+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 +243,8 @@ httpRaw req' m = do
--
-- 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 +266,31 @@ simpleHttp url = liftIO $ withManager $ \man -> do
req <- liftIO $ parseUrl url
responseBody <$> httpLbs (setConnectionClose req) man
-setConnectionClose :: Request m -> Request m
+conduitManagerSettings :: ManagerSettings
+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}
--- | Since 1.9.6
-conduitManagerSettings :: ManagerSettings
-conduitManagerSettings = def
+lbsResponse :: Monad m
+ => Response (ResumableSource m S.ByteString)
+ -> m (Response L.ByteString)
+lbsResponse res = do
+ bss <- responseBody res $$+- CL.consume
+ return res
+ { responseBody = L.fromChunks bss
+ }
diff --git a/Network/HTTP/Conduit/Chunk.hs b/Network/HTTP/Conduit/Chunk.hs
deleted file mode 100644
index 82b6adb..0000000
--- a/Network/HTTP/Conduit/Chunk.hs
+++ /dev/null
@@ -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)
diff --git a/Network/HTTP/Conduit/ConnInfo.hs b/Network/HTTP/Conduit/ConnInfo.hs
deleted file mode 100644
index 178f0bd..0000000
--- a/Network/HTTP/Conduit/ConnInfo.hs
+++ /dev/null
@@ -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
diff --git a/Network/HTTP/Conduit/Cookies.hs b/Network/HTTP/Conduit/Cookies.hs
deleted file mode 100644
index 9e71dfe..0000000
--- a/Network/HTTP/Conduit/Cookies.hs
+++ /dev/null
@@ -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)
diff --git a/Network/HTTP/Conduit/Internal.hs b/Network/HTTP/Conduit/Internal.hs
deleted file mode 100644
index 278a7ee..0000000
--- a/Network/HTTP/Conduit/Internal.hs
+++ /dev/null
@@ -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
diff --git a/Network/HTTP/Conduit/Manager.hs b/Network/HTTP/Conduit/Manager.hs
deleted file mode 100644
index 7f1b2b6..0000000
--- a/Network/HTTP/Conduit/Manager.hs
+++ /dev/null
@@ -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
diff --git a/Network/HTTP/Conduit/MultipartFormData.hs b/Network/HTTP/Conduit/MultipartFormData.hs
deleted file mode 100644
index 11be61b..0000000
--- a/Network/HTTP/Conduit/MultipartFormData.hs
+++ /dev/null
@@ -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
- }
diff --git a/Network/HTTP/Conduit/Parser.hs b/Network/HTTP/Conduit/Parser.hs
deleted file mode 100644
index c5581fc..0000000
--- a/Network/HTTP/Conduit/Parser.hs
+++ /dev/null
@@ -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)
diff --git a/Network/HTTP/Conduit/Request.hs b/Network/HTTP/Conduit/Request.hs
deleted file mode 100644
index 4988fcf..0000000
--- a/Network/HTTP/Conduit/Request.hs
+++ /dev/null
@@ -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"
diff --git a/Network/HTTP/Conduit/Response.hs b/Network/HTTP/Conduit/Response.hs
deleted file mode 100644
index 1e1cd8b..0000000
--- a/Network/HTTP/Conduit/Response.hs
+++ /dev/null
@@ -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
diff --git a/Network/HTTP/Conduit/Types.hs b/Network/HTTP/Conduit/Types.hs
deleted file mode 100644
index 5e8c2ac..0000000
--- a/Network/HTTP/Conduit/Types.hs
+++ /dev/null
@@ -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
diff --git a/Network/HTTP/Conduit/Util.hs b/Network/HTTP/Conduit/Util.hs
deleted file mode 100644
index f58884c..0000000
--- a/Network/HTTP/Conduit/Util.hs
+++ /dev/null
@@ -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
diff --git a/certificate.pem b/certificate.pem
new file mode 100644
index 0000000..65c91e3
--- /dev/null
+++ b/certificate.pem
@@ -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-----
diff --git a/http-conduit.cabal b/http-conduit.cabal
index 5316dc5..327ddb5 100644
--- a/http-conduit.cabal
+++ b/http-conduit.cabal
@@ -1,5 +1,5 @@
name: http-conduit
-version: 1.9.6
+version: 2.0.0.4
license: BSD3
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@@ -9,6 +9,8 @@ description:
This package uses conduit for parsing the actual contents of the HTTP connection. It also provides higher-level functions which allow you to avoid directly dealing with streaming data. See <http://www.yesodweb.com/book/http-conduit> for more information.
.
The @Network.HTTP.Conduit.Browser@ module has been moved to <http://hackage.haskell.org/package/http-conduit-browser/>
+ .
+ The @Network.HTTP.Conduit.MultipartFormData@ module has been moved to <http://hackage.haskell.org/package/http-client-multipart/>
category: Web, Conduit
stability: Stable
cabal-version: >= 1.8
@@ -18,79 +20,27 @@ extra-source-files: test/main.hs
, test/CookieTest.hs
, multipart-example.bin
, nyan.gif
-
-flag network-bytestring
- default: False
-
-flag tls_1_1_3
- default: True
+ , 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.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
@@ -107,8 +57,6 @@ test-suite test
, blaze-builder
, http-types
, cprng-aes
- , tls
- , tls-extra
, monad-control
, containers
, certificate
@@ -121,8 +69,9 @@ test-suite test
, 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 @@ test-suite test
, 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
diff --git a/key.pem b/key.pem
new file mode 100644
index 0000000..57465e9
--- /dev/null
+++ b/key.pem
@@ -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-----
diff --git a/test/CookieTest.hs b/test/CookieTest.hs
index 033a906..a76756f 100644
--- a/test/CookieTest.hs
+++ b/test/CookieTest.hs
@@ -4,8 +4,7 @@ import Prelude hiding (exp)
import Test.Hspec
import qualified Data.ByteString as BS
import Test.HUnit hiding (path)
-import Network.HTTP.Conduit.Cookies
-import Network.HTTP.Conduit.Types
+import Network.HTTP.Client
import qualified Network.HTTP.Conduit as HC
import Data.ByteString.UTF8
import Data.Monoid
@@ -15,7 +14,7 @@ import Data.Time.Calendar
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
diff --git a/test/main.hs b/test/main.hs
index 9bc19d3..640efe1 100644
--- a/test/main.hs
+++ b/test/main.hs
@@ -10,13 +10,12 @@ import qualified Network.Wai as Wai
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 CookieTest (cookieTest)
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.Conduit.List as CL
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 @@ app req =
[(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 @@ withApp' app' f = do
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 @@ main = withSocketsDo $ do
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 @@ main = withSocketsDo $ do
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 @@ main = withSocketsDo $ do
_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 @@ main = withSocketsDo $ do
let Just req = parseUrl $ concat ["http://127.0.0.1:", show port, "/infredir/0"]
let go (res, i) = liftIO $ responseBody res @?= (L8.pack $ show i)
E.catch (withManager $ \manager -> do
- void $ http req{redirectCount=5} manager) $
- \(TooManyRedirects redirs) -> mapM_ go (zip redirs [5,4..0 :: Int])
+ 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 @@ main = withSocketsDo $ do
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 @@ main = withSocketsDo $ do
let app' port req =
case pathInfo req of
["foo"] -> return $ responseLBS status200 [] "Hello World!"
- _ -> return $ ResponseSource status301 [("location", S8.pack $ "http://127.0.0.1:" ++ show port ++ "/foo")] $ forever $ yield $ Chunk $ fromByteString "hello\n"
+ _ -> 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 @@ main = withSocketsDo $ do
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 @@ main = withSocketsDo $ do
,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 @@ main = withSocketsDo $ do
it "works" $ withApp app $ \port -> do
req1 <- parseUrl $ "http://localhost:" ++ show port
let req2 = req1 { responseTimeout = Just 5000000 }
- withManagerSettings def { managerResponseTimeout = Just 1 } $ \man -> do
+ withManagerSettings conduitManagerSettings { managerResponseTimeout = Just 1 } $ \man -> do
eres1 <- try $ httpLbs req1 { NHC.path = "/delayed" } man
case eres1 of
Left (FailedConnectionException _ _) -> return ()