diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,25 +1,25 @@ -The following license covers this documentation, and the source code, except -where otherwise indicated. - -Copyright 2010, Michael Snoyman. All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -* Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - -* Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR -IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO -EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, -INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT -NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, -OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE -OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2010, Michael Snoyman. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Network/HTTP/Conduit.hs b/Network/HTTP/Conduit.hs --- a/Network/HTTP/Conduit.hs +++ b/Network/HTTP/Conduit.hs @@ -1,312 +1,312 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} --- | 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 --- examples: --- --- > -- Just download an HTML document and print it. --- > import Network.HTTP.Conduit --- > import qualified Data.ByteString.Lazy as L --- > --- > main = simpleHttp "http://www.haskell.org/" >>= L.putStr --- --- This example uses interleaved IO to write the response body to a file in --- constant memory space. --- --- > import Data.Conduit.Binary (sinkFile) --- > import Network.HTTP.Conduit --- > import qualified Data.Conduit as C --- > --- > main :: IO () --- > main = do --- > request <- parseUrl "http://google.com/" --- > withManager $ \manager -> do --- > Response _ _ _ src <- http request manager --- > src C.$$+- sinkFile "google.html" --- --- The following headers are automatically set by this module, and should not --- be added to 'requestHeaders': --- --- * Content-Length --- --- Note: In previous versions, the Host header would be set by this module in --- all cases. Starting from 1.6.1, if a Host header is present in --- @requestHeaders@, it will be used in place of the header this module would --- have generated. This can be useful for calling a server which utilizes --- virtual hosting. --- --- Any network code on Windows requires some initialization, and the network --- library provides withSocketsDo to perform it. Therefore, proper usage of --- this library will always involve calling that function at some point. The --- best approach is to simply call them at the beginning of your main function, --- such as: --- --- > import Network.HTTP.Conduit --- > import qualified Data.ByteString.Lazy as L --- > import Network (withSocketsDo) --- > --- > main = withSocketsDo --- > $ simpleHttp "http://www.haskell.org/" >>= L.putStr --- > --- > Cookies are implemented according to RFC 6265. --- --- Note that by default, the functions in this package will throw exceptions --- for non-2xx status codes. If you would like to avoid this, you should use --- 'checkStatus', e.g.: --- --- > import Data.Conduit.Binary (sinkFile) --- > import Network.HTTP.Conduit --- > import qualified Data.Conduit as C --- > import Network --- > --- > main :: IO () --- > main = withSocketsDo $ do --- > request' <- parseUrl "http://www.yesodweb.com/does-not-exist" --- > let request = request' { checkStatus = \_ _ -> Nothing } --- > res <- withManager $ httpLbs request --- > print res -module Network.HTTP.Conduit - ( -- * Perform a request - simpleHttp - , httpLbs - , http - -- * Datatypes - , Proxy (..) - , RequestBody (..) - , Response (..) - -- ** Request - , Request - , def - , method - , secure - , clientCertificates - , host - , port - , path - , queryString - , requestHeaders - , requestBody - , proxy - , socksProxy - , rawBody - , decompress - , redirectCount - , checkStatus - , responseTimeout - -- * Manager - , Manager - , newManager - , closeManager - , withManager - , withManagerSettings - -- ** Settings - , ManagerSettings - , managerConnCount - , managerCheckCerts - , managerCertStore - -- *** Defaults - , defaultCheckCerts - -- * Cookies - , Cookie(..) - , CookieJar - , createCookieJar - , destroyCookieJar - , updateCookieJar - , receiveSetCookie - , generateCookie - , insertCheckedCookie - , insertCookiesIntoRequest - , computeCookieString - , evictExpiredCookies - -- * Utility functions - , parseUrl - , applyBasicAuth - , addProxy - , lbsResponse - , getRedirectedRequest - -- * Decompression predicates - , alwaysDecompress - , browserDecompress - -- * Request bodies - , urlEncodedBody - -- * Exceptions - , HttpException (..) -#if DEBUG - -- * Debug - , printOpenSockets -#endif - ) where - -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 Data.Default (def) - -import Control.Exception.Lifted (throwIO) -import Control.Monad ((<=<)) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.Control (MonadBaseControl) - -import Control.Exception (fromException, toException) -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 Data.Conduit.Blaze (builderToByteString) -import Data.Conduit (MonadResource) -import Control.Exception.Lifted (try, SomeException) - -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 - --- | 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. --- --- 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 = do - res@(Response status _version hs body) <- - if redirectCount req0 == 0 - then httpRaw req0 manager - else go (redirectCount req0) req0 def [] - case checkStatus req0 status hs of - Nothing -> return res - Just exc -> do - exc' <- - case fromException exc of - Just (StatusCodeException s hdrs) -> do - lbs <- body C.$$+- CB.take 1024 - return $ toException $ StatusCodeException s $ hdrs ++ - [("X-Response-Body-Start", S.concat $ L.toChunks lbs)] - _ -> do - let CI.ResumableSource _ final = body - final - return exc - liftIO $ throwIO exc' - where - go (-1) _ _ ress = liftIO . throwIO . TooManyRedirects =<< mapM lbsResponse ress - go count req'' cookie_jar'' ress = do - now <- liftIO getCurrentTime - let (req', cookie_jar') = insertCookiesIntoRequest req'' (evictExpiredCookies cookie_jar'' now) now - res <- httpRaw req' manager - let (cookie_jar, _) = updateCookieJar res req' now cookie_jar' - case getRedirectedRequest req' (responseHeaders res) (W.statusCode (responseStatus res)) 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 - responseBody res C.$$+- sink - - -- And now perform the actual redirect - go (count - 1) req cookie_jar (res:ress) - Nothing -> return res - --- | 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 - (connRelease, ci, isManaged) <- 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 req src - - case (ex, isManaged) of - -- Connection was reused, and might be been closed. Try again - (Left _, Reused) -> do - connRelease DontReuse - http req m - -- Not reused, so this is a real exception - (Left e, Fresh) -> 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 x, _) -> return x - where - try' :: MonadBaseControl IO m => m a -> m (Either SomeException a) - try' = try - --- | Download the specified 'Request', returning the results as a 'Response'. --- --- This is a simplified version of 'http' for the common case where you simply --- want the response data as a simple datatype. If you want more power, such as --- interleaved actions on the response body during download, you'll need to use --- 'http' directly. This function is defined as: --- --- @httpLbs = 'lbsResponse' <=< 'http'@ --- --- Even though the 'Response' contains a lazy bytestring, this --- function does /not/ utilize lazy I/O, and therefore the entire --- response body will live in memory. If you want constant memory --- usage, you'll need to use @conduit@ packages's --- 'C.Source' returned by 'http'. --- --- 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 = lbsResponse <=< http r - --- | Download the specified URL, following any redirects, and --- return the response body. --- --- This function will 'throwIO' an 'HttpException' for any --- response with a non-2xx status code (besides 3xx redirects up --- to a limit of 10 redirects). It uses 'parseUrl' to parse the --- input. This function essentially wraps 'httpLbs'. --- --- Note: Even though this function returns a lazy bytestring, it --- does /not/ utilize lazy I/O, and therefore the entire response --- body will live in memory. If you want constant memory usage, --- you'll need to use the @conduit@ package and 'http' directly. --- --- Note: This function creates a new 'Manager'. It should be avoided --- in production code. -simpleHttp :: MonadIO m => String -> m L.ByteString -simpleHttp url = liftIO $ withManager $ \man -> do - url' <- liftIO $ parseUrl url - fmap responseBody $ httpLbs url' man +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +-- | 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 +-- examples: +-- +-- > -- Just download an HTML document and print it. +-- > import Network.HTTP.Conduit +-- > import qualified Data.ByteString.Lazy as L +-- > +-- > main = simpleHttp "http://www.haskell.org/" >>= L.putStr +-- +-- This example uses interleaved IO to write the response body to a file in +-- constant memory space. +-- +-- > import Data.Conduit.Binary (sinkFile) +-- > import Network.HTTP.Conduit +-- > import qualified Data.Conduit as C +-- > +-- > main :: IO () +-- > main = do +-- > request <- parseUrl "http://google.com/" +-- > withManager $ \manager -> do +-- > Response _ _ _ src <- http request manager +-- > src C.$$+- sinkFile "google.html" +-- +-- The following headers are automatically set by this module, and should not +-- be added to 'requestHeaders': +-- +-- * Content-Length +-- +-- Note: In previous versions, the Host header would be set by this module in +-- all cases. Starting from 1.6.1, if a Host header is present in +-- @requestHeaders@, it will be used in place of the header this module would +-- have generated. This can be useful for calling a server which utilizes +-- virtual hosting. +-- +-- Any network code on Windows requires some initialization, and the network +-- library provides withSocketsDo to perform it. Therefore, proper usage of +-- this library will always involve calling that function at some point. The +-- best approach is to simply call them at the beginning of your main function, +-- such as: +-- +-- > import Network.HTTP.Conduit +-- > import qualified Data.ByteString.Lazy as L +-- > import Network (withSocketsDo) +-- > +-- > main = withSocketsDo +-- > $ simpleHttp "http://www.haskell.org/" >>= L.putStr +-- > +-- > Cookies are implemented according to RFC 6265. +-- +-- Note that by default, the functions in this package will throw exceptions +-- for non-2xx status codes. If you would like to avoid this, you should use +-- 'checkStatus', e.g.: +-- +-- > import Data.Conduit.Binary (sinkFile) +-- > import Network.HTTP.Conduit +-- > import qualified Data.Conduit as C +-- > import Network +-- > +-- > main :: IO () +-- > main = withSocketsDo $ do +-- > request' <- parseUrl "http://www.yesodweb.com/does-not-exist" +-- > let request = request' { checkStatus = \_ _ -> Nothing } +-- > res <- withManager $ httpLbs request +-- > print res +module Network.HTTP.Conduit + ( -- * Perform a request + simpleHttp + , httpLbs + , http + -- * Datatypes + , Proxy (..) + , RequestBody (..) + , Response (..) + -- ** Request + , Request + , def + , method + , secure + , clientCertificates + , host + , port + , path + , queryString + , requestHeaders + , requestBody + , proxy + , socksProxy + , rawBody + , decompress + , redirectCount + , checkStatus + , responseTimeout + -- * Manager + , Manager + , newManager + , closeManager + , withManager + , withManagerSettings + -- ** Settings + , ManagerSettings + , managerConnCount + , managerCheckCerts + , managerCertStore + -- *** Defaults + , defaultCheckCerts + -- * Cookies + , Cookie(..) + , CookieJar + , createCookieJar + , destroyCookieJar + , updateCookieJar + , receiveSetCookie + , generateCookie + , insertCheckedCookie + , insertCookiesIntoRequest + , computeCookieString + , evictExpiredCookies + -- * Utility functions + , parseUrl + , applyBasicAuth + , addProxy + , lbsResponse + , getRedirectedRequest + -- * Decompression predicates + , alwaysDecompress + , browserDecompress + -- * Request bodies + , urlEncodedBody + -- * Exceptions + , HttpException (..) +#if DEBUG + -- * Debug + , printOpenSockets +#endif + ) where + +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 Data.Default (def) + +import Control.Exception.Lifted (throwIO) +import Control.Monad ((<=<)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Control (MonadBaseControl) + +import Control.Exception (fromException, toException) +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 Data.Conduit.Blaze (builderToByteString) +import Data.Conduit (MonadResource) +import Control.Exception.Lifted (try, SomeException) + +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 + +-- | 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. +-- +-- 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 = do + res@(Response status _version hs body) <- + if redirectCount req0 == 0 + then httpRaw req0 manager + else go (redirectCount req0) req0 def [] + case checkStatus req0 status hs of + Nothing -> return res + Just exc -> do + exc' <- + case fromException exc of + Just (StatusCodeException s hdrs) -> do + lbs <- body C.$$+- CB.take 1024 + return $ toException $ StatusCodeException s $ hdrs ++ + [("X-Response-Body-Start", S.concat $ L.toChunks lbs)] + _ -> do + let CI.ResumableSource _ final = body + final + return exc + liftIO $ throwIO exc' + where + go (-1) _ _ ress = liftIO . throwIO . TooManyRedirects =<< mapM lbsResponse ress + go count req'' cookie_jar'' ress = do + now <- liftIO getCurrentTime + let (req', cookie_jar') = insertCookiesIntoRequest req'' (evictExpiredCookies cookie_jar'' now) now + res <- httpRaw req' manager + let (cookie_jar, _) = updateCookieJar res req' now cookie_jar' + case getRedirectedRequest req' (responseHeaders res) (W.statusCode (responseStatus res)) 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 + responseBody res C.$$+- sink + + -- And now perform the actual redirect + go (count - 1) req cookie_jar (res:ress) + Nothing -> return res + +-- | 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 + (connRelease, ci, isManaged) <- 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 req src + + case (ex, isManaged) of + -- Connection was reused, and might be been closed. Try again + (Left _, Reused) -> do + connRelease DontReuse + http req m + -- Not reused, so this is a real exception + (Left e, Fresh) -> 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 x, _) -> return x + where + try' :: MonadBaseControl IO m => m a -> m (Either SomeException a) + try' = try + +-- | Download the specified 'Request', returning the results as a 'Response'. +-- +-- This is a simplified version of 'http' for the common case where you simply +-- want the response data as a simple datatype. If you want more power, such as +-- interleaved actions on the response body during download, you'll need to use +-- 'http' directly. This function is defined as: +-- +-- @httpLbs = 'lbsResponse' <=< 'http'@ +-- +-- Even though the 'Response' contains a lazy bytestring, this +-- function does /not/ utilize lazy I/O, and therefore the entire +-- response body will live in memory. If you want constant memory +-- usage, you'll need to use @conduit@ packages's +-- 'C.Source' returned by 'http'. +-- +-- 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 = lbsResponse <=< http r + +-- | Download the specified URL, following any redirects, and +-- return the response body. +-- +-- This function will 'throwIO' an 'HttpException' for any +-- response with a non-2xx status code (besides 3xx redirects up +-- to a limit of 10 redirects). It uses 'parseUrl' to parse the +-- input. This function essentially wraps 'httpLbs'. +-- +-- Note: Even though this function returns a lazy bytestring, it +-- does /not/ utilize lazy I/O, and therefore the entire response +-- body will live in memory. If you want constant memory usage, +-- you'll need to use the @conduit@ package and 'http' directly. +-- +-- Note: This function creates a new 'Manager'. It should be avoided +-- in production code. +simpleHttp :: MonadIO m => String -> m L.ByteString +simpleHttp url = liftIO $ withManager $ \man -> do + url' <- liftIO $ parseUrl url + fmap responseBody $ httpLbs url' man diff --git a/Network/HTTP/Conduit/Chunk.hs b/Network/HTTP/Conduit/Chunk.hs --- a/Network/HTTP/Conduit/Chunk.hs +++ b/Network/HTTP/Conduit/Chunk.hs @@ -1,64 +1,64 @@ -{-# 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 hiding (Source, Sink, Conduit) -import qualified Data.Conduit.Binary as CB - -import Control.Monad (when, unless) -import Control.Exception (assert) - -chunkedConduit :: MonadThrow m - => Bool -- ^ send the headers as well, necessary for a proxy - -> Pipe S.ByteString S.ByteString S.ByteString u m () -chunkedConduit sendHeaders = do - i <- getLen - when sendHeaders $ yield $ S8.pack $ showHex i "\r\n" - unless (i == 0) $ do - CB.isolate i - CB.drop 2 - chunkedConduit sendHeaders - -getLen :: Monad m => Pipe S.ByteString S.ByteString o u m Int -getLen = - start 0 - 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 (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 => Pipe l Blaze.Builder Blaze.Builder r m r -chunkIt = - awaitE >>= either - (\u -> yield chunkedTransferTerminator >> return u) - (\x -> yield (chunkedTransferEncoding x) >> chunkIt) +{-# 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 hiding (Source, Sink, Conduit) +import qualified Data.Conduit.Binary as CB + +import Control.Monad (when, unless) +import Control.Exception (assert) + +chunkedConduit :: MonadThrow m + => Bool -- ^ send the headers as well, necessary for a proxy + -> Pipe S.ByteString S.ByteString S.ByteString u m () +chunkedConduit sendHeaders = do + i <- getLen + when sendHeaders $ yield $ S8.pack $ showHex i "\r\n" + unless (i == 0) $ do + CB.isolate i + CB.drop 2 + chunkedConduit sendHeaders + +getLen :: Monad m => Pipe S.ByteString S.ByteString o u m Int +getLen = + start 0 + 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 (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 => Pipe l Blaze.Builder Blaze.Builder r m r +chunkIt = + awaitE >>= either + (\u -> yield chunkedTransferTerminator >> return u) + (\x -> yield (chunkedTransferEncoding x) >> chunkIt) diff --git a/Network/HTTP/Conduit/ConnInfo.hs b/Network/HTTP/Conduit/ConnInfo.hs --- a/Network/HTTP/Conduit/ConnInfo.hs +++ b/Network/HTTP/Conduit/ConnInfo.hs @@ -1,173 +1,173 @@ -{-# 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 (SomeException, throwIO, try) -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) -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 hiding (Source, Sink, 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 -> Pipe l ByteString o r m r -connSink ConnInfo { connWrite = write } = - self - where - self = awaitE >>= either return (\x -> liftIO (write x) >> self) - -connSource :: MonadResource m => ConnInfo -> Pipe l i ByteString u m () -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 -> ([X509] -> IO CertificateUsage) -> [(X509, Maybe PrivateKey)] -> Handle -> IO ConnInfo -sslClientConn _desc onCerts clientCerts h = do -#if DEBUG - i <- addSocket _desc -#endif - let setCParams cparams = cparams { onCertificateRequest = const (return clientCerts) } - 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 - hClose h - } - where - recvD istate = do - x <- recvData istate - if S.null x - then recvD istate - else return x - -getSocket :: String -> Int -> Maybe SocksConf -> IO NS.Socket -getSocket host' port' (Just socksConf) = do - socksConnectWith socksConf host' (PortNumber $ fromIntegral port') -getSocket host' port' Nothing = do - let hints = NS.defaultHints { - NS.addrFlags = [NS.AI_ADDRCONFIG] - , NS.addrSocketType = NS.Stream - } - (addr:_) <- NS.getAddrInfo (Just hints) (Just host') (Just $ show port') - sock <- NS.socket (NS.addrFamily addr) (NS.addrSocketType addr) - (NS.addrProtocol addr) - NS.setSocketOption sock NS.NoDelay 1 - ee <- try' $ NS.connect sock (NS.addrAddress addr) - case ee of - Left e -> NS.sClose sock >> throwIO e - Right () -> return sock - where - try' :: IO a -> IO (Either SomeException a) - try' = try +{-# 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 (SomeException, throwIO, try) +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) +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 hiding (Source, Sink, 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 -> Pipe l ByteString o r m r +connSink ConnInfo { connWrite = write } = + self + where + self = awaitE >>= either return (\x -> liftIO (write x) >> self) + +connSource :: MonadResource m => ConnInfo -> Pipe l i ByteString u m () +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 -> ([X509] -> IO CertificateUsage) -> [(X509, Maybe PrivateKey)] -> Handle -> IO ConnInfo +sslClientConn _desc onCerts clientCerts h = do +#if DEBUG + i <- addSocket _desc +#endif + let setCParams cparams = cparams { onCertificateRequest = const (return clientCerts) } + 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 + hClose h + } + where + recvD istate = do + x <- recvData istate + if S.null x + then recvD istate + else return x + +getSocket :: String -> Int -> Maybe SocksConf -> IO NS.Socket +getSocket host' port' (Just socksConf) = do + socksConnectWith socksConf host' (PortNumber $ fromIntegral port') +getSocket host' port' Nothing = do + let hints = NS.defaultHints { + NS.addrFlags = [NS.AI_ADDRCONFIG] + , NS.addrSocketType = NS.Stream + } + (addr:_) <- NS.getAddrInfo (Just hints) (Just host') (Just $ show port') + sock <- NS.socket (NS.addrFamily addr) (NS.addrSocketType addr) + (NS.addrProtocol addr) + NS.setSocketOption sock NS.NoDelay 1 + ee <- try' $ NS.connect sock (NS.addrAddress addr) + case ee of + Left e -> NS.sClose sock >> throwIO e + Right () -> return sock + where + try' :: IO a -> IO (Either SomeException a) + try' = try diff --git a/Network/HTTP/Conduit/Cookies.hs b/Network/HTTP/Conduit/Cookies.hs --- a/Network/HTTP/Conduit/Cookies.hs +++ b/Network/HTTP/Conduit/Cookies.hs @@ -1,270 +1,270 @@ --- | 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 Data.Default - -import qualified Network.HTTP.Conduit.Request as Req -import qualified Network.HTTP.Conduit.Response as Res - -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 - - --- This corresponds to the description of a cookie detailed in Section 5.3 \"Storage Model\" -data Cookie = Cookie - { cookie_name :: BS.ByteString - , cookie_value :: BS.ByteString - , cookie_expiry_time :: UTCTime - , cookie_domain :: BS.ByteString - , cookie_path :: BS.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 (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 - | BS.length (cookie_path c1) > BS.length (cookie_path c2) = LT - | BS.length (cookie_path c1) < BS.length (cookie_path c2) = GT - | cookie_creation_time c1 > cookie_creation_time c2 = GT - | otherwise = LT - -newtype CookieJar = CJ { expose :: [Cookie] } - --- | empty cookie jar -instance Default CookieJar where - def = CJ [] - -instance Eq CookieJar where - (==) cj1 cj2 = (L.sort $ expose cj1) == (L.sort $ expose cj2) - -instance Show CookieJar where - show = show . expose - -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 _ = False - --- | 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 && isPublicSuffix 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) +-- | 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 Data.Default + +import qualified Network.HTTP.Conduit.Request as Req +import qualified Network.HTTP.Conduit.Response as Res + +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 + + +-- This corresponds to the description of a cookie detailed in Section 5.3 \"Storage Model\" +data Cookie = Cookie + { cookie_name :: BS.ByteString + , cookie_value :: BS.ByteString + , cookie_expiry_time :: UTCTime + , cookie_domain :: BS.ByteString + , cookie_path :: BS.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 (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 + | BS.length (cookie_path c1) > BS.length (cookie_path c2) = LT + | BS.length (cookie_path c1) < BS.length (cookie_path c2) = GT + | cookie_creation_time c1 > cookie_creation_time c2 = GT + | otherwise = LT + +newtype CookieJar = CJ { expose :: [Cookie] } + +-- | empty cookie jar +instance Default CookieJar where + def = CJ [] + +instance Eq CookieJar where + (==) cj1 cj2 = (L.sort $ expose cj1) == (L.sort $ expose cj2) + +instance Show CookieJar where + show = show . expose + +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 _ = False + +-- | 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 && isPublicSuffix 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 --- a/Network/HTTP/Conduit/Internal.hs +++ b/Network/HTTP/Conduit/Internal.hs @@ -1,5 +1,5 @@ -module Network.HTTP.Conduit.Internal - ( module Network.HTTP.Conduit.Parser - ) where - -import Network.HTTP.Conduit.Parser +module Network.HTTP.Conduit.Internal + ( module Network.HTTP.Conduit.Parser + ) where + +import Network.HTTP.Conduit.Parser diff --git a/Network/HTTP/Conduit/Manager.hs b/Network/HTTP/Conduit/Manager.hs --- a/Network/HTTP/Conduit/Manager.hs +++ b/Network/HTTP/Conduit/Manager.hs @@ -1,471 +1,471 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -module Network.HTTP.Conduit.Manager - ( Manager - , ManagerSettings (..) - , ConnKey (..) - , newManager - , closeManager - , getConn - , ConnReuse (..) - , withManager - , withManagerSettings - , ConnRelease - , ManagedConn (..) - , defaultCheckCerts - ) 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) -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 Network (connectTo, PortID (PortNumber), HostName) -import Network.Socket (socketToHandle) -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.Util (hGetSome) -import Network.HTTP.Conduit.Parser (parserHeadersFromByteString) -import Network.HTTP.Conduit.Request -import Network.Socks5 (SocksConf, socksConnectWith) -import Data.Default -import Data.Maybe (mapMaybe) -import System.IO (Handle) - --- | 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. - } - -type X509Encoded = L.ByteString - -instance Default ManagerSettings where - def = ManagerSettings - { managerConnCount = 10 - , managerCheckCerts = defaultCheckCerts - , managerCertStore = getSystemCertificateStore - } - --- | 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. - } - -data NonEmptyList a = - One !a !UTCTime | - Cons !a !Int !UTCTime !(NonEmptyList a) - --- | @ConnKey@ consists of a hostname, a port and a @Bool@ --- specifying whether to use SSL. -data ConnKey = ConnKey !Text !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) - certCache <- I.newIORef Map.empty - _ <- forkIO $ reap mapRef certCache - return $ Manager mapRef (managerConnCount ms) (\x y -> getCertStore >>= \cs -> managerCheckCerts ms cs x y) certCache - --- | Collect and destroy any stale connections. -reap :: I.IORef (Maybe (Map.Map ConnKey (NonEmptyList ConnInfo))) - -> I.IORef (Map.Map S8.ByteString (Map.Map X509Encoded UTCTime)) - -> IO () -reap mapRef certCacheRef = - mask_ loop - where - loop = do - threadDelay (5 * 1000 * 1000) - 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. -closeManager :: Manager -> IO () -closeManager manager = mask_ $ do - m <- I.atomicModifyIORef (mConns manager) $ \x -> (Nothing, x) - mapM_ (nonEmptyMapM_ safeConnClose) $ maybe [] Map.elems m - -safeConnClose :: ConnInfo -> IO () -safeConnClose ci = connClose ci `catch` \(_::SomeException) -> 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 - :: MonadResource m - => Manager - -> String - -> Int - -> Maybe SocksConf -- ^ optional socks proxy - -> m (ConnRelease m, ConnInfo, ManagedConn) -getSocketConn man host' port' socksProxy' = - getManagedConn man (ConnKey (T.pack host') port' False) $ - getSocket 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 :: MonadResource m - => ([X509] -> IO CertificateUsage) - -> [(X509, Maybe PrivateKey)] - -> Manager - -> String -- ^ host - -> Int -- ^ port - -> Maybe SocksConf -- ^ optional socks proxy - -> m (ConnRelease m, ConnInfo, ManagedConn) -getSslConn checkCert clientCerts man host' port' socksProxy' = - getManagedConn man (ConnKey (T.pack host') port' True) $ - (connectionTo host' (PortNumber $ fromIntegral port') socksProxy' >>= sslClientConn desc checkCert clientCerts) - where - desc = socketDesc host' port' "secured" - -getSslProxyConn - :: MonadResource m - => ([X509] -> IO CertificateUsage) - -> [(X509, Maybe PrivateKey)] - -> S8.ByteString -- ^ Target host - -> Int -- ^ Target port - -> Manager - -> String -- ^ Proxy host - -> Int -- ^ Proxy port - -> Maybe SocksConf -- ^ optional SOCKS proxy - -> m (ConnRelease m, ConnInfo, ManagedConn) -getSslProxyConn checkCert clientCerts thost tport man phost pport socksProxy' = - getManagedConn man (ConnKey (T.pack phost) pport True) $ - doConnect >>= sslClientConn desc checkCert clientCerts - where - desc = socketDesc phost pport "secured-proxy" - doConnect = do - h <- connectionTo phost (PortNumber $ fromIntegral pport) socksProxy' - L.hPutStr h $ Blaze.toLazyByteString connectRequest - hFlush h - r <- hGetSome h 2048 - res <- parserHeadersFromByteString r - case res of - Right ((_, 200, _), _) -> return h - Right ((_, _, msg), _) -> hClose h >> proxyError (S8.unpack msg) - Left s -> hClose h >> proxyError 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 = - error $ "Proxy failed to CONNECT to '" - ++ S8.unpack thost ++ ":" ++ show tport ++ "' : " ++ s - -data ManagedConn = Fresh | Reused - --- | 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) - -data ConnReuse = Reuse | DontReuse - -type ConnRelease m = ConnReuse -> m () - -getConn :: MonadResource m - => Request m - -> Manager - -> m (ConnRelease m, ConnInfo, ManagedConn) -getConn req m = - go m connhost connport (socksProxy req) - where - h = host req - (useProxy, connhost, connport) = - case proxy req of - Just p -> (True, S8.unpack (proxyHost p), proxyPort p) - Nothing -> (False, S8.unpack h, port req) - 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 :: HostName -> PortID -> Maybe SocksConf -> IO Handle -connectionTo host' port' Nothing = connectTo host' port' -connectionTo host' port' (Just socksConf) = - socksConnectWith socksConf host' port' >>= flip socketToHandle ReadWriteMode +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +module Network.HTTP.Conduit.Manager + ( Manager + , ManagerSettings (..) + , ConnKey (..) + , newManager + , closeManager + , getConn + , ConnReuse (..) + , withManager + , withManagerSettings + , ConnRelease + , ManagedConn (..) + , defaultCheckCerts + ) 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) +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 Network (connectTo, PortID (PortNumber), HostName) +import Network.Socket (socketToHandle) +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.Util (hGetSome) +import Network.HTTP.Conduit.Parser (parserHeadersFromByteString) +import Network.HTTP.Conduit.Request +import Network.Socks5 (SocksConf, socksConnectWith) +import Data.Default +import Data.Maybe (mapMaybe) +import System.IO (Handle) + +-- | 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. + } + +type X509Encoded = L.ByteString + +instance Default ManagerSettings where + def = ManagerSettings + { managerConnCount = 10 + , managerCheckCerts = defaultCheckCerts + , managerCertStore = getSystemCertificateStore + } + +-- | 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. + } + +data NonEmptyList a = + One !a !UTCTime | + Cons !a !Int !UTCTime !(NonEmptyList a) + +-- | @ConnKey@ consists of a hostname, a port and a @Bool@ +-- specifying whether to use SSL. +data ConnKey = ConnKey !Text !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) + certCache <- I.newIORef Map.empty + _ <- forkIO $ reap mapRef certCache + return $ Manager mapRef (managerConnCount ms) (\x y -> getCertStore >>= \cs -> managerCheckCerts ms cs x y) certCache + +-- | Collect and destroy any stale connections. +reap :: I.IORef (Maybe (Map.Map ConnKey (NonEmptyList ConnInfo))) + -> I.IORef (Map.Map S8.ByteString (Map.Map X509Encoded UTCTime)) + -> IO () +reap mapRef certCacheRef = + mask_ loop + where + loop = do + threadDelay (5 * 1000 * 1000) + 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. +closeManager :: Manager -> IO () +closeManager manager = mask_ $ do + m <- I.atomicModifyIORef (mConns manager) $ \x -> (Nothing, x) + mapM_ (nonEmptyMapM_ safeConnClose) $ maybe [] Map.elems m + +safeConnClose :: ConnInfo -> IO () +safeConnClose ci = connClose ci `catch` \(_::SomeException) -> 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 + :: MonadResource m + => Manager + -> String + -> Int + -> Maybe SocksConf -- ^ optional socks proxy + -> m (ConnRelease m, ConnInfo, ManagedConn) +getSocketConn man host' port' socksProxy' = + getManagedConn man (ConnKey (T.pack host') port' False) $ + getSocket 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 :: MonadResource m + => ([X509] -> IO CertificateUsage) + -> [(X509, Maybe PrivateKey)] + -> Manager + -> String -- ^ host + -> Int -- ^ port + -> Maybe SocksConf -- ^ optional socks proxy + -> m (ConnRelease m, ConnInfo, ManagedConn) +getSslConn checkCert clientCerts man host' port' socksProxy' = + getManagedConn man (ConnKey (T.pack host') port' True) $ + (connectionTo host' (PortNumber $ fromIntegral port') socksProxy' >>= sslClientConn desc checkCert clientCerts) + where + desc = socketDesc host' port' "secured" + +getSslProxyConn + :: MonadResource m + => ([X509] -> IO CertificateUsage) + -> [(X509, Maybe PrivateKey)] + -> S8.ByteString -- ^ Target host + -> Int -- ^ Target port + -> Manager + -> String -- ^ Proxy host + -> Int -- ^ Proxy port + -> Maybe SocksConf -- ^ optional SOCKS proxy + -> m (ConnRelease m, ConnInfo, ManagedConn) +getSslProxyConn checkCert clientCerts thost tport man phost pport socksProxy' = + getManagedConn man (ConnKey (T.pack phost) pport True) $ + doConnect >>= sslClientConn desc checkCert clientCerts + where + desc = socketDesc phost pport "secured-proxy" + doConnect = do + h <- connectionTo phost (PortNumber $ fromIntegral pport) socksProxy' + L.hPutStr h $ Blaze.toLazyByteString connectRequest + hFlush h + r <- hGetSome h 2048 + res <- parserHeadersFromByteString r + case res of + Right ((_, 200, _), _) -> return h + Right ((_, _, msg), _) -> hClose h >> proxyError (S8.unpack msg) + Left s -> hClose h >> proxyError 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 = + error $ "Proxy failed to CONNECT to '" + ++ S8.unpack thost ++ ":" ++ show tport ++ "' : " ++ s + +data ManagedConn = Fresh | Reused + +-- | 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) + +data ConnReuse = Reuse | DontReuse + +type ConnRelease m = ConnReuse -> m () + +getConn :: MonadResource m + => Request m + -> Manager + -> m (ConnRelease m, ConnInfo, ManagedConn) +getConn req m = + go m connhost connport (socksProxy req) + where + h = host req + (useProxy, connhost, connport) = + case proxy req of + Just p -> (True, S8.unpack (proxyHost p), proxyPort p) + Nothing -> (False, S8.unpack h, port req) + 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 :: HostName -> PortID -> Maybe SocksConf -> IO Handle +connectionTo host' port' Nothing = connectTo host' port' +connectionTo host' port' (Just socksConf) = + socksConnectWith socksConf host' port' >>= flip socketToHandle ReadWriteMode diff --git a/Network/HTTP/Conduit/Parser.hs b/Network/HTTP/Conduit/Parser.hs --- a/Network/HTTP/Conduit/Parser.hs +++ b/Network/HTTP/Conduit/Parser.hs @@ -1,123 +1,123 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -module Network.HTTP.Conduit.Parser - ( sinkHeaders - , newline - , parserHeadersFromByteString - , parseChunkHeader - ) where - -import Prelude hiding (take, takeWhile) -import Control.Applicative -import Data.Word (Word8) - -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 - -import Data.Attoparsec - -import Data.Conduit.Attoparsec (sinkParser) -import Data.Conduit (Sink, MonadResource, MonadThrow) -import Control.Monad (when) - - -type Header = (S.ByteString, S.ByteString) - -parseHeader :: Parser Header -parseHeader = do - k <- takeWhile1 notNewlineColon - _ <- word8 58 -- colon - skipWhile isSpace - v <- takeWhile notNewline - newline - return (k, v) - -notNewlineColon, isSpace, isNumber, notNewline :: Word8 -> Bool - -notNewlineColon 10 = False -- LF -notNewlineColon 13 = False -- CR -notNewlineColon 58 = False -- colon -notNewlineColon _ = True - -isSpace 32 = True -isSpace _ = False - -isNumber i = 0x30 <= i && i <= 0x39 - -notNewline 10 = False -notNewline 13 = False -notNewline _ = True - -newline :: Parser () -newline = - lf <|> (cr >> lf) - where - word8' x = word8 x >> return () - lf = word8' 10 - cr = word8' 13 - -parseHeaders :: Parser (Status, [Header]) -parseHeaders = do - s <- parseStatus "HTTP status line" - h <- manyTill parseHeader newline "Response headers" - return (s, h) - -sinkHeaders :: (MonadThrow m, MonadResource m) => Sink S.ByteString m (Status, [Header]) -sinkHeaders = sinkParser parseHeaders - - -parserHeadersFromByteString :: Monad m => S.ByteString -> m (Either String (Status, [Header])) -parserHeadersFromByteString s = return $ parseOnly parseHeaders s - - -type Status = (S.ByteString, Int, S.ByteString) - -parseStatus :: Parser Status -parseStatus = do - end <- atEnd - when end $ fail "EOF reached" - _ <- manyTill (take 1 >> return ()) (try $ string "HTTP/") "HTTP/" - ver <- takeWhile1 $ not . isSpace - _ <- word8 32 -- space - statCode <- takeWhile1 isNumber - statCode' <- - case reads $ S8.unpack statCode of - [] -> fail $ "Invalid status code: " ++ S8.unpack statCode - (x, _):_ -> return x - statMsg <- try (word8 32 >> takeWhile notNewline) <|> return "" - newline - if (statCode == "100") - then newline >> parseStatus - else return (ver, statCode', statMsg) - -parseChunkHeader :: Parser Int -parseChunkHeader = do - len <- hexs - skipWhile isSpace - newline <|> attribs - return len - -attribs :: Parser () -attribs = do - _ <- word8 59 -- colon - skipWhile notNewline - newline - -hexs :: Parser Int -hexs = do - ws <- many1 hex - return $ foldl1 (\a b -> a * 16 + b) $ map fromIntegral ws - -hex :: Parser Word8 -hex = - (digit <|> upper <|> lower) "Hexadecimal digit" - where - digit = do - d <- satisfy $ \w -> (w >= 48 && w <= 57) - return $ d - 48 - upper = do - d <- satisfy $ \w -> (w >= 65 && w <= 70) - return $ d - 55 - lower = do - d <- satisfy $ \w -> (w >= 97 && w <= 102) - return $ d - 87 +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +module Network.HTTP.Conduit.Parser + ( sinkHeaders + , newline + , parserHeadersFromByteString + , parseChunkHeader + ) where + +import Prelude hiding (take, takeWhile) +import Control.Applicative +import Data.Word (Word8) + +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 + +import Data.Attoparsec + +import Data.Conduit.Attoparsec (sinkParser) +import Data.Conduit (Sink, MonadResource, MonadThrow) +import Control.Monad (when) + + +type Header = (S.ByteString, S.ByteString) + +parseHeader :: Parser Header +parseHeader = do + k <- takeWhile1 notNewlineColon + _ <- word8 58 -- colon + skipWhile isSpace + v <- takeWhile notNewline + newline + return (k, v) + +notNewlineColon, isSpace, isNumber, notNewline :: Word8 -> Bool + +notNewlineColon 10 = False -- LF +notNewlineColon 13 = False -- CR +notNewlineColon 58 = False -- colon +notNewlineColon _ = True + +isSpace 32 = True +isSpace _ = False + +isNumber i = 0x30 <= i && i <= 0x39 + +notNewline 10 = False +notNewline 13 = False +notNewline _ = True + +newline :: Parser () +newline = + lf <|> (cr >> lf) + where + word8' x = word8 x >> return () + lf = word8' 10 + cr = word8' 13 + +parseHeaders :: Parser (Status, [Header]) +parseHeaders = do + s <- parseStatus "HTTP status line" + h <- manyTill parseHeader newline "Response headers" + return (s, h) + +sinkHeaders :: (MonadThrow m, MonadResource m) => Sink S.ByteString m (Status, [Header]) +sinkHeaders = sinkParser parseHeaders + + +parserHeadersFromByteString :: Monad m => S.ByteString -> m (Either String (Status, [Header])) +parserHeadersFromByteString s = return $ parseOnly parseHeaders s + + +type Status = (S.ByteString, Int, S.ByteString) + +parseStatus :: Parser Status +parseStatus = do + end <- atEnd + when end $ fail "EOF reached" + _ <- manyTill (take 1 >> return ()) (try $ string "HTTP/") "HTTP/" + ver <- takeWhile1 $ not . isSpace + _ <- word8 32 -- space + statCode <- takeWhile1 isNumber + statCode' <- + case reads $ S8.unpack statCode of + [] -> fail $ "Invalid status code: " ++ S8.unpack statCode + (x, _):_ -> return x + statMsg <- try (word8 32 >> takeWhile notNewline) <|> return "" + newline + if (statCode == "100") + then newline >> parseStatus + else return (ver, statCode', statMsg) + +parseChunkHeader :: Parser Int +parseChunkHeader = do + len <- hexs + skipWhile isSpace + newline <|> attribs + return len + +attribs :: Parser () +attribs = do + _ <- word8 59 -- colon + skipWhile notNewline + newline + +hexs :: Parser Int +hexs = do + ws <- many1 hex + return $ foldl1 (\a b -> a * 16 + b) $ map fromIntegral ws + +hex :: Parser Word8 +hex = + (digit <|> upper <|> lower) "Hexadecimal digit" + where + digit = do + d <- satisfy $ \w -> (w >= 48 && w <= 57) + return $ d - 48 + upper = do + d <- satisfy $ \w -> (w >= 65 && w <= 70) + return $ d - 55 + lower = do + d <- satisfy $ \w -> (w >= 97 && w <= 102) + return $ d - 87 diff --git a/Network/HTTP/Conduit/Request.hs b/Network/HTTP/Conduit/Request.hs --- a/Network/HTTP/Conduit/Request.hs +++ b/Network/HTTP/Conduit/Request.hs @@ -1,287 +1,287 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Network.HTTP.Conduit.Request - ( Request (..) - , RequestBody (..) - , ContentType - , Proxy (..) - , parseUrl - , setUriRelative - , browserDecompress - , HttpException (..) - , alwaysDecompress - , addProxy - , applyBasicAuth - , urlEncodedBody - , needsGunzip - , requestBuilder - ) where - -import Data.Maybe (fromMaybe, isJust) -import Data.Monoid (mempty, mappend) - -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.Conduit.List as CL - -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.Exception (Exception, toException) -import Control.Failure (Failure (failure)) -import Codec.Binary.UTF8.String (encodeString) -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, (<>)) - --- | 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 . encodeString - --- | 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 . 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 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 - , rawBody = False - , decompress = browserDecompress - , redirectCount = 10 - , checkStatus = \s@(W.Status sci _) hs -> - if 200 <= sci && sci < 300 - then Nothing - else Just $ toException $ StatusCodeException s hs - , responseTimeout = Just 5000000 - } - --- | 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 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 paramters 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 = - CL.sourceList [builder] `mappend` bodySource - where - sourceSingle = CL.sourceList . return - - (contentLength, bodySource) = - case requestBody req of - RequestBodyLBS lbs -> (Just $ L.length lbs, sourceSingle $ fromLazyByteString lbs) - RequestBodyBS bs -> (Just $ fromIntegral $ S.length bs, sourceSingle $ fromByteString bs) - RequestBodyBuilder i b -> (Just $ i, sourceSingle b) - RequestBodySource i source -> (Just i, source) - RequestBodySourceChunked source -> (Nothing, 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" +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Network.HTTP.Conduit.Request + ( Request (..) + , RequestBody (..) + , ContentType + , Proxy (..) + , parseUrl + , setUriRelative + , browserDecompress + , HttpException (..) + , alwaysDecompress + , addProxy + , applyBasicAuth + , urlEncodedBody + , needsGunzip + , requestBuilder + ) where + +import Data.Maybe (fromMaybe, isJust) +import Data.Monoid (mempty, mappend) + +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.Conduit.List as CL + +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.Exception (Exception, toException) +import Control.Failure (Failure (failure)) +import Codec.Binary.UTF8.String (encodeString) +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, (<>)) + +-- | 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 . encodeString + +-- | 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 . 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 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 + , rawBody = False + , decompress = browserDecompress + , redirectCount = 10 + , checkStatus = \s@(W.Status sci _) hs -> + if 200 <= sci && sci < 300 + then Nothing + else Just $ toException $ StatusCodeException s hs + , responseTimeout = Just 5000000 + } + +-- | 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 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 paramters 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 = + CL.sourceList [builder] `mappend` bodySource + where + sourceSingle = CL.sourceList . return + + (contentLength, bodySource) = + case requestBody req of + RequestBodyLBS lbs -> (Just $ L.length lbs, sourceSingle $ fromLazyByteString lbs) + RequestBodyBS bs -> (Just $ fromIntegral $ S.length bs, sourceSingle $ fromByteString bs) + RequestBodyBuilder i b -> (Just $ i, sourceSingle b) + RequestBodySource i source -> (Just i, source) + RequestBodySourceChunked source -> (Nothing, 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 --- a/Network/HTTP/Conduit/Response.hs +++ b/Network/HTTP/Conduit/Response.hs @@ -1,152 +1,152 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -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 (liftIO) - -import qualified Data.ByteString.Char8 as S8 -import qualified Data.ByteString.Lazy as L - -import qualified Data.CaseInsensitive as CI - -import Data.Conduit hiding (Sink, Conduit) -import Data.Conduit.Internal (ResumableSource (..), Pipe (..)) -import qualified Data.Conduit.Zlib as CZ -import qualified Data.Conduit.Binary as CB -import qualified Data.Conduit.List as CL - -import qualified Network.HTTP.Types as W -import Network.URI (parseURIReference) - -import Network.HTTP.Conduit.Types (Response (..)) - -import Network.HTTP.Conduit.Manager -import Network.HTTP.Conduit.Request -import Network.HTTP.Conduit.Util -import Network.HTTP.Conduit.Parser -import Network.HTTP.Conduit.Chunk - -import Data.Void (Void, absurd) - -import System.Timeout.Lifted (timeout) -import Control.Monad.Trans.Control (MonadBaseControl) - --- | 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 = E.catch (runResourceT $ http req' man >> return [req']) --- > (\ (StatusCodeException status headers) -> do --- > l <- myHttp (fromJust $ nextRequest status headers) man --- > return $ req' : l) --- > where req' = req { redirectCount = 0 } --- > nextRequest status headers = getRedirectedRequest req' headers $ W.statusCode status -getRedirectedRequest :: Request m -> W.ResponseHeaders -> Int -> Maybe (Request m) -getRedirectedRequest req hs 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 "" - } - else req' - | otherwise = Nothing - --- | 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 p) i - -getResponse :: (MonadResource m, MonadBaseControl IO m) - => ConnRelease m - -> Request m - -> Source m S8.ByteString - -> m (Response (ResumableSource m S8.ByteString)) -getResponse connRelease req@(Request {..}) src1 = do - let timeout' = - case responseTimeout 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 $$+ checkHeaderLength 4096 sinkHeaders - 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' - 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 src3 = - if ("transfer-encoding", "chunked") `elem` hs' - then fmapResume ($= chunkedConduit rawBody) src2 - else - case mcl of - Just len -> fmapResume ($= CB.isolate len) src2 - Nothing -> src2 - let src4 = - if needsGunzip req hs' - then fmapResume ($= CZ.ungzip) src3 - else src3 - return $ addCleanup' cleanup src4 - - return $ Response s version hs' body - where - fmapResume f (ResumableSource src m) = ResumableSource (f src) m - addCleanup' f (ResumableSource src m) = ResumableSource (addCleanup f src) (m >> f False) +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +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 (liftIO) + +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L + +import qualified Data.CaseInsensitive as CI + +import Data.Conduit hiding (Sink, Conduit) +import Data.Conduit.Internal (ResumableSource (..), Pipe (..)) +import qualified Data.Conduit.Zlib as CZ +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL + +import qualified Network.HTTP.Types as W +import Network.URI (parseURIReference) + +import Network.HTTP.Conduit.Types (Response (..)) + +import Network.HTTP.Conduit.Manager +import Network.HTTP.Conduit.Request +import Network.HTTP.Conduit.Util +import Network.HTTP.Conduit.Parser +import Network.HTTP.Conduit.Chunk + +import Data.Void (Void, absurd) + +import System.Timeout.Lifted (timeout) +import Control.Monad.Trans.Control (MonadBaseControl) + +-- | 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 = E.catch (runResourceT $ http req' man >> return [req']) +-- > (\ (StatusCodeException status headers) -> do +-- > l <- myHttp (fromJust $ nextRequest status headers) man +-- > return $ req' : l) +-- > where req' = req { redirectCount = 0 } +-- > nextRequest status headers = getRedirectedRequest req' headers $ W.statusCode status +getRedirectedRequest :: Request m -> W.ResponseHeaders -> Int -> Maybe (Request m) +getRedirectedRequest req hs 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 "" + } + else req' + | otherwise = Nothing + +-- | 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 p) i + +getResponse :: (MonadResource m, MonadBaseControl IO m) + => ConnRelease m + -> Request m + -> Source m S8.ByteString + -> m (Response (ResumableSource m S8.ByteString)) +getResponse connRelease req@(Request {..}) src1 = do + let timeout' = + case responseTimeout 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 $$+ checkHeaderLength 4096 sinkHeaders + 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' + 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 src3 = + if ("transfer-encoding", "chunked") `elem` hs' + then fmapResume ($= chunkedConduit rawBody) src2 + else + case mcl of + Just len -> fmapResume ($= CB.isolate len) src2 + Nothing -> src2 + let src4 = + if needsGunzip req hs' + then fmapResume ($= CZ.ungzip) src3 + else src3 + return $ addCleanup' cleanup src4 + + return $ Response s version hs' body + where + fmapResume f (ResumableSource src m) = ResumableSource (f src) m + addCleanup' f (ResumableSource src m) = ResumableSource (addCleanup f src) (m >> f False) diff --git a/Network/HTTP/Conduit/Types.hs b/Network/HTTP/Conduit/Types.hs --- a/Network/HTTP/Conduit/Types.hs +++ b/Network/HTTP/Conduit/Types.hs @@ -1,155 +1,155 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module Network.HTTP.Conduit.Types - ( Request (..) - , RequestBody (..) - , ContentType - , Proxy (..) - , HttpException (..) - , Response (..) - ) where - -import Data.Int (Int64) -import Data.Typeable (Typeable) - -import qualified Blaze.ByteString.Builder as Blaze - -import qualified Data.Conduit as C - -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L - -import qualified Network.HTTP.Types as W -import Network.Socks5 (SocksConf) - -import Control.Exception (Exception, SomeException) - -import Data.Certificate.X509 (X509) -import Network.TLS (PrivateKey) - -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. - , 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 -> 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. - } - --- | 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 Blaze.Builder - | RequestBodySource Int64 (C.Source m Blaze.Builder) - | RequestBodySourceChunked (C.Source m Blaze.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, Typeable) - -data HttpException = StatusCodeException W.Status W.ResponseHeaders - | 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 - deriving (Show, Typeable) -instance Exception HttpException - --- | A simple representation of the HTTP response created by 'lbsConsumer'. -data Response body = Response - { responseStatus :: W.Status - , responseVersion :: W.HttpVersion - , responseHeaders :: W.ResponseHeaders - , responseBody :: body - } - deriving (Show, Eq, Typeable) - --- | Since 1.1.2. -instance Functor Response where - fmap f (Response status v headers body) = Response status v headers (f body) +{-# LANGUAGE DeriveDataTypeable #-} +module Network.HTTP.Conduit.Types + ( Request (..) + , RequestBody (..) + , ContentType + , Proxy (..) + , HttpException (..) + , Response (..) + ) where + +import Data.Int (Int64) +import Data.Typeable (Typeable) + +import qualified Blaze.ByteString.Builder as Blaze + +import qualified Data.Conduit as C + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + +import qualified Network.HTTP.Types as W +import Network.Socks5 (SocksConf) + +import Control.Exception (Exception, SomeException) + +import Data.Certificate.X509 (X509) +import Network.TLS (PrivateKey) + +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. + , 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 -> 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. + } + +-- | 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 Blaze.Builder + | RequestBodySource Int64 (C.Source m Blaze.Builder) + | RequestBodySourceChunked (C.Source m Blaze.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, Typeable) + +data HttpException = StatusCodeException W.Status W.ResponseHeaders + | 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 + deriving (Show, Typeable) +instance Exception HttpException + +-- | A simple representation of the HTTP response created by 'lbsConsumer'. +data Response body = Response + { responseStatus :: W.Status + , responseVersion :: W.HttpVersion + , responseHeaders :: W.ResponseHeaders + , responseBody :: body + } + deriving (Show, Eq, Typeable) + +-- | Since 1.1.2. +instance Functor Response where + fmap f (Response status v headers body) = Response status v headers (f body) diff --git a/Network/HTTP/Conduit/Util.hs b/Network/HTTP/Conduit/Util.hs --- a/Network/HTTP/Conduit/Util.hs +++ b/Network/HTTP/Conduit/Util.hs @@ -1,71 +1,71 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -module Network.HTTP.Conduit.Util - ( hGetSome - , (<>) - , readDec - , hasNoBody - ) where - -import Data.Monoid (Monoid, mappend) - -import qualified Data.ByteString.Char8 as S8 - -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 +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +module Network.HTTP.Conduit.Util + ( hGetSome + , (<>) + , readDec + , hasNoBody + ) where + +import Data.Monoid (Monoid, mappend) + +import qualified Data.ByteString.Char8 as S8 + +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 diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,8 +1,8 @@ -#!/usr/bin/env runhaskell - -> module Main where -> import Distribution.Simple -> import System.Cmd (system) - -> main :: IO () -> main = defaultMain +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple +> import System.Cmd (system) + +> main :: IO () +> main = defaultMain diff --git a/http-conduit.cabal b/http-conduit.cabal --- a/http-conduit.cabal +++ b/http-conduit.cabal @@ -1,124 +1,124 @@ -name: http-conduit -version: 1.8.4.4 -license: BSD3 -license-file: LICENSE -author: Michael Snoyman -maintainer: Michael Snoyman -synopsis: HTTP client package with conduit interface and HTTPS support. -description: - This package uses attoparsec for parsing the actual contents of the HTTP connection. It also provides higher-level functions which allow you to avoid direct usage of conduits. See for more information. - . - "Network.HTTP.Conduit.Browser" module has been moved to -category: Web, Conduit -stability: Stable -cabal-version: >= 1.8 -build-type: Simple -homepage: http://www.yesodweb.com/book/http-conduit -extra-source-files: test/main.hs, test/CookieTest.hs - -flag network-bytestring - default: False - -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 && < 0.6 - , zlib-conduit >= 0.5 && < 0.6 - , blaze-builder-conduit >= 0.5 - , attoparsec-conduit >= 0.5 - , attoparsec >= 0.8.0.2 - , utf8-string >= 0.3.4 - , blaze-builder >= 0.2.1 - , http-types >= 0.6 - , cprng-aes >= 0.2 - , tls >= 1.0.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 - 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 - exposed-modules: Network.HTTP.Conduit - Network.HTTP.Conduit.Internal - 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 - type: exitcode-stdio-1.0 - hs-source-dirs: ., test - - ghc-options: -Wall - cpp-options: -DDEBUG - build-depends: base >= 4 && < 5 - , HUnit - , hspec >= 1.3 - , bytestring - , transformers - , failure - , conduit - , zlib-conduit - , blaze-builder-conduit - , attoparsec-conduit - , attoparsec - , utf8-string - , blaze-builder - , http-types - , cprng-aes - , tls - , tls-extra - , monad-control - , containers - , certificate - , case-insensitive - , base64-bytestring - , asn1-data - , data-default - , text - , transformers-base - , lifted-base - , time - , network - , wai - , warp >= 1.2.1 - , socks - , http-types - , cookie - , regex-compat - , network-conduit >= 0.6 - , resourcet - , void - , deepseq - , mtl - -source-repository head - type: git - location: git://github.com/snoyberg/http-conduit.git +name: http-conduit +version: 1.8.4.5 +license: BSD3 +license-file: LICENSE +author: Michael Snoyman +maintainer: Michael Snoyman +synopsis: HTTP client package with conduit interface and HTTPS support. +description: + This package uses attoparsec for parsing the actual contents of the HTTP connection. It also provides higher-level functions which allow you to avoid direct usage of conduits. See for more information. + . + "Network.HTTP.Conduit.Browser" module has been moved to +category: Web, Conduit +stability: Stable +cabal-version: >= 1.8 +build-type: Simple +homepage: http://www.yesodweb.com/book/http-conduit +extra-source-files: test/main.hs, test/CookieTest.hs + +flag network-bytestring + default: False + +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 && < 0.6 + , zlib-conduit >= 0.5 && < 0.6 + , blaze-builder-conduit >= 0.5 + , attoparsec-conduit >= 0.5 + , attoparsec >= 0.8.0.2 + , utf8-string >= 0.3.4 + , blaze-builder >= 0.2.1 + , http-types >= 0.6 + , cprng-aes >= 0.2 + , tls >= 1.0.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 + 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 + exposed-modules: Network.HTTP.Conduit + Network.HTTP.Conduit.Internal + 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 + type: exitcode-stdio-1.0 + hs-source-dirs: ., test + + ghc-options: -Wall + cpp-options: -DDEBUG + build-depends: base >= 4 && < 5 + , HUnit + , hspec >= 1.3 + , bytestring + , transformers + , failure + , conduit + , zlib-conduit + , blaze-builder-conduit + , attoparsec-conduit + , attoparsec + , utf8-string + , blaze-builder + , http-types + , cprng-aes + , tls + , tls-extra + , monad-control + , containers + , certificate + , case-insensitive + , base64-bytestring + , asn1-data + , data-default + , text + , transformers-base + , lifted-base + , time + , network + , wai + , warp >= 1.2.1 + , socks + , http-types + , cookie + , regex-compat + , network-conduit >= 0.6 + , resourcet + , void + , deepseq + , mtl + +source-repository head + type: git + location: git://github.com/snoyberg/http-conduit.git diff --git a/test/CookieTest.hs b/test/CookieTest.hs --- a/test/CookieTest.hs +++ b/test/CookieTest.hs @@ -1,546 +1,546 @@ -module CookieTest (cookieTest) where - -import Prelude hiding (exp) -import Test.Hspec -import qualified Data.ByteString as BS -import Test.HUnit hiding (path) -import Network.HTTP.Conduit.Cookies -import qualified Network.HTTP.Conduit as HC -import Data.ByteString.UTF8 -import Data.Maybe -import Data.Time.Clock -import Data.Time.Calendar -import qualified Data.CaseInsensitive as CI -import Web.Cookie - -default_request :: HC.Request m -default_request = fromJust $ HC.parseUrl "http://www.google.com/" - -default_cookie :: Cookie -default_cookie = Cookie { cookie_name = fromString "name" - , cookie_value = fromString "value" - , cookie_expiry_time = default_time - , cookie_domain = fromString "www.google.com" - , cookie_path = fromString "/" - , cookie_creation_time = default_time - , cookie_last_access_time = default_time - , cookie_persistent = False - , cookie_host_only = False - , cookie_secure_only = False - , cookie_http_only = False - } - -default_time :: UTCTime -default_time = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0) - -default_diff_time :: DiffTime -default_diff_time = secondsToDiffTime 1209600 - -default_set_cookie :: SetCookie -default_set_cookie = def { setCookieName = fromString "name" - , setCookieValue = fromString "value" - , setCookiePath = Just $ fromString "/" - , setCookieExpires = Just default_time - , setCookieMaxAge = Just default_diff_time - , setCookieDomain = Just $ fromString "www.google.com" - , setCookieHttpOnly = False - , setCookieSecure = False - } - -testValidIp :: Test -testValidIp = TestCase $ assertBool "Couldn't parse valid IP address" $ - isIpAddress $ fromString "1.2.3.4" - -testIpNumTooHigh :: Test -testIpNumTooHigh = TestCase $ assertBool "One of the digits in the IP address is too large" $ - not $ isIpAddress $ fromString "501.2.3.4" - -testTooManySegmentsInIp :: Test -testTooManySegmentsInIp = TestCase $ assertBool "Too many segments in the ip address" $ - not $ isIpAddress $ fromString "1.2.3.4.5" - -testCharsInIp :: Test -testCharsInIp = TestCase $ assertBool "Chars are not allowed in IP addresses" $ - not $ isIpAddress $ fromString "1.2a3.4.5" - -testDomainMatchesSuccess :: Test -testDomainMatchesSuccess = TestCase $ assertBool "Domains should match" $ - domainMatches (fromString "www.google.com") (fromString "google.com") - -testSameDomain :: Test -testSameDomain = TestCase $ assertBool "Same domain should match" $ - domainMatches domain domain - where domain = fromString "www.google.com" - -testSiblingDomain :: Test -testSiblingDomain = TestCase $ assertBool "Sibling domain should not match" $ - not $ domainMatches (fromString "www.google.com") (fromString "secure.google.com") - -testParentDomain :: Test -testParentDomain = TestCase $ assertBool "Parent domain should fail" $ - not $ domainMatches (fromString "google.com") (fromString "www.google.com") - -testNaiveSuffixDomain :: Test -testNaiveSuffixDomain = TestCase $ assertBool "Naively checking for suffix for domain matching should fail" $ - not $ domainMatches (fromString "agoogle.com") (fromString "google.com") - -testDefaultPath :: Test -testDefaultPath = TestCase $ assertEqual "Getting default path from a request" - (fromString "/") (defaultPath default_request) - -testShortDefaultPath :: Test -testShortDefaultPath = TestCase $ assertEqual "Getting default path from a short path" - (fromString "/") (defaultPath $ default_request {HC.path = fromString "/search"}) - -testPopulatedDefaultPath :: Test -testPopulatedDefaultPath = TestCase $ assertEqual "Getting default path from a request with a path" - (fromString "/search") (defaultPath $ default_request {HC.path = fromString "/search/term"}) - -testParamsDefaultPath :: Test -testParamsDefaultPath = TestCase $ assertEqual "Getting default path from a request with a path and GET params" - (fromString "/search") (defaultPath $ default_request {HC.path = fromString "/search/term?var=val"}) - -testDefaultPathEndingInSlash :: Test -testDefaultPathEndingInSlash = TestCase $ assertEqual "Getting default path that ends in a slash" - (fromString "/search/term") (defaultPath $ default_request {HC.path = fromString "/search/term/"}) - -testSamePathsMatch :: Test -testSamePathsMatch = TestCase $ assertBool "The same path should match" $ - pathMatches path path - where path = fromString "/a/path" - -testPathSlashAtEnd :: Test -testPathSlashAtEnd = TestCase $ assertBool "Putting the slash at the end should still match paths" $ - pathMatches (fromString "/a/path/to/here") (fromString "/a/path/") - -testPathNoSlashAtEnd :: Test -testPathNoSlashAtEnd = TestCase $ assertBool "Not putting the slash at the end should still match paths" $ - pathMatches (fromString "/a/path/to/here") (fromString "/a/path") - -testDivergingPaths :: Test -testDivergingPaths = TestCase $ assertBool "Diverging paths don't match" $ - not $ pathMatches (fromString "/a/path/to/here") (fromString "/a/different/path") - -testCookieEqualitySuccess :: Test -testCookieEqualitySuccess = TestCase $ assertEqual "The same cookies should be equal" - cookie cookie - where cookie = default_cookie - -testCookieEqualityResiliance :: Test -testCookieEqualityResiliance = TestCase $ assertEqual "Cookies should still be equal if extra options are changed" - (default_cookie {cookie_persistent = True}) (default_cookie {cookie_host_only = True}) - -testDomainChangesEquality :: Test -testDomainChangesEquality = TestCase $ assertBool "Changing the domain should make cookies not equal" $ - default_cookie /= (default_cookie {cookie_domain = fromString "/search"}) - -testRemoveCookie :: Test -testRemoveCookie = TestCase $ assertEqual "Removing a cookie works" - (Just default_cookie, createCookieJar []) (removeExistingCookieFromCookieJar default_cookie $ createCookieJar [default_cookie]) - -testRemoveNonexistantCookie :: Test -testRemoveNonexistantCookie = TestCase $ assertEqual "Removing a nonexistant cookie doesn't work" - (Nothing, createCookieJar [default_cookie]) (removeExistingCookieFromCookieJar (default_cookie {cookie_name = fromString "key2"}) $ createCookieJar [default_cookie]) - -testRemoveCorrectCookie :: Test -testRemoveCorrectCookie = TestCase $ assertEqual "Removing only the correct cookie" - (Just search_for, createCookieJar [red_herring]) (removeExistingCookieFromCookieJar search_for $ createCookieJar [red_herring, search_for]) - where search_for = default_cookie {cookie_name = fromString "name1"} - red_herring = default_cookie {cookie_name = fromString "name2"} - -testEvictExpiredCookies :: Test -testEvictExpiredCookies = TestCase $ assertEqual "Evicting expired cookies works" - (createCookieJar [a, c]) (evictExpiredCookies (createCookieJar [a, b, c, d]) middle) - where a = default_cookie { cookie_name = fromString "a" - , cookie_expiry_time = UTCTime (ModifiedJulianDay 3) (secondsToDiffTime 0) - } - b = default_cookie { cookie_name = fromString "b" - , cookie_expiry_time = UTCTime (ModifiedJulianDay 1) (secondsToDiffTime 0) - } - c = default_cookie { cookie_name = fromString "c" - , cookie_expiry_time = UTCTime (ModifiedJulianDay 3) (secondsToDiffTime 0) - } - d = default_cookie { cookie_name = fromString "d" - , cookie_expiry_time = UTCTime (ModifiedJulianDay 1) (secondsToDiffTime 0) - } - middle = UTCTime (ModifiedJulianDay 2) (secondsToDiffTime 0) - -testEvictNoCookies :: Test -testEvictNoCookies = TestCase $ assertEqual "Evicting empty cookie jar" - (createCookieJar []) (evictExpiredCookies (createCookieJar []) middle) - where middle = UTCTime (ModifiedJulianDay 2) (secondsToDiffTime 0) - -testComputeCookieStringUpdateLastAccessTime :: Test -testComputeCookieStringUpdateLastAccessTime = TestCase $ assertEqual "Updates last access time upon using cookies" - (fromString "name=value", out_cookie_jar) (computeCookieString request cookie_jar now True) - where request = default_request - cookie_jar = createCookieJar [default_cookie] - now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) - out_cookie_jar = createCookieJar [default_cookie {cookie_last_access_time = now}] - -testComputeCookieStringHostOnly :: Test -testComputeCookieStringHostOnly = TestCase $ assertEqual "Host only cookies should match host exactly" - (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) - where request = default_request - cookie_jar = createCookieJar [default_cookie {cookie_host_only = True}] - -testComputeCookieStringHostOnlyFilter :: Test -testComputeCookieStringHostOnlyFilter = TestCase $ assertEqual "Host only cookies shouldn't match subdomain" - (fromString "", cookie_jar) (computeCookieString request cookie_jar default_time True) - where request = default_request {HC.host = fromString "sub1.sub2.google.com"} - cookie_jar = createCookieJar [default_cookie { cookie_host_only = True - , cookie_domain = fromString "sub2.google.com" - } - ] - -testComputeCookieStringDomainMatching :: Test -testComputeCookieStringDomainMatching = TestCase $ assertEqual "Domain matching works for new requests" - (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) - where request = default_request {HC.host = fromString "sub1.sub2.google.com"} - cookie_jar = createCookieJar [default_cookie {cookie_domain = fromString "sub2.google.com"}] - -testComputeCookieStringPathMatching :: Test -testComputeCookieStringPathMatching = TestCase $ assertEqual "Path matching works for new requests" - (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) - where request = default_request {HC.path = fromString "/a/path/to/nowhere"} - cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}] - -testComputeCookieStringPathMatchingFails :: Test -testComputeCookieStringPathMatchingFails = TestCase $ assertEqual "Path matching fails when it should" - (fromString "", cookie_jar) (computeCookieString request cookie_jar default_time True) - where request = default_request {HC.path = fromString "/a/different/path/to/nowhere"} - cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}] - -testComputeCookieStringPathMatchingWithParms :: Test -testComputeCookieStringPathMatchingWithParms = TestCase $ assertEqual "Path matching succeeds when request has GET params" - (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) - where request = default_request {HC.path = fromString "/a/path/to/nowhere?var=val"} - cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}] - -testComputeCookieStringSecure :: Test -testComputeCookieStringSecure = TestCase $ assertEqual "Secure flag filters properly" - (fromString "", cookie_jar) (computeCookieString default_request cookie_jar default_time True) - where cookie_jar = createCookieJar [default_cookie {cookie_secure_only = True}] - -testComputeCookieStringHttpOnly :: Test -testComputeCookieStringHttpOnly = TestCase $ assertEqual "http-only flag filters properly" - (fromString "", cookie_jar) (computeCookieString default_request cookie_jar default_time False) - where cookie_jar = createCookieJar [default_cookie {cookie_http_only = True}] - -testComputeCookieStringSort :: Test -testComputeCookieStringSort = TestCase $ assertEqual "Sorting works correctly" - (fromString "c1=v1;c3=v3;c4=v4;c2=v2", cookie_jar_out) format_output - where now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 11) - cookie_jar = createCookieJar [ default_cookie { cookie_name = fromString "c1" - , cookie_value = fromString "v1" - , cookie_path = fromString "/all/encompassing/request" - } - , default_cookie { cookie_name = fromString "c2" - , cookie_value = fromString "v2" - , cookie_path = fromString "/all" - } - , default_cookie { cookie_name = fromString "c3" - , cookie_value = fromString "v3" - , cookie_path = fromString "/all/encompassing" - , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) - } - , default_cookie { cookie_name = fromString "c4" - , cookie_value = fromString "v4" - , cookie_path = fromString "/all/encompassing" - , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2) - } - ] - cookie_jar_out = createCookieJar [ default_cookie { cookie_name = fromString "c1" - , cookie_value = fromString "v1" - , cookie_path = fromString "/all/encompassing/request" - , cookie_last_access_time = now - } - , default_cookie { cookie_name = fromString "c2" - , cookie_value = fromString "v2" - , cookie_path = fromString "/all" - , cookie_last_access_time = now - } - , default_cookie { cookie_name = fromString "c3" - , cookie_value = fromString "v3" - , cookie_path = fromString "/all/encompassing" - , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) - , cookie_last_access_time = now - } - , default_cookie { cookie_name = fromString "c4" - , cookie_value = fromString "v4" - , cookie_path = fromString "/all/encompassing" - , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2) - , cookie_last_access_time = now - } - ] - request = default_request {HC.path = fromString "/all/encompassing/request/path"} - format_output = computeCookieString request cookie_jar default_time False - -testInsertCookiesIntoRequestWorks :: Test -testInsertCookiesIntoRequestWorks = TestCase $ assertEqual "Inserting cookies works" - [(CI.mk $ fromString "Cookie", fromString "key=val")] out_headers - where out_headers = HC.requestHeaders req - (req, _) = insertCookiesIntoRequest req' cookie_jar default_time - cookie_jar = createCookieJar [ default_cookie { cookie_name = fromString "key" - , cookie_value = fromString "val" - } - ] - req' = default_request {HC.requestHeaders = [(CI.mk $ fromString "Cookie", - fromString "otherkey=otherval")]} - -testReceiveSetCookie :: Test -testReceiveSetCookie = TestCase $ assertEqual "Receiving a Set-Cookie" - (createCookieJar [default_cookie]) (receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) - -testReceiveSetCookieTrailingDot :: Test -testReceiveSetCookieTrailingDot = TestCase $ assertEqual "Receiving a Set-Cookie with a trailing domain dot" - (createCookieJar []) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) - where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "www.google.com."} - -testReceiveSetCookieLeadingDot :: Test -testReceiveSetCookieLeadingDot = TestCase $ assertEqual "Receiving a Set-Cookie with a leading domain dot" - (createCookieJar [default_cookie]) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) - where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString ".www.google.com"} - -testReceiveSetCookieNoDomain :: Test -testReceiveSetCookieNoDomain = TestCase $ assertEqual "Receiving cookie without domain" - (createCookieJar [default_cookie]) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) - where set_cookie = default_set_cookie {setCookieDomain = Nothing} - -testReceiveSetCookieEmptyDomain :: Test -testReceiveSetCookieEmptyDomain = TestCase $ assertEqual "Receiving cookie with empty domain" - (createCookieJar [default_cookie]) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) - where set_cookie = default_set_cookie {setCookieDomain = Just BS.empty} - --- Can't test public suffixes until that module is written - -testReceiveSetCookieNonMatchingDomain :: Test -testReceiveSetCookieNonMatchingDomain = TestCase $ assertEqual "Receiving cookie with non-matching domain" - (createCookieJar []) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) - where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "www.wikipedia.org"} - -testReceiveSetCookieHostOnly :: Test -testReceiveSetCookieHostOnly = TestCase $ assertBool "Checking host-only flag gets set" $ - cookie_host_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] - where set_cookie = default_set_cookie {setCookieDomain = Nothing} - -testReceiveSetCookieHostOnlyNotSet :: Test -testReceiveSetCookieHostOnlyNotSet = TestCase $ assertBool "Checking host-only flag doesn't get set" $ - not $ cookie_host_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] - where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "google.com"} - -testReceiveSetCookieHttpOnly :: Test -testReceiveSetCookieHttpOnly = TestCase $ assertBool "Checking http-only flag gets set" $ - cookie_http_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] - where set_cookie = default_set_cookie {setCookieHttpOnly = True} - -testReceiveSetCookieHttpOnlyNotSet :: Test -testReceiveSetCookieHttpOnlyNotSet = TestCase $ assertBool "Checking http-only flag doesn't get set" $ - not $ cookie_http_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] - where set_cookie = default_set_cookie {setCookieHttpOnly = False} - -testReceiveSetCookieHttpOnlyDrop :: Test -testReceiveSetCookieHttpOnlyDrop = TestCase $ assertEqual "Checking non http request gets dropped" - (createCookieJar []) (receiveSetCookie set_cookie default_request default_time False $ createCookieJar []) - where set_cookie = default_set_cookie {setCookieHttpOnly = True} - -testReceiveSetCookieName :: Test -testReceiveSetCookieName = TestCase $ assertEqual "Name gets set correctly" - (fromString "name") (cookie_name $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) - -testReceiveSetCookieValue :: Test -testReceiveSetCookieValue = TestCase $ assertEqual "Value gets set correctly" - (fromString "value") (cookie_value $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) - -testReceiveSetCookieExpiry :: Test -testReceiveSetCookieExpiry = TestCase $ assertEqual "Expiry gets set correctly" - now_plus_diff_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) - where now_plus_diff_time = ((fromRational $ toRational default_diff_time) `addUTCTime` default_time) - -testReceiveSetCookieNoMaxAge :: Test -testReceiveSetCookieNoMaxAge = TestCase $ assertEqual "Expiry is based on the given value" - default_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie cookie_without_max_age default_request default_time True $ createCookieJar []) - where cookie_without_max_age = default_set_cookie {setCookieMaxAge = Nothing} - -testReceiveSetCookieNoExpiry :: Test -testReceiveSetCookieNoExpiry = TestCase $ assertEqual "Expiry is based on max age" - now_plus_diff_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie cookie_without_expiry default_request default_time True $ createCookieJar []) - where now_plus_diff_time = ((fromRational $ toRational default_diff_time) `addUTCTime` default_time) - cookie_without_expiry = default_set_cookie {setCookieExpires = Nothing} - -testReceiveSetCookieNoExpiryNoMaxAge :: Test -testReceiveSetCookieNoExpiryNoMaxAge = TestCase $ assertBool "Expiry is set to a future date" $ - default_time < (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie basic_cookie default_request default_time True $ createCookieJar []) - where basic_cookie = default_set_cookie { setCookieExpires = Nothing, setCookieMaxAge = Nothing } - -testReceiveSetCookiePath :: Test -testReceiveSetCookiePath = TestCase $ assertEqual "Path gets set correctly" - (fromString "/a/path") (cookie_path $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) - where set_cookie = default_set_cookie {setCookiePath = Just $ fromString "/a/path"} - -testReceiveSetCookieNoPath :: Test -testReceiveSetCookieNoPath = TestCase $ assertEqual "Path gets set correctly when nonexistant" - (fromString "/a/path/to") (cookie_path $ head $ destroyCookieJar $ receiveSetCookie set_cookie request default_time True $ createCookieJar []) - where set_cookie = default_set_cookie {setCookiePath = Nothing} - request = default_request {HC.path = fromString "/a/path/to/nowhere"} - -testReceiveSetCookieCreationTime :: Test -testReceiveSetCookieCreationTime = TestCase $ assertEqual "Creation time gets set correctly" - now (cookie_creation_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar []) - where now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) - -testReceiveSetCookieAccessTime :: Test -testReceiveSetCookieAccessTime = TestCase $ assertEqual "Last access time gets set correctly" - now (cookie_last_access_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar []) - where now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) - -testReceiveSetCookiePersistent :: Test -testReceiveSetCookiePersistent = TestCase $ assertBool "Persistent flag gets set correctly" $ - cookie_persistent $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] - where set_cookie = default_set_cookie {setCookieExpires = Just default_time} - -testReceiveSetCookieSecure :: Test -testReceiveSetCookieSecure = TestCase $ assertBool "Secure flag gets set correctly" $ - cookie_secure_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] - where set_cookie = default_set_cookie {setCookieSecure = True} - -testReceiveSetCookieMaxAge :: Test -testReceiveSetCookieMaxAge = TestCase $ assertEqual "Max-Age gets set correctly" - total (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request now True $ createCookieJar []) - where set_cookie = default_set_cookie { setCookieExpires = Nothing - , setCookieMaxAge = Just $ secondsToDiffTime 10 - } - now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) - total = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 22) - -testReceiveSetCookiePreferMaxAge :: Test -testReceiveSetCookiePreferMaxAge = TestCase $ assertEqual "Max-Age is preferred over Expires" - total (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request now True $ createCookieJar []) - where set_cookie = default_set_cookie { setCookieExpires = Just exp - , setCookieMaxAge = Just $ secondsToDiffTime 10 - } - exp = UTCTime (ModifiedJulianDay 11) (secondsToDiffTime 5) - now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) - total = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 22) - -testReceiveSetCookieExisting :: Test -testReceiveSetCookieExisting = TestCase $ assertEqual "Existing cookie gets updated" - t (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [default_cookie]) - where set_cookie = default_set_cookie { setCookieExpires = Just t - , setCookieMaxAge = Nothing - } - t = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) - -testReceiveSetCookieExistingCreation :: Test -testReceiveSetCookieExistingCreation = TestCase $ assertEqual "Creation time gets updated in existing cookie" - default_time (cookie_creation_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar [default_cookie]) - where now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) - -testReceiveSetCookieExistingHttpOnly :: Test -testReceiveSetCookieExistingHttpOnly = TestCase $ assertEqual "Existing http-only cookie gets dropped" - default_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time False $ createCookieJar [existing_cookie]) - where existing_cookie = default_cookie {cookie_http_only = True} - -ipParseTests :: Spec -ipParseTests = do - it "Valid IP" testValidIp - it "Digit Too High" testIpNumTooHigh - it "Too Many Segments" testTooManySegmentsInIp - it "Chars in IP" testCharsInIp - -domainMatchingTests :: Spec -domainMatchingTests = do - it "Should Match" testDomainMatchesSuccess - it "Same Domain" testSameDomain - it "Sibling Domain" testSiblingDomain - it "Parent Domain" testParentDomain - it "Checking for Naive suffix-check" testNaiveSuffixDomain - -defaultPathTests :: Spec -defaultPathTests = do - it "Basic default path test" testDefaultPath - it "Basic populated default path" testPopulatedDefaultPath - it "Default path from request with GET params works" testParamsDefaultPath - it "Getting a default path that ends in a slash" testDefaultPathEndingInSlash - it "Getting a short default path" testShortDefaultPath - -pathMatchingTests :: Spec -pathMatchingTests = do - it "Same paths match" testSamePathsMatch - it "Putting slash at end" testPathSlashAtEnd - it "Not putting slash at end" testPathNoSlashAtEnd - it "Diverging paths don't match" testDivergingPaths - -equalityTests :: Spec -equalityTests = do - it "The same cookie should be equal to itself" testCookieEqualitySuccess - it "Changing extra options shouldn't change equality" testCookieEqualityResiliance - it "Changing a cookie's domain should change its equality" testDomainChangesEquality - -removeTests :: Spec -removeTests = do - it "Removing a cookie works" testRemoveCookie - it "Removing a nonexistant cookie doesn't work" testRemoveNonexistantCookie - it "Removing the correct cookie" testRemoveCorrectCookie - -evictionTests :: Spec -evictionTests = do - it "Testing eviction" testEvictExpiredCookies - it "Evicting from empty cookie jar" testEvictNoCookies - -sendingTests :: Spec -sendingTests = do - it "Updates last access time upon using cookies" testComputeCookieStringUpdateLastAccessTime - it "Host-only flag matches exact host" testComputeCookieStringHostOnly - it "Host-only flag doesn't match subdomain" testComputeCookieStringHostOnlyFilter - it "Domain matching works properly" testComputeCookieStringDomainMatching - it "Path matching works" testComputeCookieStringPathMatching - it "Path matching fails when it should" testComputeCookieStringPathMatchingFails - it "Path matching succeeds when request has GET params" testComputeCookieStringPathMatchingWithParms - it "Secure flag filters correctly" testComputeCookieStringSecure - it "Http-only flag filters correctly" testComputeCookieStringHttpOnly - it "Sorting works correctly" testComputeCookieStringSort - it "Inserting cookie header works" testInsertCookiesIntoRequestWorks - -receivingTests :: Spec -receivingTests = do - it "Can receive set-cookie" testReceiveSetCookie - it "Receiving a Set-Cookie with a trailing dot on the domain" testReceiveSetCookieTrailingDot - it "Receiving a Set-Cookie with a leading dot on the domain" testReceiveSetCookieLeadingDot - it "Set-Cookie with no domain" testReceiveSetCookieNoDomain - it "Set-Cookie with empty domain" testReceiveSetCookieEmptyDomain - it "Set-Cookie with non-matching domain" testReceiveSetCookieNonMatchingDomain - it "Host-only flag gets set" testReceiveSetCookieHostOnly - it "Host-only flag doesn't get set" testReceiveSetCookieHostOnlyNotSet - it "Http-only flag gets set" testReceiveSetCookieHttpOnly - it "Http-only flag doesn't get set" testReceiveSetCookieHttpOnlyNotSet - it "Checking non http request gets dropped" testReceiveSetCookieHttpOnlyDrop - it "Name gets set correctly" testReceiveSetCookieName - it "Value gets set correctly" testReceiveSetCookieValue - it "Expiry gets set correctly" testReceiveSetCookieExpiry - it "Expiry gets set based on max age if no expiry is given" testReceiveSetCookieNoExpiry - it "Expiry gets set based on given value if no max age is given" testReceiveSetCookieNoMaxAge - it "Expiry gets set to a future date if no expiry and no max age are given" testReceiveSetCookieNoExpiryNoMaxAge - it "Path gets set correctly when nonexistant" testReceiveSetCookieNoPath - it "Path gets set correctly" testReceiveSetCookiePath - it "Creation time gets set correctly" testReceiveSetCookieCreationTime - it "Last access time gets set correctly" testReceiveSetCookieAccessTime - it "Persistent flag gets set correctly" testReceiveSetCookiePersistent - it "Existing cookie gets updated" testReceiveSetCookieExisting - it "Creation time gets updated in existing cookie" testReceiveSetCookieExistingCreation - it "Existing http-only cookie gets dropped" testReceiveSetCookieExistingHttpOnly - it "Secure flag gets set correctly" testReceiveSetCookieSecure - it "Max-Age flag gets set correctly" testReceiveSetCookieMaxAge - it "Max-Age is preferred over Expires" testReceiveSetCookiePreferMaxAge - -cookieTest :: Spec -cookieTest = do - describe "ipParseTests" ipParseTests - describe "domainMatchingTests" domainMatchingTests - describe "defaultPathTests" defaultPathTests - describe "pathMatchingTests" pathMatchingTests - describe "equalityTests" equalityTests - describe "removeTests" removeTests - describe "evictionTests" evictionTests - describe "sendingTests" sendingTests - describe "receivingTests" receivingTests +module CookieTest (cookieTest) where + +import Prelude hiding (exp) +import Test.Hspec +import qualified Data.ByteString as BS +import Test.HUnit hiding (path) +import Network.HTTP.Conduit.Cookies +import qualified Network.HTTP.Conduit as HC +import Data.ByteString.UTF8 +import Data.Maybe +import Data.Time.Clock +import Data.Time.Calendar +import qualified Data.CaseInsensitive as CI +import Web.Cookie + +default_request :: HC.Request m +default_request = fromJust $ HC.parseUrl "http://www.google.com/" + +default_cookie :: Cookie +default_cookie = Cookie { cookie_name = fromString "name" + , cookie_value = fromString "value" + , cookie_expiry_time = default_time + , cookie_domain = fromString "www.google.com" + , cookie_path = fromString "/" + , cookie_creation_time = default_time + , cookie_last_access_time = default_time + , cookie_persistent = False + , cookie_host_only = False + , cookie_secure_only = False + , cookie_http_only = False + } + +default_time :: UTCTime +default_time = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0) + +default_diff_time :: DiffTime +default_diff_time = secondsToDiffTime 1209600 + +default_set_cookie :: SetCookie +default_set_cookie = def { setCookieName = fromString "name" + , setCookieValue = fromString "value" + , setCookiePath = Just $ fromString "/" + , setCookieExpires = Just default_time + , setCookieMaxAge = Just default_diff_time + , setCookieDomain = Just $ fromString "www.google.com" + , setCookieHttpOnly = False + , setCookieSecure = False + } + +testValidIp :: Test +testValidIp = TestCase $ assertBool "Couldn't parse valid IP address" $ + isIpAddress $ fromString "1.2.3.4" + +testIpNumTooHigh :: Test +testIpNumTooHigh = TestCase $ assertBool "One of the digits in the IP address is too large" $ + not $ isIpAddress $ fromString "501.2.3.4" + +testTooManySegmentsInIp :: Test +testTooManySegmentsInIp = TestCase $ assertBool "Too many segments in the ip address" $ + not $ isIpAddress $ fromString "1.2.3.4.5" + +testCharsInIp :: Test +testCharsInIp = TestCase $ assertBool "Chars are not allowed in IP addresses" $ + not $ isIpAddress $ fromString "1.2a3.4.5" + +testDomainMatchesSuccess :: Test +testDomainMatchesSuccess = TestCase $ assertBool "Domains should match" $ + domainMatches (fromString "www.google.com") (fromString "google.com") + +testSameDomain :: Test +testSameDomain = TestCase $ assertBool "Same domain should match" $ + domainMatches domain domain + where domain = fromString "www.google.com" + +testSiblingDomain :: Test +testSiblingDomain = TestCase $ assertBool "Sibling domain should not match" $ + not $ domainMatches (fromString "www.google.com") (fromString "secure.google.com") + +testParentDomain :: Test +testParentDomain = TestCase $ assertBool "Parent domain should fail" $ + not $ domainMatches (fromString "google.com") (fromString "www.google.com") + +testNaiveSuffixDomain :: Test +testNaiveSuffixDomain = TestCase $ assertBool "Naively checking for suffix for domain matching should fail" $ + not $ domainMatches (fromString "agoogle.com") (fromString "google.com") + +testDefaultPath :: Test +testDefaultPath = TestCase $ assertEqual "Getting default path from a request" + (fromString "/") (defaultPath default_request) + +testShortDefaultPath :: Test +testShortDefaultPath = TestCase $ assertEqual "Getting default path from a short path" + (fromString "/") (defaultPath $ default_request {HC.path = fromString "/search"}) + +testPopulatedDefaultPath :: Test +testPopulatedDefaultPath = TestCase $ assertEqual "Getting default path from a request with a path" + (fromString "/search") (defaultPath $ default_request {HC.path = fromString "/search/term"}) + +testParamsDefaultPath :: Test +testParamsDefaultPath = TestCase $ assertEqual "Getting default path from a request with a path and GET params" + (fromString "/search") (defaultPath $ default_request {HC.path = fromString "/search/term?var=val"}) + +testDefaultPathEndingInSlash :: Test +testDefaultPathEndingInSlash = TestCase $ assertEqual "Getting default path that ends in a slash" + (fromString "/search/term") (defaultPath $ default_request {HC.path = fromString "/search/term/"}) + +testSamePathsMatch :: Test +testSamePathsMatch = TestCase $ assertBool "The same path should match" $ + pathMatches path path + where path = fromString "/a/path" + +testPathSlashAtEnd :: Test +testPathSlashAtEnd = TestCase $ assertBool "Putting the slash at the end should still match paths" $ + pathMatches (fromString "/a/path/to/here") (fromString "/a/path/") + +testPathNoSlashAtEnd :: Test +testPathNoSlashAtEnd = TestCase $ assertBool "Not putting the slash at the end should still match paths" $ + pathMatches (fromString "/a/path/to/here") (fromString "/a/path") + +testDivergingPaths :: Test +testDivergingPaths = TestCase $ assertBool "Diverging paths don't match" $ + not $ pathMatches (fromString "/a/path/to/here") (fromString "/a/different/path") + +testCookieEqualitySuccess :: Test +testCookieEqualitySuccess = TestCase $ assertEqual "The same cookies should be equal" + cookie cookie + where cookie = default_cookie + +testCookieEqualityResiliance :: Test +testCookieEqualityResiliance = TestCase $ assertEqual "Cookies should still be equal if extra options are changed" + (default_cookie {cookie_persistent = True}) (default_cookie {cookie_host_only = True}) + +testDomainChangesEquality :: Test +testDomainChangesEquality = TestCase $ assertBool "Changing the domain should make cookies not equal" $ + default_cookie /= (default_cookie {cookie_domain = fromString "/search"}) + +testRemoveCookie :: Test +testRemoveCookie = TestCase $ assertEqual "Removing a cookie works" + (Just default_cookie, createCookieJar []) (removeExistingCookieFromCookieJar default_cookie $ createCookieJar [default_cookie]) + +testRemoveNonexistantCookie :: Test +testRemoveNonexistantCookie = TestCase $ assertEqual "Removing a nonexistant cookie doesn't work" + (Nothing, createCookieJar [default_cookie]) (removeExistingCookieFromCookieJar (default_cookie {cookie_name = fromString "key2"}) $ createCookieJar [default_cookie]) + +testRemoveCorrectCookie :: Test +testRemoveCorrectCookie = TestCase $ assertEqual "Removing only the correct cookie" + (Just search_for, createCookieJar [red_herring]) (removeExistingCookieFromCookieJar search_for $ createCookieJar [red_herring, search_for]) + where search_for = default_cookie {cookie_name = fromString "name1"} + red_herring = default_cookie {cookie_name = fromString "name2"} + +testEvictExpiredCookies :: Test +testEvictExpiredCookies = TestCase $ assertEqual "Evicting expired cookies works" + (createCookieJar [a, c]) (evictExpiredCookies (createCookieJar [a, b, c, d]) middle) + where a = default_cookie { cookie_name = fromString "a" + , cookie_expiry_time = UTCTime (ModifiedJulianDay 3) (secondsToDiffTime 0) + } + b = default_cookie { cookie_name = fromString "b" + , cookie_expiry_time = UTCTime (ModifiedJulianDay 1) (secondsToDiffTime 0) + } + c = default_cookie { cookie_name = fromString "c" + , cookie_expiry_time = UTCTime (ModifiedJulianDay 3) (secondsToDiffTime 0) + } + d = default_cookie { cookie_name = fromString "d" + , cookie_expiry_time = UTCTime (ModifiedJulianDay 1) (secondsToDiffTime 0) + } + middle = UTCTime (ModifiedJulianDay 2) (secondsToDiffTime 0) + +testEvictNoCookies :: Test +testEvictNoCookies = TestCase $ assertEqual "Evicting empty cookie jar" + (createCookieJar []) (evictExpiredCookies (createCookieJar []) middle) + where middle = UTCTime (ModifiedJulianDay 2) (secondsToDiffTime 0) + +testComputeCookieStringUpdateLastAccessTime :: Test +testComputeCookieStringUpdateLastAccessTime = TestCase $ assertEqual "Updates last access time upon using cookies" + (fromString "name=value", out_cookie_jar) (computeCookieString request cookie_jar now True) + where request = default_request + cookie_jar = createCookieJar [default_cookie] + now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) + out_cookie_jar = createCookieJar [default_cookie {cookie_last_access_time = now}] + +testComputeCookieStringHostOnly :: Test +testComputeCookieStringHostOnly = TestCase $ assertEqual "Host only cookies should match host exactly" + (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) + where request = default_request + cookie_jar = createCookieJar [default_cookie {cookie_host_only = True}] + +testComputeCookieStringHostOnlyFilter :: Test +testComputeCookieStringHostOnlyFilter = TestCase $ assertEqual "Host only cookies shouldn't match subdomain" + (fromString "", cookie_jar) (computeCookieString request cookie_jar default_time True) + where request = default_request {HC.host = fromString "sub1.sub2.google.com"} + cookie_jar = createCookieJar [default_cookie { cookie_host_only = True + , cookie_domain = fromString "sub2.google.com" + } + ] + +testComputeCookieStringDomainMatching :: Test +testComputeCookieStringDomainMatching = TestCase $ assertEqual "Domain matching works for new requests" + (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) + where request = default_request {HC.host = fromString "sub1.sub2.google.com"} + cookie_jar = createCookieJar [default_cookie {cookie_domain = fromString "sub2.google.com"}] + +testComputeCookieStringPathMatching :: Test +testComputeCookieStringPathMatching = TestCase $ assertEqual "Path matching works for new requests" + (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) + where request = default_request {HC.path = fromString "/a/path/to/nowhere"} + cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}] + +testComputeCookieStringPathMatchingFails :: Test +testComputeCookieStringPathMatchingFails = TestCase $ assertEqual "Path matching fails when it should" + (fromString "", cookie_jar) (computeCookieString request cookie_jar default_time True) + where request = default_request {HC.path = fromString "/a/different/path/to/nowhere"} + cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}] + +testComputeCookieStringPathMatchingWithParms :: Test +testComputeCookieStringPathMatchingWithParms = TestCase $ assertEqual "Path matching succeeds when request has GET params" + (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) + where request = default_request {HC.path = fromString "/a/path/to/nowhere?var=val"} + cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}] + +testComputeCookieStringSecure :: Test +testComputeCookieStringSecure = TestCase $ assertEqual "Secure flag filters properly" + (fromString "", cookie_jar) (computeCookieString default_request cookie_jar default_time True) + where cookie_jar = createCookieJar [default_cookie {cookie_secure_only = True}] + +testComputeCookieStringHttpOnly :: Test +testComputeCookieStringHttpOnly = TestCase $ assertEqual "http-only flag filters properly" + (fromString "", cookie_jar) (computeCookieString default_request cookie_jar default_time False) + where cookie_jar = createCookieJar [default_cookie {cookie_http_only = True}] + +testComputeCookieStringSort :: Test +testComputeCookieStringSort = TestCase $ assertEqual "Sorting works correctly" + (fromString "c1=v1;c3=v3;c4=v4;c2=v2", cookie_jar_out) format_output + where now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 11) + cookie_jar = createCookieJar [ default_cookie { cookie_name = fromString "c1" + , cookie_value = fromString "v1" + , cookie_path = fromString "/all/encompassing/request" + } + , default_cookie { cookie_name = fromString "c2" + , cookie_value = fromString "v2" + , cookie_path = fromString "/all" + } + , default_cookie { cookie_name = fromString "c3" + , cookie_value = fromString "v3" + , cookie_path = fromString "/all/encompassing" + , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) + } + , default_cookie { cookie_name = fromString "c4" + , cookie_value = fromString "v4" + , cookie_path = fromString "/all/encompassing" + , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2) + } + ] + cookie_jar_out = createCookieJar [ default_cookie { cookie_name = fromString "c1" + , cookie_value = fromString "v1" + , cookie_path = fromString "/all/encompassing/request" + , cookie_last_access_time = now + } + , default_cookie { cookie_name = fromString "c2" + , cookie_value = fromString "v2" + , cookie_path = fromString "/all" + , cookie_last_access_time = now + } + , default_cookie { cookie_name = fromString "c3" + , cookie_value = fromString "v3" + , cookie_path = fromString "/all/encompassing" + , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) + , cookie_last_access_time = now + } + , default_cookie { cookie_name = fromString "c4" + , cookie_value = fromString "v4" + , cookie_path = fromString "/all/encompassing" + , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2) + , cookie_last_access_time = now + } + ] + request = default_request {HC.path = fromString "/all/encompassing/request/path"} + format_output = computeCookieString request cookie_jar default_time False + +testInsertCookiesIntoRequestWorks :: Test +testInsertCookiesIntoRequestWorks = TestCase $ assertEqual "Inserting cookies works" + [(CI.mk $ fromString "Cookie", fromString "key=val")] out_headers + where out_headers = HC.requestHeaders req + (req, _) = insertCookiesIntoRequest req' cookie_jar default_time + cookie_jar = createCookieJar [ default_cookie { cookie_name = fromString "key" + , cookie_value = fromString "val" + } + ] + req' = default_request {HC.requestHeaders = [(CI.mk $ fromString "Cookie", + fromString "otherkey=otherval")]} + +testReceiveSetCookie :: Test +testReceiveSetCookie = TestCase $ assertEqual "Receiving a Set-Cookie" + (createCookieJar [default_cookie]) (receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) + +testReceiveSetCookieTrailingDot :: Test +testReceiveSetCookieTrailingDot = TestCase $ assertEqual "Receiving a Set-Cookie with a trailing domain dot" + (createCookieJar []) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) + where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "www.google.com."} + +testReceiveSetCookieLeadingDot :: Test +testReceiveSetCookieLeadingDot = TestCase $ assertEqual "Receiving a Set-Cookie with a leading domain dot" + (createCookieJar [default_cookie]) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) + where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString ".www.google.com"} + +testReceiveSetCookieNoDomain :: Test +testReceiveSetCookieNoDomain = TestCase $ assertEqual "Receiving cookie without domain" + (createCookieJar [default_cookie]) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) + where set_cookie = default_set_cookie {setCookieDomain = Nothing} + +testReceiveSetCookieEmptyDomain :: Test +testReceiveSetCookieEmptyDomain = TestCase $ assertEqual "Receiving cookie with empty domain" + (createCookieJar [default_cookie]) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) + where set_cookie = default_set_cookie {setCookieDomain = Just BS.empty} + +-- Can't test public suffixes until that module is written + +testReceiveSetCookieNonMatchingDomain :: Test +testReceiveSetCookieNonMatchingDomain = TestCase $ assertEqual "Receiving cookie with non-matching domain" + (createCookieJar []) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) + where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "www.wikipedia.org"} + +testReceiveSetCookieHostOnly :: Test +testReceiveSetCookieHostOnly = TestCase $ assertBool "Checking host-only flag gets set" $ + cookie_host_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] + where set_cookie = default_set_cookie {setCookieDomain = Nothing} + +testReceiveSetCookieHostOnlyNotSet :: Test +testReceiveSetCookieHostOnlyNotSet = TestCase $ assertBool "Checking host-only flag doesn't get set" $ + not $ cookie_host_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] + where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "google.com"} + +testReceiveSetCookieHttpOnly :: Test +testReceiveSetCookieHttpOnly = TestCase $ assertBool "Checking http-only flag gets set" $ + cookie_http_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] + where set_cookie = default_set_cookie {setCookieHttpOnly = True} + +testReceiveSetCookieHttpOnlyNotSet :: Test +testReceiveSetCookieHttpOnlyNotSet = TestCase $ assertBool "Checking http-only flag doesn't get set" $ + not $ cookie_http_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] + where set_cookie = default_set_cookie {setCookieHttpOnly = False} + +testReceiveSetCookieHttpOnlyDrop :: Test +testReceiveSetCookieHttpOnlyDrop = TestCase $ assertEqual "Checking non http request gets dropped" + (createCookieJar []) (receiveSetCookie set_cookie default_request default_time False $ createCookieJar []) + where set_cookie = default_set_cookie {setCookieHttpOnly = True} + +testReceiveSetCookieName :: Test +testReceiveSetCookieName = TestCase $ assertEqual "Name gets set correctly" + (fromString "name") (cookie_name $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) + +testReceiveSetCookieValue :: Test +testReceiveSetCookieValue = TestCase $ assertEqual "Value gets set correctly" + (fromString "value") (cookie_value $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) + +testReceiveSetCookieExpiry :: Test +testReceiveSetCookieExpiry = TestCase $ assertEqual "Expiry gets set correctly" + now_plus_diff_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) + where now_plus_diff_time = ((fromRational $ toRational default_diff_time) `addUTCTime` default_time) + +testReceiveSetCookieNoMaxAge :: Test +testReceiveSetCookieNoMaxAge = TestCase $ assertEqual "Expiry is based on the given value" + default_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie cookie_without_max_age default_request default_time True $ createCookieJar []) + where cookie_without_max_age = default_set_cookie {setCookieMaxAge = Nothing} + +testReceiveSetCookieNoExpiry :: Test +testReceiveSetCookieNoExpiry = TestCase $ assertEqual "Expiry is based on max age" + now_plus_diff_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie cookie_without_expiry default_request default_time True $ createCookieJar []) + where now_plus_diff_time = ((fromRational $ toRational default_diff_time) `addUTCTime` default_time) + cookie_without_expiry = default_set_cookie {setCookieExpires = Nothing} + +testReceiveSetCookieNoExpiryNoMaxAge :: Test +testReceiveSetCookieNoExpiryNoMaxAge = TestCase $ assertBool "Expiry is set to a future date" $ + default_time < (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie basic_cookie default_request default_time True $ createCookieJar []) + where basic_cookie = default_set_cookie { setCookieExpires = Nothing, setCookieMaxAge = Nothing } + +testReceiveSetCookiePath :: Test +testReceiveSetCookiePath = TestCase $ assertEqual "Path gets set correctly" + (fromString "/a/path") (cookie_path $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) + where set_cookie = default_set_cookie {setCookiePath = Just $ fromString "/a/path"} + +testReceiveSetCookieNoPath :: Test +testReceiveSetCookieNoPath = TestCase $ assertEqual "Path gets set correctly when nonexistant" + (fromString "/a/path/to") (cookie_path $ head $ destroyCookieJar $ receiveSetCookie set_cookie request default_time True $ createCookieJar []) + where set_cookie = default_set_cookie {setCookiePath = Nothing} + request = default_request {HC.path = fromString "/a/path/to/nowhere"} + +testReceiveSetCookieCreationTime :: Test +testReceiveSetCookieCreationTime = TestCase $ assertEqual "Creation time gets set correctly" + now (cookie_creation_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar []) + where now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) + +testReceiveSetCookieAccessTime :: Test +testReceiveSetCookieAccessTime = TestCase $ assertEqual "Last access time gets set correctly" + now (cookie_last_access_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar []) + where now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) + +testReceiveSetCookiePersistent :: Test +testReceiveSetCookiePersistent = TestCase $ assertBool "Persistent flag gets set correctly" $ + cookie_persistent $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] + where set_cookie = default_set_cookie {setCookieExpires = Just default_time} + +testReceiveSetCookieSecure :: Test +testReceiveSetCookieSecure = TestCase $ assertBool "Secure flag gets set correctly" $ + cookie_secure_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] + where set_cookie = default_set_cookie {setCookieSecure = True} + +testReceiveSetCookieMaxAge :: Test +testReceiveSetCookieMaxAge = TestCase $ assertEqual "Max-Age gets set correctly" + total (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request now True $ createCookieJar []) + where set_cookie = default_set_cookie { setCookieExpires = Nothing + , setCookieMaxAge = Just $ secondsToDiffTime 10 + } + now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) + total = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 22) + +testReceiveSetCookiePreferMaxAge :: Test +testReceiveSetCookiePreferMaxAge = TestCase $ assertEqual "Max-Age is preferred over Expires" + total (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request now True $ createCookieJar []) + where set_cookie = default_set_cookie { setCookieExpires = Just exp + , setCookieMaxAge = Just $ secondsToDiffTime 10 + } + exp = UTCTime (ModifiedJulianDay 11) (secondsToDiffTime 5) + now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) + total = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 22) + +testReceiveSetCookieExisting :: Test +testReceiveSetCookieExisting = TestCase $ assertEqual "Existing cookie gets updated" + t (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [default_cookie]) + where set_cookie = default_set_cookie { setCookieExpires = Just t + , setCookieMaxAge = Nothing + } + t = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) + +testReceiveSetCookieExistingCreation :: Test +testReceiveSetCookieExistingCreation = TestCase $ assertEqual "Creation time gets updated in existing cookie" + default_time (cookie_creation_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar [default_cookie]) + where now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) + +testReceiveSetCookieExistingHttpOnly :: Test +testReceiveSetCookieExistingHttpOnly = TestCase $ assertEqual "Existing http-only cookie gets dropped" + default_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time False $ createCookieJar [existing_cookie]) + where existing_cookie = default_cookie {cookie_http_only = True} + +ipParseTests :: Spec +ipParseTests = do + it "Valid IP" testValidIp + it "Digit Too High" testIpNumTooHigh + it "Too Many Segments" testTooManySegmentsInIp + it "Chars in IP" testCharsInIp + +domainMatchingTests :: Spec +domainMatchingTests = do + it "Should Match" testDomainMatchesSuccess + it "Same Domain" testSameDomain + it "Sibling Domain" testSiblingDomain + it "Parent Domain" testParentDomain + it "Checking for Naive suffix-check" testNaiveSuffixDomain + +defaultPathTests :: Spec +defaultPathTests = do + it "Basic default path test" testDefaultPath + it "Basic populated default path" testPopulatedDefaultPath + it "Default path from request with GET params works" testParamsDefaultPath + it "Getting a default path that ends in a slash" testDefaultPathEndingInSlash + it "Getting a short default path" testShortDefaultPath + +pathMatchingTests :: Spec +pathMatchingTests = do + it "Same paths match" testSamePathsMatch + it "Putting slash at end" testPathSlashAtEnd + it "Not putting slash at end" testPathNoSlashAtEnd + it "Diverging paths don't match" testDivergingPaths + +equalityTests :: Spec +equalityTests = do + it "The same cookie should be equal to itself" testCookieEqualitySuccess + it "Changing extra options shouldn't change equality" testCookieEqualityResiliance + it "Changing a cookie's domain should change its equality" testDomainChangesEquality + +removeTests :: Spec +removeTests = do + it "Removing a cookie works" testRemoveCookie + it "Removing a nonexistant cookie doesn't work" testRemoveNonexistantCookie + it "Removing the correct cookie" testRemoveCorrectCookie + +evictionTests :: Spec +evictionTests = do + it "Testing eviction" testEvictExpiredCookies + it "Evicting from empty cookie jar" testEvictNoCookies + +sendingTests :: Spec +sendingTests = do + it "Updates last access time upon using cookies" testComputeCookieStringUpdateLastAccessTime + it "Host-only flag matches exact host" testComputeCookieStringHostOnly + it "Host-only flag doesn't match subdomain" testComputeCookieStringHostOnlyFilter + it "Domain matching works properly" testComputeCookieStringDomainMatching + it "Path matching works" testComputeCookieStringPathMatching + it "Path matching fails when it should" testComputeCookieStringPathMatchingFails + it "Path matching succeeds when request has GET params" testComputeCookieStringPathMatchingWithParms + it "Secure flag filters correctly" testComputeCookieStringSecure + it "Http-only flag filters correctly" testComputeCookieStringHttpOnly + it "Sorting works correctly" testComputeCookieStringSort + it "Inserting cookie header works" testInsertCookiesIntoRequestWorks + +receivingTests :: Spec +receivingTests = do + it "Can receive set-cookie" testReceiveSetCookie + it "Receiving a Set-Cookie with a trailing dot on the domain" testReceiveSetCookieTrailingDot + it "Receiving a Set-Cookie with a leading dot on the domain" testReceiveSetCookieLeadingDot + it "Set-Cookie with no domain" testReceiveSetCookieNoDomain + it "Set-Cookie with empty domain" testReceiveSetCookieEmptyDomain + it "Set-Cookie with non-matching domain" testReceiveSetCookieNonMatchingDomain + it "Host-only flag gets set" testReceiveSetCookieHostOnly + it "Host-only flag doesn't get set" testReceiveSetCookieHostOnlyNotSet + it "Http-only flag gets set" testReceiveSetCookieHttpOnly + it "Http-only flag doesn't get set" testReceiveSetCookieHttpOnlyNotSet + it "Checking non http request gets dropped" testReceiveSetCookieHttpOnlyDrop + it "Name gets set correctly" testReceiveSetCookieName + it "Value gets set correctly" testReceiveSetCookieValue + it "Expiry gets set correctly" testReceiveSetCookieExpiry + it "Expiry gets set based on max age if no expiry is given" testReceiveSetCookieNoExpiry + it "Expiry gets set based on given value if no max age is given" testReceiveSetCookieNoMaxAge + it "Expiry gets set to a future date if no expiry and no max age are given" testReceiveSetCookieNoExpiryNoMaxAge + it "Path gets set correctly when nonexistant" testReceiveSetCookieNoPath + it "Path gets set correctly" testReceiveSetCookiePath + it "Creation time gets set correctly" testReceiveSetCookieCreationTime + it "Last access time gets set correctly" testReceiveSetCookieAccessTime + it "Persistent flag gets set correctly" testReceiveSetCookiePersistent + it "Existing cookie gets updated" testReceiveSetCookieExisting + it "Creation time gets updated in existing cookie" testReceiveSetCookieExistingCreation + it "Existing http-only cookie gets dropped" testReceiveSetCookieExistingHttpOnly + it "Secure flag gets set correctly" testReceiveSetCookieSecure + it "Max-Age flag gets set correctly" testReceiveSetCookieMaxAge + it "Max-Age is preferred over Expires" testReceiveSetCookiePreferMaxAge + +cookieTest :: Spec +cookieTest = do + describe "ipParseTests" ipParseTests + describe "domainMatchingTests" domainMatchingTests + describe "defaultPathTests" defaultPathTests + describe "pathMatchingTests" pathMatchingTests + describe "equalityTests" equalityTests + describe "removeTests" removeTests + describe "evictionTests" evictionTests + describe "sendingTests" sendingTests + describe "receivingTests" receivingTests diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -1,228 +1,228 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -import Test.Hspec -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 -import Test.HUnit -import Network.Wai hiding (requestBody) -import qualified Network.Wai -import Network.Wai.Handler.Warp (run) -import Network.HTTP.Conduit -import Data.ByteString.Base64 (encode) -import Control.Concurrent (forkIO, killThread, threadDelay) -import Network.HTTP.Types -import Control.Exception.Lifted (try, SomeException) -import Network.HTTP.Conduit.ConnInfo -import Network (withSocketsDo) -import CookieTest (cookieTest) -import Data.Conduit.Network (runTCPServer, serverSettings, HostPreference (HostAny), appSink, appSource) -import Data.Conduit (($$), yield, Flush (Chunk)) -import Control.Monad.Trans.Resource (register) -import Control.Monad.IO.Class (liftIO) -import Control.Monad (forever) -import Data.ByteString.UTF8 (fromString) -import Data.Conduit.List (sourceList) -import Data.CaseInsensitive (mk) -import Data.List (partition) -import qualified Data.Conduit.List as CL -import qualified Data.Text.Encoding as TE -import qualified Data.ByteString.Lazy as L -import Blaze.ByteString.Builder (fromByteString) - -app :: Application -app req = - case pathInfo req of - [] -> return $ responseLBS status200 [] "homepage" - ["cookies"] -> return $ responseLBS status200 [tastyCookie] "cookies" - _ -> return $ responseLBS status404 [] "not found" - - where tastyCookie = (mk (fromString "Set-Cookie"), fromString "flavor=chocolate-chip;") - -main :: IO () -main = withSocketsDo $ hspec $ do - cookieTest - describe "simpleHttp" $ do - it "gets homepage" $ do - tid <- forkIO $ run 13000 app - threadDelay 10000 - lbs <- simpleHttp "http://127.0.0.1:13000/" - killThread tid - lbs @?= "homepage" - it "throws exception on 404" $ do - tid <- forkIO $ run 13001 app - threadDelay 10000 - elbs <- try $ simpleHttp "http://127.0.0.1:13001/404" - killThread tid - case elbs of - Left (_ :: SomeException) -> return () - Right _ -> error "Expected an exception" - describe "httpLbs" $ do - it "preserves 'set-cookie' headers" $ do - tid <- forkIO $ run 13010 app - threadDelay 10000 - request <- parseUrl "http://127.0.0.1:13010/cookies" - withManager $ \manager -> do - Response _ _ headers _ <- httpLbs request manager - let setCookie = mk (fromString "Set-Cookie") - (setCookieHeaders, _) = partition ((== setCookie) . fst) headers - liftIO $ assertBool "response contains a 'set-cookie' header" $ length setCookieHeaders > 0 - killThread tid - describe "manager" $ do - it "closes all connections" $ do - clearSocketsList - tid1 <- forkIO $ run 13002 app - tid2 <- forkIO $ run 13003 app - threadDelay 1000 - withManager $ \manager -> do - let Just req1 = parseUrl "http://127.0.0.1:13002/" - let Just req2 = parseUrl "http://127.0.0.1:13003/" - _res1a <- http req1 manager - _res1b <- http req1 manager - _res2 <- http req2 manager - return () - requireAllSocketsClosed - killThread tid2 - killThread tid1 - describe "DOS protection" $ do - it "overlong headers" $ do - tid1 <- forkIO overLongHeaders - threadDelay 1000 - withManager $ \manager -> do - _ <- register $ killThread tid1 - let Just req1 = parseUrl "http://127.0.0.1:13004/" - res1 <- try $ http req1 manager - case res1 of - Left e -> liftIO $ show (e :: SomeException) @?= show OverlongHeaders - _ -> error "Shouldn't have worked" - it "not overlong headers" $ do - tid1 <- forkIO notOverLongHeaders - threadDelay 1000 - withManager $ \manager -> do - _ <- register $ killThread tid1 - let Just req1 = parseUrl "http://127.0.0.1:13005/" - _ <- httpLbs req1 manager - return () - describe "redirects" $ do - it "doesn't double escape" $ do - tid <- forkIO redir - threadDelay 1000000 - withManager $ \manager -> do - _ <- register $ killThread tid - let go (encoded, final) = do - let Just req1 = parseUrl $ "http://127.0.0.1:13006/redir/" ++ encoded - res <- httpLbs req1 manager - liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200 - liftIO $ responseBody res @?= L.fromChunks [TE.encodeUtf8 final] - mapM_ go - [ ("hello world%2F", "hello world/") - , ("%D7%A9%D7%9C%D7%95%D7%9D", "שלום") - , ("simple", "simple") - , ("hello%20world", "hello world") - , ("hello%20world%3f%23", "hello world?#") - ] - - describe "chunked request body" $ do - it "works" $ do - tid <- forkIO echo - threadDelay 1000000 - withManager $ \manager -> do - _ <- register $ killThread tid - let go bss = do - let Just req1 = parseUrl "http://127.0.0.1:13007" - src = sourceList $ map fromByteString bss - lbs = L.fromChunks bss - res <- httpLbs req1 - { method = "POST" - , requestBody = RequestBodySourceChunked src - } manager - liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200 - let ts = S.concat . L.toChunks - liftIO $ ts (responseBody res) @?= ts lbs - mapM_ go - [ ["hello", "world"] - , replicate 500 "foo\003\n\r" - ] - describe "no status message" $ do - it "works" $ do - tid <- forkIO noStatusMessage - threadDelay 1000000 - withManager $ \manager -> do - _ <- register $ killThread tid - req <- parseUrl "http://127.0.0.1:13008" - res <- httpLbs req manager - liftIO $ do - Network.HTTP.Conduit.responseStatus res `shouldBe` status200 - responseBody res `shouldBe` "foo" - - describe "redirect" $ do - it "ignores large response bodies" $ do - tid <- forkIO $ run 13100 $ \req -> - case pathInfo req of - ["foo"] -> return $ responseLBS status200 [] "Hello World!" - _ -> return $ ResponseSource status301 [("location", "http://localhost:13100/foo")] $ forever $ yield $ Chunk $ fromByteString "hello\n" - threadDelay 1000000 - withManager $ \manager -> do - _ <- register $ killThread tid - req <- parseUrl "http://127.0.0.1:13100" - res <- httpLbs req manager - liftIO $ do - Network.HTTP.Conduit.responseStatus res `shouldBe` status200 - responseBody res `shouldBe` "Hello World!" - -overLongHeaders :: IO () -overLongHeaders = runTCPServer (serverSettings 13004 HostAny) $ \app -> - src $$ appSink app - where - src = sourceList $ "HTTP/1.0 200 OK\r\nfoo: " : repeat "bar" - -notOverLongHeaders :: IO () -notOverLongHeaders = runTCPServer (serverSettings 13005 HostAny) $ \app -> do - appSource app $$ CL.drop 1 - src $$ appSink app - where - src = sourceList $ [S.concat $ "HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\nContent-Length: 16384\r\n\r\n" : ( take 16384 $ repeat "x")] - -redir :: IO () -redir = - run 13006 redirApp - where - redirApp req = - case pathInfo req of - ["redir", foo] -> return $ responseLBS status301 - [ ("Location", "http://127.0.0.1:13006/content/" `S.append` escape foo) - ] - "" - ["content", foo] -> return $ responseLBS status200 [] $ L.fromChunks [TE.encodeUtf8 foo] - _ -> return $ responseLBS status404 [] "" - escape = S8.concatMap (S8.pack . encodeUrlChar) . TE.encodeUtf8 - - encodeUrlChar :: Char -> String - encodeUrlChar c - -- List of unreserved characters per RFC 3986 - -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding - | 'A' <= c && c <= 'Z' = [c] - | 'a' <= c && c <= 'z' = [c] - | '0' <= c && c <= '9' = [c] - encodeUrlChar c@'-' = [c] - encodeUrlChar c@'_' = [c] - encodeUrlChar c@'.' = [c] - encodeUrlChar c@'~' = [c] - encodeUrlChar y = - let (a, c) = fromEnum y `divMod` 16 - b = a `mod` 16 - showHex' x - | x < 10 = toEnum $ x + (fromEnum '0') - | x < 16 = toEnum $ x - 10 + (fromEnum 'A') - | otherwise = error $ "Invalid argument to showHex: " ++ show x - in ['%', showHex' b, showHex' c] - -echo :: IO () -echo = run 13007 $ \req -> do - bss <- Network.Wai.requestBody req $$ CL.consume - return $ responseLBS status200 [] $ L.fromChunks bss - -noStatusMessage :: IO () -noStatusMessage = runTCPServer (serverSettings 13008 HostAny) $ \app -> - src $$ appSink app - where - src = yield "HTTP/1.0 200\r\nContent-Length: 3\r\n\r\nfoo: barbazbin" +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +import Test.Hspec +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import Test.HUnit +import Network.Wai hiding (requestBody) +import qualified Network.Wai +import Network.Wai.Handler.Warp (run) +import Network.HTTP.Conduit +import Data.ByteString.Base64 (encode) +import Control.Concurrent (forkIO, killThread, threadDelay) +import Network.HTTP.Types +import Control.Exception.Lifted (try, SomeException) +import Network.HTTP.Conduit.ConnInfo +import Network (withSocketsDo) +import CookieTest (cookieTest) +import Data.Conduit.Network (runTCPServer, serverSettings, HostPreference (HostAny), appSink, appSource) +import Data.Conduit (($$), yield, Flush (Chunk)) +import Control.Monad.Trans.Resource (register) +import Control.Monad.IO.Class (liftIO) +import Control.Monad (forever) +import Data.ByteString.UTF8 (fromString) +import Data.Conduit.List (sourceList) +import Data.CaseInsensitive (mk) +import Data.List (partition) +import qualified Data.Conduit.List as CL +import qualified Data.Text.Encoding as TE +import qualified Data.ByteString.Lazy as L +import Blaze.ByteString.Builder (fromByteString) + +app :: Application +app req = + case pathInfo req of + [] -> return $ responseLBS status200 [] "homepage" + ["cookies"] -> return $ responseLBS status200 [tastyCookie] "cookies" + _ -> return $ responseLBS status404 [] "not found" + + where tastyCookie = (mk (fromString "Set-Cookie"), fromString "flavor=chocolate-chip;") + +main :: IO () +main = withSocketsDo $ hspec $ do + cookieTest + describe "simpleHttp" $ do + it "gets homepage" $ do + tid <- forkIO $ run 13000 app + threadDelay 10000 + lbs <- simpleHttp "http://127.0.0.1:13000/" + killThread tid + lbs @?= "homepage" + it "throws exception on 404" $ do + tid <- forkIO $ run 13001 app + threadDelay 10000 + elbs <- try $ simpleHttp "http://127.0.0.1:13001/404" + killThread tid + case elbs of + Left (_ :: SomeException) -> return () + Right _ -> error "Expected an exception" + describe "httpLbs" $ do + it "preserves 'set-cookie' headers" $ do + tid <- forkIO $ run 13010 app + threadDelay 10000 + request <- parseUrl "http://127.0.0.1:13010/cookies" + withManager $ \manager -> do + Response _ _ headers _ <- httpLbs request manager + let setCookie = mk (fromString "Set-Cookie") + (setCookieHeaders, _) = partition ((== setCookie) . fst) headers + liftIO $ assertBool "response contains a 'set-cookie' header" $ length setCookieHeaders > 0 + killThread tid + describe "manager" $ do + it "closes all connections" $ do + clearSocketsList + tid1 <- forkIO $ run 13002 app + tid2 <- forkIO $ run 13003 app + threadDelay 1000 + withManager $ \manager -> do + let Just req1 = parseUrl "http://127.0.0.1:13002/" + let Just req2 = parseUrl "http://127.0.0.1:13003/" + _res1a <- http req1 manager + _res1b <- http req1 manager + _res2 <- http req2 manager + return () + requireAllSocketsClosed + killThread tid2 + killThread tid1 + describe "DOS protection" $ do + it "overlong headers" $ do + tid1 <- forkIO overLongHeaders + threadDelay 1000 + withManager $ \manager -> do + _ <- register $ killThread tid1 + let Just req1 = parseUrl "http://127.0.0.1:13004/" + res1 <- try $ http req1 manager + case res1 of + Left e -> liftIO $ show (e :: SomeException) @?= show OverlongHeaders + _ -> error "Shouldn't have worked" + it "not overlong headers" $ do + tid1 <- forkIO notOverLongHeaders + threadDelay 1000 + withManager $ \manager -> do + _ <- register $ killThread tid1 + let Just req1 = parseUrl "http://127.0.0.1:13005/" + _ <- httpLbs req1 manager + return () + describe "redirects" $ do + it "doesn't double escape" $ do + tid <- forkIO redir + threadDelay 1000000 + withManager $ \manager -> do + _ <- register $ killThread tid + let go (encoded, final) = do + let Just req1 = parseUrl $ "http://127.0.0.1:13006/redir/" ++ encoded + res <- httpLbs req1 manager + liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200 + liftIO $ responseBody res @?= L.fromChunks [TE.encodeUtf8 final] + mapM_ go + [ ("hello world%2F", "hello world/") + , ("%D7%A9%D7%9C%D7%95%D7%9D", "שלום") + , ("simple", "simple") + , ("hello%20world", "hello world") + , ("hello%20world%3f%23", "hello world?#") + ] + + describe "chunked request body" $ do + it "works" $ do + tid <- forkIO echo + threadDelay 1000000 + withManager $ \manager -> do + _ <- register $ killThread tid + let go bss = do + let Just req1 = parseUrl "http://127.0.0.1:13007" + src = sourceList $ map fromByteString bss + lbs = L.fromChunks bss + res <- httpLbs req1 + { method = "POST" + , requestBody = RequestBodySourceChunked src + } manager + liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200 + let ts = S.concat . L.toChunks + liftIO $ ts (responseBody res) @?= ts lbs + mapM_ go + [ ["hello", "world"] + , replicate 500 "foo\003\n\r" + ] + describe "no status message" $ do + it "works" $ do + tid <- forkIO noStatusMessage + threadDelay 1000000 + withManager $ \manager -> do + _ <- register $ killThread tid + req <- parseUrl "http://127.0.0.1:13008" + res <- httpLbs req manager + liftIO $ do + Network.HTTP.Conduit.responseStatus res `shouldBe` status200 + responseBody res `shouldBe` "foo" + + describe "redirect" $ do + it "ignores large response bodies" $ do + tid <- forkIO $ run 13100 $ \req -> + case pathInfo req of + ["foo"] -> return $ responseLBS status200 [] "Hello World!" + _ -> return $ ResponseSource status301 [("location", "http://localhost:13100/foo")] $ forever $ yield $ Chunk $ fromByteString "hello\n" + threadDelay 1000000 + withManager $ \manager -> do + _ <- register $ killThread tid + req <- parseUrl "http://127.0.0.1:13100" + res <- httpLbs req manager + liftIO $ do + Network.HTTP.Conduit.responseStatus res `shouldBe` status200 + responseBody res `shouldBe` "Hello World!" + +overLongHeaders :: IO () +overLongHeaders = runTCPServer (serverSettings 13004 HostAny) $ \app -> + src $$ appSink app + where + src = sourceList $ "HTTP/1.0 200 OK\r\nfoo: " : repeat "bar" + +notOverLongHeaders :: IO () +notOverLongHeaders = runTCPServer (serverSettings 13005 HostAny) $ \app -> do + appSource app $$ CL.drop 1 + src $$ appSink app + where + src = sourceList $ [S.concat $ "HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\nContent-Length: 16384\r\n\r\n" : ( take 16384 $ repeat "x")] + +redir :: IO () +redir = + run 13006 redirApp + where + redirApp req = + case pathInfo req of + ["redir", foo] -> return $ responseLBS status301 + [ ("Location", "http://127.0.0.1:13006/content/" `S.append` escape foo) + ] + "" + ["content", foo] -> return $ responseLBS status200 [] $ L.fromChunks [TE.encodeUtf8 foo] + _ -> return $ responseLBS status404 [] "" + escape = S8.concatMap (S8.pack . encodeUrlChar) . TE.encodeUtf8 + + encodeUrlChar :: Char -> String + encodeUrlChar c + -- List of unreserved characters per RFC 3986 + -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding + | 'A' <= c && c <= 'Z' = [c] + | 'a' <= c && c <= 'z' = [c] + | '0' <= c && c <= '9' = [c] + encodeUrlChar c@'-' = [c] + encodeUrlChar c@'_' = [c] + encodeUrlChar c@'.' = [c] + encodeUrlChar c@'~' = [c] + encodeUrlChar y = + let (a, c) = fromEnum y `divMod` 16 + b = a `mod` 16 + showHex' x + | x < 10 = toEnum $ x + (fromEnum '0') + | x < 16 = toEnum $ x - 10 + (fromEnum 'A') + | otherwise = error $ "Invalid argument to showHex: " ++ show x + in ['%', showHex' b, showHex' c] + +echo :: IO () +echo = run 13007 $ \req -> do + bss <- Network.Wai.requestBody req $$ CL.consume + return $ responseLBS status200 [] $ L.fromChunks bss + +noStatusMessage :: IO () +noStatusMessage = runTCPServer (serverSettings 13008 HostAny) $ \app -> + src $$ appSink app + where + src = yield "HTTP/1.0 200\r\nContent-Length: 3\r\n\r\nfoo: barbazbin"