http-conduit 1.8.4.3 → 1.8.4.4
raw patch · 16 files changed
+3014/−2995 lines, 16 filesdep ~asn1-datadep ~attoparsecdep ~attoparsec-conduitsetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: asn1-data, attoparsec, attoparsec-conduit, base64-bytestring, blaze-builder, blaze-builder-conduit, certificate, cookie, cprng-aes, http-types, monad-control, network, socks, tls, tls-extra, transformers-base, void
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/−209
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.3-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 && < 0.6- , attoparsec-conduit >= 0.5 && < 0.6- , attoparsec >= 0.8.0.2 && < 0.11- , utf8-string >= 0.3.4- , blaze-builder >= 0.2.1 && < 0.4- , http-types >= 0.6 && < 0.8- , cprng-aes >= 0.2 && < 0.3- , tls >= 1.0.0 && < 1.1- , tls-extra >= 0.5.0 && < 0.6- , monad-control >= 0.3 && < 0.4- , containers >= 0.2- , certificate >= 1.3 && < 1.4- , case-insensitive >= 0.2- , base64-bytestring >= 0.1 && < 1.1- , asn1-data >= 0.5.1 && < 0.8- , data-default- , text- , transformers-base >= 0.4 && < 0.5- , lifted-base >= 0.1- , socks >= 0.4 && < 0.5- , time- , cookie >= 0.4 && < 0.5- , void >= 0.5.5 && < 0.6- , 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.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
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,209 +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)-import Control.Monad.Trans.Resource (register)-import Control.Monad.IO.Class (liftIO)-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- lbs <- simpleHttp "http://127.0.0.1:13000/"- killThread tid- lbs @?= "homepage"- it "throws exception on 404" $ do- tid <- forkIO $ run 13001 app- 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- 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"--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"