diff --git a/Network/HTTP/Conduit.hs b/Network/HTTP/Conduit.hs --- 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 @@ -118,10 +117,8 @@ , RequestBody (..) -- ** Request , Request - , def , method , secure - , clientCertificates , host , port , path @@ -129,7 +126,6 @@ , requestHeaders , requestBody , proxy - , socksProxy , hostAddress , rawBody , decompress @@ -138,6 +134,11 @@ , responseTimeout , cookieJar , getConnectionWrapper + -- *** Request body + , requestBodySource + , requestBodySourceChunked + , requestBodySourceIO + , requestBodySourceChunkedIO -- * Response , Response , responseStatus @@ -154,12 +155,10 @@ -- ** Settings , ManagerSettings , conduitManagerSettings + , mkManagerSettings , managerConnCount - , managerCheckCerts - , managerCertStore , managerResponseTimeout - -- *** Defaults - , defaultCheckCerts + , managerTlsConnection -- * Cookies , Cookie(..) , CookieJar @@ -180,173 +179,34 @@ , urlEncodedBody -- * Exceptions , HttpException (..) -#if DEBUG - -- * Debug - , printOpenSockets -#endif ) where -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L - -import qualified Network.HTTP.Types as W -import Data.Default (def) - -import Control.Exception.Lifted (throwIO, try, IOException, handle, fromException, toException) -import qualified Network.TLS as TLS -import Control.Applicative -import Control.Monad ((<=<)) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.Resource - -import qualified Data.Conduit as C -import Data.Conduit.Blaze (builderToByteString) - -import Data.Time.Clock - -import Network.HTTP.Conduit.Request -import Network.HTTP.Conduit.Response -import Network.HTTP.Conduit.Manager -import Network.HTTP.Conduit.ConnInfo -import Network.HTTP.Conduit.Cookies -import Network.HTTP.Conduit.Internal (httpRedirect, applyCheckStatus) -import Network.HTTP.Conduit.Types - --- | The most low-level function for initiating an HTTP request. --- --- The first argument to this function gives a full specification --- on the request: the host to connect to, whether to use SSL, --- headers, etc. Please see 'Request' for full details. The --- second argument specifies which 'Manager' should be used. --- --- This function then returns a 'Response' with a --- 'C.Source'. The 'Response' contains the status code --- and headers that were sent back to us, and the --- 'C.Source' contains the body of the request. Note --- that this 'C.Source' allows you to have fully --- interleaved IO actions during your HTTP download, making it --- possible to download very large responses in constant memory. --- You may also directly connect the returned 'C.Source' --- into a 'C.Sink', perhaps a file or another socket. --- --- An important note: the response body returned by this function represents a --- live HTTP connection. As such, if you do not use the response body, an open --- socket will be retained until the containing @ResourceT@ block exits. If you --- do not need the response body, it is recommended that you explicitly shut --- down the connection immediately, using the pattern: --- --- > responseBody res $$+- return () --- --- As a more thorough example, consider the following program. Without the --- explicit response body closing, the program will run out of file descriptors --- around the 1000th request (depending on the operating system limits). --- --- > import Control.Monad (replicateM_) --- > import Control.Monad.IO.Class (liftIO) --- > import Data.Conduit (($$+-)) --- > import Network (withSocketsDo) --- > import Network.HTTP.Conduit --- > --- > main = withSocketsDo $ withManager $ \manager -> do --- > req <- parseUrl "http://localhost/" --- > mapM_ (worker manager req) [1..5000] --- > --- > worker manager req i = do --- > res <- http req manager --- > responseBody res $$+- return () -- The important line --- > liftIO $ print (i, responseStatus res) --- --- Note: Unlike previous versions, this function will perform redirects, as --- specified by the 'redirectCount' setting. -http - :: (MonadResource m, MonadBaseControl IO m) - => Request m - -> Manager - -> m (Response (C.ResumableSource m S.ByteString)) -http req0 manager = wrapIOException $ do - res <- - if redirectCount req0 == 0 - then httpRaw req0 manager - else go (redirectCount req0) req0 - maybe (return res) throwIO =<< applyCheckStatus (checkStatus req0) res - where - go count req' = httpRedirect - count - (\req -> do - res <- httpRaw req manager - let mreq = getRedirectedRequest req (responseHeaders res) (responseCookieJar res) (W.statusCode (responseStatus res)) - return (res, mreq)) - id - req' - --- | Get a 'Response' without any redirect following. -httpRaw - :: (MonadBaseControl IO m, MonadResource m) - => Request m - -> Manager - -> m (Response (C.ResumableSource m S.ByteString)) -httpRaw req' m = do - (req, cookie_jar') <- case cookieJar req' of - Just cj -> do - now <- liftIO getCurrentTime - return $ insertCookiesIntoRequest req' (evictExpiredCookies cj now) now - Nothing -> return (req', def) - (timeout', (connRelease, ci, isManaged)) <- getConnectionWrapper - req - (responseTimeout' req) - (failedConnectionException req) - (getConn req m) - let src = connSource ci - - -- Originally, we would only test for exceptions when sending the request, - -- not on calling @getResponse@. However, some servers seem to close - -- connections after accepting the request headers, so we need to check for - -- exceptions in both. - ex <- try $ do - requestBuilder req C.$$ builderToByteString C.=$ connSink ci - - getResponse connRelease timeout' req src - - case (ex, isManaged) of - -- Connection was reused, and might have been closed. Try again - (Left e, Reused) | isRetryableException e -> do - connRelease DontReuse - http req m - -- Not reused, or a non-retry, so this is a real exception - (Left e, _) -> liftIO $ throwIO e - -- Everything went ok, so the connection is good. If any exceptions get - -- thrown in the response body, just throw them as normal. - (Right res, _) -> case cookieJar req' of - Just _ -> do - now' <- liftIO getCurrentTime - let (cookie_jar, _) = updateCookieJar res req now' cookie_jar' - return $ res {responseCookieJar = cookie_jar} - Nothing -> return res - where +import qualified Data.ByteString.Lazy as L - responseTimeout' req - | rt == useDefaultTimeout = mResponseTimeout m - | otherwise = rt - where - rt = responseTimeout req +import Control.Applicative ((<$>)) +import Control.Exception.Lifted (bracket) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Resource - -- Exceptions for which we should retry our request if we were reusing an - -- already open connection. In the case of IOExceptions, for example, we - -- assume that the connection was closed on the server and therefore open a - -- new one. - isRetryableException e - | ((fromException e)::(Maybe TLS.TLSError))==Just TLS.Error_EOF = True - | otherwise = case fromException e of - Just (_ :: IOException) -> True - _ -> - case fromException e of - -- Note: Some servers will timeout connections by accepting - -- the incoming packets for the new request, but closing - -- the connection as soon as we try to read. To make sure - -- we open a new connection under these circumstances, we - -- check for the NoResponseDataReceived exception. - Just NoResponseDataReceived -> True - _ -> False +import qualified Network.HTTP.Client as Client (httpLbs) +import Network.HTTP.Client.Conduit +import Network.HTTP.Client.Internal (createCookieJar, + destroyCookieJar) +import Network.HTTP.Client.Internal (Manager, ManagerSettings, + closeManager, managerConnCount, + managerResponseTimeout, + managerTlsConnection, newManager) +import Network.HTTP.Client (parseUrl, urlEncodedBody, applyBasicAuth) +import Network.HTTP.Client.Internal (addProxy, alwaysDecompress, + browserDecompress) +import Network.HTTP.Client.Internal (getRedirectedRequest, + lbsResponse) +import Network.HTTP.Client.TLS (mkManagerSettings, + tlsManagerSettings) +import Network.HTTP.Client.Internal (Cookie (..), CookieJar (..), + HttpException (..), Proxy (..), + Request (..), RequestBody (..), + Response (..)) -- | Download the specified 'Request', returning the results as a 'Response'. -- @@ -365,26 +225,8 @@ -- -- Note: Unlike previous versions, this function will perform redirects, as -- specified by the 'redirectCount' setting. -httpLbs :: (MonadBaseControl IO m, MonadResource m) => Request m -> Manager -> m (Response L.ByteString) -httpLbs r = wrapIOException . (lbsResponse <=< http r) - -wrapIOException :: MonadBaseControl IO m => m a -> m a -wrapIOException = - handle $ throwIO . wrapper - where - wrapper se = - case fromException se of - Just e -> toException $ InternalIOException e - Nothing -> - case fromException se of - Just TLS.Terminated{} -> toException $ TlsException se - Nothing -> - case fromException se of - Just TLS.HandshakeFailed{} -> toException $ TlsException se - Nothing -> - case fromException se of - Just TLS.ConnectionNotEstablished -> toException $ TlsException se - Nothing -> se +httpLbs :: MonadIO m => Request -> Manager -> m (Response L.ByteString) +httpLbs r m = liftIO $ Client.httpLbs r m -- | Download the specified URL, following any redirects, and -- return the response body. @@ -406,9 +248,22 @@ req <- liftIO $ parseUrl url responseBody <$> httpLbs (setConnectionClose req) man -setConnectionClose :: Request m -> Request m -setConnectionClose req = req{requestHeaders = ("Connection", "close") : requestHeaders req} - --- | Since 1.9.6 conduitManagerSettings :: ManagerSettings -conduitManagerSettings = def +conduitManagerSettings = tlsManagerSettings + +withManager :: (MonadIO m, MonadBaseControl IO m) + => (Manager -> ResourceT m a) + -> m a +withManager = withManagerSettings conduitManagerSettings + +withManagerSettings :: (MonadIO m, MonadBaseControl IO m) + => ManagerSettings + -> (Manager -> ResourceT m a) + -> m a +withManagerSettings set f = bracket + (liftIO $ newManager set) + (liftIO . closeManager) + (runResourceT . f) + +setConnectionClose :: Request -> Request +setConnectionClose req = req{requestHeaders = ("Connection", "close") : requestHeaders req} diff --git a/Network/HTTP/Conduit/Chunk.hs b/Network/HTTP/Conduit/Chunk.hs deleted file mode 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 \ - , 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 "" - -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 --- 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 --- 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 --- 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 --- 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 --- . -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 "" - showsPrec d (RequestBodySource l _) = - showParen (d>=11) $ showString "RequestBodySource " . showsPrec 11 l . - showString " " - showsPrec d (RequestBodySourceChunked _) = - showParen (d>=11) $ showString "RequestBodySource " - --- | 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 --- 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 --- /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 --- a/http-conduit.cabal +++ b/http-conduit.cabal @@ -1,5 +1,5 @@ name: http-conduit -version: 1.9.6 +version: 2.0.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -18,79 +18,27 @@ , test/CookieTest.hs , multipart-example.bin , nyan.gif - -flag network-bytestring - default: False - -flag tls_1_1_3 - default: True + , certificate.pem + , key.pem library build-depends: base >= 4 && < 5 , bytestring >= 0.9.1.4 , transformers >= 0.2 - , failure >= 0.1 , resourcet >= 0.3 && < 0.5 , conduit >= 0.5.5 && < 1.1 - , zlib-conduit >= 0.5 && < 1.1 - , blaze-builder-conduit >= 0.5 - , utf8-string >= 0.3.4 - , blaze-builder >= 0.2.1 , http-types >= 0.7 - , mime-types >= 0.1 - , cprng-aes >= 0.3 - , tls >= 1.1.0 - , tls-extra >= 0.5.0 - , monad-control >= 0.3 - , containers >= 0.2 - , certificate >= 1.3 - , case-insensitive >= 0.2 - , base64-bytestring >= 0.1 - , asn1-data >= 0.5.1 - , data-default - , text - , transformers-base >= 0.4 , lifted-base >= 0.1 - , socks >= 0.4 - , time - , cookie >= 0.4 - , void >= 0.5.5 - , regex-compat - , mtl - , deepseq - , publicsuffixlist >= 0.0.3 && < 1.0 - , array >= 0.3 - , random - , filepath - if flag(network-bytestring) - build-depends: network >= 2.2.1 && < 2.2.3 - , network-bytestring >= 0.1.3 && < 0.1.4 - else - build-depends: network >= 2.3 - if flag(tls_1_1_3) - build-depends: tls >= 1.1.3 - , cprng-aes >= 0.5.0 - else - build-depends: tls < 1.1.3 - , cprng-aes < 0.5.0 + , http-client >= 0.2 + , http-client-tls + , http-client-conduit exposed-modules: Network.HTTP.Conduit - Network.HTTP.Conduit.Internal - Network.HTTP.Conduit.MultipartFormData - other-modules: Network.HTTP.Conduit.Parser - Network.HTTP.Conduit.ConnInfo - Network.HTTP.Conduit.Request - Network.HTTP.Conduit.Util - Network.HTTP.Conduit.Manager - Network.HTTP.Conduit.Chunk - Network.HTTP.Conduit.Response - Network.HTTP.Conduit.Cookies - Network.HTTP.Conduit.Types ghc-options: -Wall test-suite test - main-is: test/main.hs + main-is: main.hs type: exitcode-stdio-1.0 - hs-source-dirs: ., test + hs-source-dirs: test ghc-options: -Wall cpp-options: -DDEBUG @@ -121,8 +69,9 @@ , lifted-base , time , network - , wai < 2.0 - , warp >= 1.3.6 + , wai >= 2.0 && < 2.1 + , warp >= 2.0 && < 2.1 + , warp-tls , socks , http-types , cookie @@ -137,7 +86,11 @@ , random , filepath , mime-types + , http-client + , http-conduit + , connection + , http-client-multipart source-repository head type: git - location: git://github.com/snoyberg/http-conduit.git + location: git://github.com/snoyberg/http-client.git diff --git a/key.pem b/key.pem new file mode 100644 --- /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 --- a/test/CookieTest.hs +++ b/test/CookieTest.hs @@ -4,8 +4,7 @@ import Test.Hspec import qualified Data.ByteString as BS import Test.HUnit hiding (path) -import Network.HTTP.Conduit.Cookies -import Network.HTTP.Conduit.Types +import Network.HTTP.Client import qualified Network.HTTP.Conduit as HC import Data.ByteString.UTF8 import Data.Monoid @@ -15,7 +14,7 @@ import qualified Data.CaseInsensitive as CI import Web.Cookie -default_request :: HC.Request m +default_request :: HC.Request default_request = fromJust $ HC.parseUrl "http://www.google.com/" default_cookie :: Cookie diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -10,13 +10,12 @@ import Network.Wai.Handler.Warp (runSettings, defaultSettings, settingsPort, settingsBeforeMainLoop) import Network.HTTP.Conduit hiding (port) import qualified Network.HTTP.Conduit as NHC -import Network.HTTP.Conduit.MultipartFormData +import Network.HTTP.Client.MultipartFormData import Control.Concurrent (forkIO, killThread, putMVar, takeMVar, newEmptyMVar, threadDelay) import Network.HTTP.Types import Control.Exception.Lifted (try, SomeException, bracket, onException, IOException) import qualified Data.IORef as I import qualified Control.Exception as E (catch) -import Network.HTTP.Conduit.ConnInfo import Network (withSocketsDo) import Network.Socket (sClose) import qualified Network.BSD @@ -24,7 +23,7 @@ import Data.Conduit.Network (runTCPServer, serverSettings, HostPreference (..), appSink, appSource, bindPort, serverAfterBind, ServerSettings) import qualified Data.Conduit.Network import System.IO.Unsafe (unsafePerformIO) -import Data.Conduit (($$), yield, Flush (Chunk, Flush), runResourceT, await) +import Data.Conduit (($$), ($$+-), yield, Flush (Chunk, Flush), await) import Control.Monad (void, forever) import Control.Monad.IO.Class (liftIO) import Data.ByteString.UTF8 (fromString) @@ -35,11 +34,13 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.ByteString.Lazy as L -import Blaze.ByteString.Builder (fromByteString, toByteString) +import Blaze.ByteString.Builder (fromByteString) import System.IO -import Data.Monoid (mconcat) import Data.Time.Clock import Data.Time.Calendar +import qualified Network.Wai.Handler.WarpTLS as WT +import Network.Connection (settingDisableCertificateValidation) +import Data.Default (def) past :: UTCTime past = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0) @@ -82,7 +83,7 @@ [(hLocation, S.append "/infredir/" $ S8.pack $ show $ i+1)] (L8.pack $ show i) ["dump_cookies"] -> return $ responseLBS status200 [] $ L.fromChunks $ return $ maybe "" id $ lookup hCookie $ Wai.requestHeaders req - ["delayed"] -> return $ ResponseSource status200 [("foo", "bar")] $ do + ["delayed"] -> return $ responseSource status200 [("foo", "bar")] $ do yield Flush liftIO $ threadDelay 30000000 yield $ Chunk $ fromByteString "Hello World!" @@ -118,6 +119,21 @@ killThread (const $ takeMVar baton >> f port) +withAppTls :: Application -> (Int -> IO ()) -> IO () +withAppTls app' f = withAppTls' (const app') f + +withAppTls' :: (Int -> Application) -> (Int -> IO ()) -> IO () +withAppTls' app' f = do + port <- getPort + baton <- newEmptyMVar + bracket + (forkIO $ WT.runTLS WT.defaultTlsSettings defaultSettings + { settingsPort = port + , settingsBeforeMainLoop = putMVar baton () + } (app' port) `onException` putMVar baton ()) + killThread + (const $ takeMVar baton >> f port) + main :: IO () main = withSocketsDo $ do mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr] @@ -130,15 +146,15 @@ it "throws exception on 404" $ withApp app $ \port -> do elbs <- try $ simpleHttp $ concat ["http://127.0.0.1:", show port, "/404"] case elbs of - Left (_ :: SomeException) -> return () - Right _ -> error "Expected an exception" + Left (StatusCodeException _ _ _) -> return () + _ -> error "Expected an exception" describe "httpLbs" $ do it "preserves 'set-cookie' headers" $ withApp app $ \port -> do request <- parseUrl $ concat ["http://127.0.0.1:", show port, "/cookies"] withManager $ \manager -> do response <- httpLbs request manager let setCookie = mk (fromString "Set-Cookie") - (setCookieHeaders, _) = partition ((== setCookie) . fst) (responseHeaders response) + (setCookieHeaders, _) = partition ((== setCookie) . fst) (NHC.responseHeaders response) liftIO $ assertBool "response contains a 'set-cookie' header" $ length setCookieHeaders > 0 it "redirects set cookies" $ withApp app $ \port -> do request <- parseUrl $ concat ["http://127.0.0.1:", show port, "/cookie_redir1"] @@ -171,9 +187,18 @@ withManager $ \manager -> do response <- httpLbs (request {cookieJar = Nothing}) manager liftIO $ (responseCookieJar response) @?= def + it "TLS" $ withAppTls app $ \port -> do + request <- parseUrl $ "https://127.0.0.1:" ++ show port + let set = mkManagerSettings + def + { settingDisableCertificateValidation = True + } + Nothing + response <- withManagerSettings set $ httpLbs request + responseBody response @?= "homepage" describe "manager" $ do it "closes all connections" $ withApp app $ \port1 -> withApp app $ \port2 -> do - clearSocketsList + --FIXME clearSocketsList withManager $ \manager -> do let Just req1 = parseUrl $ "http://127.0.0.1:" ++ show port1 let Just req2 = parseUrl $ "http://127.0.0.1:" ++ show port2 @@ -181,7 +206,15 @@ _res1b <- http req1 manager _res2 <- http req2 manager return () - requireAllSocketsClosed + --FIXME requireAllSocketsClosed + describe "http" $ do + it "response body" $ withApp app $ \port -> do + withManager $ \manager -> do + req <- parseUrl $ "http://127.0.0.1:" ++ show port + res1 <- http req manager + bss <- responseBody res1 $$+- CL.consume + res2 <- httpLbs req manager + liftIO $ L.fromChunks bss `shouldBe` responseBody res2 describe "DOS protection" $ do it "overlong headers" $ overLongHeaders $ \port -> do withManager $ \manager -> do @@ -214,18 +247,21 @@ let Just req = parseUrl $ concat ["http://127.0.0.1:", show port, "/infredir/0"] let go (res, i) = liftIO $ responseBody res @?= (L8.pack $ show i) E.catch (withManager $ \manager -> do - void $ http req{redirectCount=5} manager) $ - \(TooManyRedirects redirs) -> mapM_ go (zip redirs [5,4..0 :: Int]) + void $ http req{redirectCount=5} manager) $ \e -> + case e of + TooManyRedirects redirs -> + mapM_ go (zip redirs [5,4..0 :: Int]) + _ -> error $ show e describe "chunked request body" $ do it "works" $ echo $ \port -> do withManager $ \manager -> do let go bss = do let Just req1 = parseUrl $ "http://127.0.0.1:" ++ show port - src = sourceList $ map fromByteString bss + src = sourceList bss lbs = L.fromChunks bss res <- httpLbs req1 { method = "POST" - , requestBody = RequestBodySourceChunked src + , requestBody = requestBodySourceChunked src } manager liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200 let ts = S.concat . L.toChunks @@ -257,7 +293,7 @@ withManager $ \manager -> do eres <- try $ httpLbs req manager liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres - `shouldBe` Left (show InvalidChunkHeaders) + `shouldBe` Left (show IncompleteHeaders) it "incomplete chunk" $ wrongLengthChunk2 $ \port -> do req <- parseUrl $ "http://127.0.0.1:" ++ show port withManager $ \manager -> do @@ -294,7 +330,7 @@ let app' port req = case pathInfo req of ["foo"] -> return $ responseLBS status200 [] "Hello World!" - _ -> return $ ResponseSource status301 [("location", S8.pack $ "http://127.0.0.1:" ++ show port ++ "/foo")] $ forever $ yield $ Chunk $ fromByteString "hello\n" + _ -> return $ responseSource status301 [("location", S8.pack $ "http://127.0.0.1:" ++ show port ++ "/foo")] $ forever $ yield $ Chunk $ fromByteString "hello\n" withApp' app' $ \port -> withManager $ \manager -> do req <- parseUrl $ "http://127.0.0.1:" ++ show port res <- httpLbs req manager @@ -304,7 +340,7 @@ describe "multipart/form-data" $ do it "formats correctly" $ do let bd = "---------------------------190723902820679116301912680260" - (RequestBodySource _ src) <- renderParts bd + (RequestBodyStream _ givesPopper) <- renderParts bd [partBS "email" "" ,partBS "parent_id" "70488" ,partBS "captcha" "" @@ -312,7 +348,14 @@ ,partBS "text" $ TE.encodeUtf8 ">>72127\r\nМы работаем над этим." ,partFileSource "upload" "nyan.gif" ] - mfd <- fmap (toByteString . mconcat) $ runResourceT $ src $$ CL.consume + ires <- I.newIORef S.empty + let loop front popper = do + bs <- popper + if S.null bs + then I.writeIORef ires $ S.concat $ front [] + else loop (front . (bs:)) popper + givesPopper $ loop id + mfd <- I.readIORef ires exam <- S.readFile "multipart-example.bin" mfd @?= exam @@ -339,7 +382,7 @@ it "works" $ withApp app $ \port -> do req1 <- parseUrl $ "http://localhost:" ++ show port let req2 = req1 { responseTimeout = Just 5000000 } - withManagerSettings def { managerResponseTimeout = Just 1 } $ \man -> do + withManagerSettings conduitManagerSettings { managerResponseTimeout = Just 1 } $ \man -> do eres1 <- try $ httpLbs req1 { NHC.path = "/delayed" } man case eres1 of Left (FailedConnectionException _ _) -> return ()