http-conduit 1.8.4.4 → 1.8.4.5
raw patch · 16 files changed
+3014/−3014 lines, 16 filesdep ~networksetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: network
API changes (from Hackage documentation)
Files
- LICENSE +25/−25
- Network/HTTP/Conduit.hs +312/−312
- Network/HTTP/Conduit/Chunk.hs +64/−64
- Network/HTTP/Conduit/ConnInfo.hs +173/−173
- Network/HTTP/Conduit/Cookies.hs +270/−270
- Network/HTTP/Conduit/Internal.hs +5/−5
- Network/HTTP/Conduit/Manager.hs +471/−471
- Network/HTTP/Conduit/Parser.hs +123/−123
- Network/HTTP/Conduit/Request.hs +287/−287
- Network/HTTP/Conduit/Response.hs +152/−152
- Network/HTTP/Conduit/Types.hs +155/−155
- Network/HTTP/Conduit/Util.hs +71/−71
- Setup.lhs +8/−8
- http-conduit.cabal +124/−124
- test/CookieTest.hs +546/−546
- test/main.hs +228/−228
LICENSE view
@@ -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.
Network/HTTP/Conduit.hs view
@@ -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
Network/HTTP/Conduit/Chunk.hs view
@@ -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)
Network/HTTP/Conduit/ConnInfo.hs view
@@ -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
Network/HTTP/Conduit/Cookies.hs view
@@ -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)
Network/HTTP/Conduit/Internal.hs view
@@ -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
Network/HTTP/Conduit/Manager.hs view
@@ -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
Network/HTTP/Conduit/Parser.hs view
@@ -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
Network/HTTP/Conduit/Request.hs view
@@ -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"
Network/HTTP/Conduit/Response.hs view
@@ -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)
Network/HTTP/Conduit/Types.hs view
@@ -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 --- <http://www.yesodweb.com/book/settings-types>. -data Request m = Request - { method :: W.Method - -- ^ HTTP request method, eg GET, POST. - , secure :: Bool - -- ^ Whether to use HTTPS (ie, SSL). - , clientCertificates :: [(X509, Maybe PrivateKey)] - -- ^ SSL client certificates - , host :: S.ByteString - , port :: Int - , path :: S.ByteString - -- ^ Everything from the host to the query string. - , queryString :: S.ByteString - , requestHeaders :: W.RequestHeaders - -- ^ Custom HTTP request headers - -- - -- As already stated in the introduction, the Content-Length and Host - -- headers are set automatically by this module, and shall not be added to - -- requestHeaders. - -- - -- Moreover, the Accept-Encoding header is set implicitly to gzip for - -- convenience by default. This behaviour can be overridden if needed, by - -- setting the header explicitly to a different value. In order to omit the - -- Accept-Header altogether, set it to the empty string \"\". If you need an - -- empty Accept-Header (i.e. requesting the identity encoding), set it to a - -- non-empty white-space string, e.g. \" \". See RFC 2616 section 14.3 for - -- details about the semantics of the Accept-Header field. If you request a - -- content-encoding not supported by this module, you will have to decode - -- it yourself (see also the 'decompress' field). - -- - -- Note: Multiple header fields with the same field-name will result in - -- multiple header fields being sent and therefore it\'s the responsibility - -- of the client code to ensure that the rules from RFC 2616 section 4.2 - -- are honoured. - , requestBody :: RequestBody m - , proxy :: Maybe Proxy - -- ^ Optional HTTP proxy. - , socksProxy :: Maybe SocksConf - -- ^ Optional SOCKS proxy. - , 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+-- <http://www.yesodweb.com/book/settings-types>.+data Request m = Request+ { method :: W.Method+ -- ^ HTTP request method, eg GET, POST.+ , secure :: Bool+ -- ^ Whether to use HTTPS (ie, SSL).+ , clientCertificates :: [(X509, Maybe PrivateKey)]+ -- ^ SSL client certificates+ , host :: S.ByteString+ , port :: Int+ , path :: S.ByteString+ -- ^ Everything from the host to the query string.+ , queryString :: S.ByteString+ , requestHeaders :: W.RequestHeaders+ -- ^ Custom HTTP request headers+ --+ -- As already stated in the introduction, the Content-Length and Host+ -- headers are set automatically by this module, and shall not be added to+ -- requestHeaders.+ --+ -- Moreover, the Accept-Encoding header is set implicitly to gzip for+ -- convenience by default. This behaviour can be overridden if needed, by+ -- setting the header explicitly to a different value. In order to omit the+ -- Accept-Header altogether, set it to the empty string \"\". If you need an+ -- empty Accept-Header (i.e. requesting the identity encoding), set it to a+ -- non-empty white-space string, e.g. \" \". See RFC 2616 section 14.3 for+ -- details about the semantics of the Accept-Header field. If you request a+ -- content-encoding not supported by this module, you will have to decode+ -- it yourself (see also the 'decompress' field).+ --+ -- Note: Multiple header fields with the same field-name will result in+ -- multiple header fields being sent and therefore it\'s the responsibility+ -- of the client code to ensure that the rules from RFC 2616 section 4.2+ -- are honoured.+ , requestBody :: RequestBody m+ , proxy :: Maybe Proxy+ -- ^ Optional HTTP proxy.+ , socksProxy :: Maybe SocksConf+ -- ^ Optional SOCKS proxy.+ , 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)
Network/HTTP/Conduit/Util.hs view
@@ -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
Setup.lhs view
@@ -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
http-conduit.cabal view
@@ -1,124 +1,124 @@-name: http-conduit -version: 1.8.4.4 -license: BSD3 -license-file: LICENSE -author: Michael Snoyman <michael@snoyman.com> -maintainer: Michael Snoyman <michael@snoyman.com> -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 <http://www.yesodweb.com/book/http-conduit> for more information. - . - "Network.HTTP.Conduit.Browser" module has been moved to <http://hackage.haskell.org/package/http-conduit-browser/> -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 <michael@snoyman.com>+maintainer: Michael Snoyman <michael@snoyman.com>+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 <http://www.yesodweb.com/book/http-conduit> for more information.+ .+ "Network.HTTP.Conduit.Browser" module has been moved to <http://hackage.haskell.org/package/http-conduit-browser/>+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
test/CookieTest.hs view
@@ -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
test/main.hs view
@@ -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"