HTTP 4000.2.11 → 4000.5.0
raw patch · 22 files changed
Files
- CHANGES +15/−0
- HTTP.cabal +102/−52
- Network/Browser.hs +178/−178
- Network/BufferType.hs +16/−16
- Network/HTTP.hs +36/−33
- Network/HTTP/Auth.hs +22/−22
- Network/HTTP/Base.hs +180/−145
- Network/HTTP/Base64.hs +12/−12
- Network/HTTP/Cookie.hs +16/−16
- Network/HTTP/HandleStream.hs +45/−45
- Network/HTTP/Headers.hs +180/−25
- Network/HTTP/MD5Aux.hs +4/−3
- Network/HTTP/Proxy.hs +68/−14
- Network/HTTP/Stream.hs +34/−34
- Network/HTTP/Utils.hs +105/−9
- Network/Stream.hs +7/−13
- Network/StreamDebugger.hs +15/−15
- Network/StreamSocket.hs +13/−9
- Network/TCP.hs +113/−86
- test/Httpd.hs +158/−0
- test/UnitTests.hs +69/−0
- test/httpTests.hs +61/−35
CHANGES view
@@ -1,3 +1,18 @@+Version 4000.4.0: release 2022-02-22+ * Restrict to GHC >=7.6 and associated cleanups (Andreas Abel)+ * Drop deprecated instance Error (Andreas Abel)+ * Preparation for mtl-2.3 (Andreas Abel)+ * General tidying (Andreas Abel)+ * Support GHC 9.2 (Bodigrim)++Version 4000.3.16: release 2021-03-20+ * Support GHC-9.0 (Oleg Genrus)+ * Various dependency bumps (multiple people)+ * Try all addresses returned by getAddrInfo (Fraser Tweedale)++Version ?++ * If the URI contains "user:pass@" part, use it for Basic Authorization * Add a test harness. * Don't leak a socket when getHostAddr throws an exception. * Send cookies in request format, not response format.
HTTP.cabal view
@@ -1,17 +1,17 @@+Cabal-Version: 3.0 Name: HTTP-Version: 4000.2.11-Cabal-Version: >= 1.8+Version: 4000.5.0 Build-type: Simple-License: BSD3+License: BSD-3-Clause License-file: LICENSE Author: Warrick Gray <warrick.gray@hotmail.com>-Maintainer: Ganesh Sittampalam <http@projects.haskell.org>+Maintainer: Ganesh Sittampalam <ganesh@earth.li> Homepage: https://github.com/haskell/HTTP Category: Network Synopsis: A library for client-side HTTP-Description: +Description: - The HTTP package supports client-side web programming in Haskell. It lets you set up + The HTTP package supports client-side web programming in Haskell. It lets you set up HTTP connections, transmitting requests and processing the responses coming back, all from within the comforts of Haskell. It's dependent on the network package to operate, but other than that, the implementation is all written in Haskell.@@ -40,36 +40,64 @@ > setAllowRedirects True -- handle HTTP redirects > request $ getRequest "http://www.haskell.org/" > return (take 100 (rspBody rsp))+ .+ __Note:__ This package does not support HTTPS connections.+ If you need HTTPS, take a look at the following packages:+ .+ * <http://hackage.haskell.org/package/http-streams http-streams>+ .+ * <http://hackage.haskell.org/package/http-client http-client> (in combination with+ <http://hackage.haskell.org/package/http-client-tls http-client-tls>)+ .+ * <http://hackage.haskell.org/package/req req>+ .+ * <http://hackage.haskell.org/package/wreq wreq>+ . Extra-Source-Files: CHANGES +tested-with:+ GHC == 9.12.2+ GHC == 9.10.3+ GHC == 9.8.4+ GHC == 9.6.7+ GHC == 9.4.8+ GHC == 9.2.8+ GHC == 9.0.2+ GHC == 8.10.7+ GHC == 8.8.4+ GHC == 8.6.5+ GHC == 8.4.4+ GHC == 8.2.2+ -- CI failing for GHC 8.0 because of https://github.com/haskell/cabal/issues/10379+ -- GHC == 8.0.2+ Source-Repository head type: git location: https://github.com/haskell/HTTP.git -Flag old-base- description: Old, monolithic base- default: False--Flag mtl1- description: Use the old mtl version 1.- default: False- Flag warn-as-error default: False description: Build with warnings-as-errors+ manual: True -Flag network23- description: Use version 2.3.x or below of the network package+Flag conduit10+ description: Use version 1.0.x or below of the conduit package (for the test suite) default: False +Flag warp-tests+ description: Test against warp+ default: False+ manual: True+ Library- Exposed-modules: + Autogen-modules: Paths_HTTP+ Exposed-modules: Network.BufferType, Network.Stream, Network.StreamDebugger, Network.StreamSocket,- Network.TCP, + Network.TCP, Network.HTTP, Network.HTTP.Headers, Network.HTTP.Base,@@ -82,53 +110,75 @@ Other-modules: Network.HTTP.Base64, Network.HTTP.MD5Aux,- Network.HTTP.Utils+ Network.HTTP.Utils, Paths_HTTP GHC-options: -fwarn-missing-signatures -Wall- Build-depends: base >= 2 && < 4.8, network < 2.5, parsec- Extensions: FlexibleInstances- if flag(old-base)- Build-depends: base < 3- else- Build-depends: base >= 3, array, old-time, bytestring - if flag(mtl1)- Build-depends: mtl >= 1.1 && < 1.2- CPP-Options: -DMTL1- else- Build-depends: mtl >= 2.0 && < 2.2+ -- note the test harness constraints should be kept in sync with these+ -- where dependencies are shared+ build-depends:+ base >= 4.6.0.0 && < 4.22+ , array >= 0.3.0.2 && < 0.6+ , bytestring >= 0.9.1.5 && < 0.13+ , parsec >= 2.0 && < 3.2+ , time >= 1.1.2.3 && < 1.15+ , transformers >= 0.2.0.0 && < 0.7+ -- transformers-0.2.0.0 is the first to have Control.Monad.IO.Class+ -- The following dependencies are refined by flags, but they should+ -- still be mentioned here on the top-level.+ , mtl >= 2.0.0.0 && < 2.4+ , network >= 2.6 && < 3.3+ , network-uri >= 2.6 && < 2.7 + default-language: Haskell98+ default-extensions: FlexibleInstances+ if flag(warn-as-error) ghc-options: -Werror if os(windows)- Build-depends: Win32+ Build-depends: Win32 >= 2.2.0.0 && < 2.15 Test-Suite test type: exitcode-stdio-1.0 - build-tools: ghc >= 6.10 && < 7.10-+ default-language: Haskell98 hs-source-dirs: test main-is: httpTests.hs - -- note: version constraints are inherited from HTTP library stanza- build-depends: HTTP,- HUnit,- httpd-shed,- mtl >= 2.0 && < 2.2,- bytestring >= 0.9 && < 0.11,- case-insensitive >= 0.4 && < 1.2,- deepseq >= 1.3 && < 1.4,- http-types >= 0.6 && < 0.9,- conduit >= 0.4 && < 1.1,- wai >= 1.2 && < 1.4,- -- compile failure with warp 1.3.10- warp >= 1.2 && < 1.3.10,- pureMD5 >= 2.1 && < 2.2,- base >= 2 && < 4.8,- network,- split >= 0.1 && < 0.3,- test-framework,- test-framework-hunit+ other-modules:+ Httpd+ UnitTests + ghc-options: -Wall++ build-depends:+ HTTP+ -- constraints inherited from HTTP+ , base+ , bytestring+ , mtl+ , network+ , network-uri+ -- extra dependencies+ , deepseq >= 1.3.0.0 && < 1.6+ , httpd-shed >= 0.4 && < 0.5+ , HUnit >= 1.2.0.1 && < 1.7+ , pureMD5 >= 0.2.4 && < 2.2+ , split >= 0.1.3 && < 0.3+ , test-framework >= 0.2.0 && < 0.9+ , test-framework-hunit >= 0.3.0 && < 0.4++ if flag(warp-tests)+ CPP-Options: -DWARP_TESTS+ build-depends:+ case-insensitive >= 0.4.0.1 && < 1.3+ , conduit >= 1.0.8 && < 1.4+ , http-types >= 0.8.0 && < 1.0+ , wai >= 2.1.0 && < 3.3+ , warp >= 2.1.0 && < 3.5++ if flag(conduit10)+ build-depends: conduit < 1.1+ else+ build-depends: conduit >= 1.1, conduit-extra >= 1.1 && < 1.4
Network/Browser.hs view
@@ -1,18 +1,18 @@-{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, CPP #-}+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, CPP, FlexibleContexts #-} {- | Module : Network.Browser Copyright : See LICENSE file License : BSD- -Maintainer : Ganesh Sittampalam <http@projects.haskell.org>++Maintainer : Ganesh Sittampalam <ganesh@earth.li> Stability : experimental Portability : non-portable (not tested) Session-level interactions over HTTP.- -The "Network.Browser" goes beyond the basic "Network.HTTP" functionality in -providing support for more involved, and real, request/response interactions over ++The "Network.Browser" goes beyond the basic "Network.HTTP" functionality in+providing support for more involved, and real, request/response interactions over HTTP. Additional features supported are: * HTTP Authentication handling@@ -33,25 +33,25 @@ > setAllowRedirects True -- handle HTTP redirects > request $ getRequest "http://www.haskell.org/" > return (take 100 (rspBody rsp))- + -}-module Network.Browser +module Network.Browser ( BrowserState , BrowserAction -- browser monad, effectively a state monad. , Proxy(..)- + , browse -- :: BrowserAction a -> IO a , request -- :: Request -> BrowserAction Response- + , getBrowserState -- :: BrowserAction t (BrowserState t) , withBrowserState -- :: BrowserState t -> BrowserAction t a -> BrowserAction t a- + , setAllowRedirects -- :: Bool -> BrowserAction t () , getAllowRedirects -- :: BrowserAction t Bool , setMaxRedirects -- :: Int -> BrowserAction t () , getMaxRedirects -- :: BrowserAction t (Maybe Int)- + , Authority(..) , getAuthorities , setAuthorities@@ -59,12 +59,12 @@ , Challenge(..) , Qop(..) , Algorithm(..)- + , getAuthorityGen , setAuthorityGen , setAllowBasicAuth , getAllowBasicAuth- + , setMaxErrorRetries -- :: Maybe Int -> BrowserAction t () , getMaxErrorRetries -- :: BrowserAction t (Maybe Int) @@ -78,21 +78,21 @@ , getCookieFilter -- :: BrowserAction t (URI -> Cookie -> IO Bool) , defaultCookieFilter -- :: URI -> Cookie -> IO Bool , userCookieFilter -- :: URI -> Cookie -> IO Bool- + , Cookie(..) , getCookies -- :: BrowserAction t [Cookie] , setCookies -- :: [Cookie] -> BrowserAction t () , addCookie -- :: Cookie -> BrowserAction t ()- + , setErrHandler -- :: (String -> IO ()) -> BrowserAction t () , setOutHandler -- :: (String -> IO ()) -> BrowserAction t ()- + , setEventHandler -- :: (BrowserEvent -> BrowserAction t ()) -> BrowserAction t ()- + , BrowserEvent(..) , BrowserEventType(..) , RequestID- + , setProxy -- :: Proxy -> BrowserAction t () , getProxy -- :: BrowserAction t Proxy @@ -100,20 +100,20 @@ , getCheckForProxy -- :: BrowserAction t Bool , setDebugLog -- :: Maybe String -> BrowserAction t ()- + , getUserAgent -- :: BrowserAction t String , setUserAgent -- :: String -> BrowserAction t ()- + , out -- :: String -> BrowserAction t () , err -- :: String -> BrowserAction t () , ioAction -- :: IO a -> BrowserAction a , defaultGETRequest , defaultGETRequest_- + , formToRequest , uriDefaultTo- + -- old and half-baked; don't use: , Form(..) , FormVar@@ -133,23 +133,27 @@ import Network.Stream ( ConnError(..), Result ) import Network.BufferType+#if (MIN_VERSION_base(4,9,0)) && !(MIN_VERSION_base(4,13,0))+import Control.Monad.Fail+#endif import Data.Char (toLower) import Data.List (isPrefixOf) import Data.Maybe (fromMaybe, listToMaybe, catMaybes )+#if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative (..), (<$>))-#ifdef MTL1-import Control.Monad (filterM, forM_, when, ap)-#else-import Control.Monad (filterM, forM_, when) #endif-import Control.Monad.State (StateT (..), MonadIO (..), modify, gets, withStateT, evalStateT, MonadState (..))+import Control.Monad (filterM, forM_, when)+import Control.Monad.IO.Class+ ( MonadIO (..) )+import Control.Monad.State+ ( MonadState(..), gets, modify, StateT (..), evalStateT, withStateT ) import qualified System.IO ( hSetBuffering, hPutStr, stdout, stdin, hGetChar , BufferMode(NoBuffering, LineBuffering) )-import System.Time ( ClockTime, getClockTime )+import Data.Time.Clock ( UTCTime, getCurrentTime ) ------------------------------------------------------------------@@ -206,8 +210,8 @@ where cookiematch :: Cookie -> Bool cookiematch = cookieMatch (dom,path)- + -- | @setCookieFilter fn@ sets the cookie acceptance filter to @fn@. setCookieFilter :: (URI -> Cookie -> IO Bool) -> BrowserAction t () setCookieFilter f = modify (\b -> b { bsCookieFilter=f })@@ -250,7 +254,7 @@ Notes:- - digest authentication so far ignores qop, so fails to authenticate + - digest authentication so far ignores qop, so fails to authenticate properly with qop=auth-int challenges - calculates a1 more than necessary - doesn't reverse authenticate@@ -270,8 +274,8 @@ matchURI :: URI -> Bool matchURI s = (uriToAuthorityString s == dom) && (uriPath s `isPrefixOf` pth)- + -- | @getAuthorities@ return the current set of @Authority@s known -- to the browser. getAuthorities :: BrowserAction t [Authority]@@ -303,9 +307,9 @@ getAllowBasicAuth = gets bsAllowBasicAuth -- | @setMaxAuthAttempts mbMax@ sets the maximum number of authentication attempts--- to do. If @Nothing@, rever to default max.+-- to do. If @Nothing@, revert to default max. setMaxAuthAttempts :: Maybe Int -> BrowserAction t ()-setMaxAuthAttempts mb +setMaxAuthAttempts mb | fromMaybe 0 mb < 0 = return () | otherwise = modify (\ b -> b{bsMaxAuthAttempts=mb}) @@ -356,7 +360,7 @@ answerable chall = (chAlgorithm chall) == Just AlgMD5 buildAuth :: Challenge -> String -> String -> Authority- buildAuth (ChalBasic r) u p = + buildAuth (ChalBasic r) u p = AuthBasic { auSite=uri , auRealm=r , auUsername=u@@ -407,7 +411,7 @@ } instance Show (BrowserState t) where- show bs = "BrowserState { " + show bs = "BrowserState { " ++ shows (bsCookies bs) ("\n" {- ++ show (bsAuthorities bs) ++ "\n"-} ++ "AllowRedirects: " ++ shows (bsAllowRedirects bs) "} ")@@ -415,15 +419,12 @@ -- | @BrowserAction@ is the IO monad, but carrying along a 'BrowserState'. newtype BrowserAction conn a = BA { unBA :: StateT (BrowserState conn) IO a }-#ifdef MTL1- deriving (Functor, Monad, MonadIO, MonadState (BrowserState conn))--instance Applicative (BrowserAction conn) where- pure = return- (<*>) = ap-#else- deriving (Functor, Applicative, Monad, MonadIO, MonadState (BrowserState conn))+ deriving+ ( Functor, Applicative, Monad, MonadIO, MonadState (BrowserState conn)+#if MIN_VERSION_base(4,9,0)+ , MonadFail #endif+ ) runBA :: BrowserState conn -> BrowserAction conn a -> IO a runBA bs = flip evalStateT bs . unBA@@ -433,7 +434,7 @@ browse :: BrowserAction conn a -> IO a browse = runBA defaultBrowserState --- | The default browser state has the settings +-- | The default browser state has the settings defaultBrowserState :: BrowserState t defaultBrowserState = res where@@ -455,7 +456,7 @@ , bsConnectionPool = [] , bsCheckProxy = defaultAutoProxyDetect , bsProxy = noProxy- , bsDebug = Nothing + , bsDebug = Nothing , bsEvent = Nothing , bsRequestID = 0 , bsUserAgent = Nothing@@ -476,8 +477,8 @@ -- before doing so. nextRequest :: BrowserAction t a -> BrowserAction t a nextRequest act = do- let updReqID st = - let + let updReqID st =+ let rid = succ (bsRequestID st) in rid `seq` st{bsRequestID=rid}@@ -514,13 +515,13 @@ getAllowRedirects :: BrowserAction t Bool getAllowRedirects = gets bsAllowRedirects --- | @setMaxRedirects maxCount@ sets the maxiumum number of forwarding hops+-- | @setMaxRedirects maxCount@ sets the maximum number of forwarding hops -- we are willing to jump through. A no-op if the count is negative; if zero, -- the max is set to whatever default applies. Notice that setting the max -- redirects count does /not/ enable following of redirects itself; use -- 'setAllowRedirects' to do so. setMaxRedirects :: Maybe Int -> BrowserAction t ()-setMaxRedirects c +setMaxRedirects c | fromMaybe 0 c < 0 = return () | otherwise = modify (\b -> b{bsMaxRedirects=c}) @@ -542,7 +543,7 @@ -- | @setProxy p@ will disable proxy usage if @p@ is @NoProxy@. -- If @p@ is @Proxy proxyURL mbAuth@, then @proxyURL@ is interpreted--- as the URL of the proxy to use, possibly authenticating via +-- as the URL of the proxy to use, possibly authenticating via -- 'Authority' information in @mbAuth@. setProxy :: Proxy -> BrowserAction t () setProxy p =@@ -552,7 +553,7 @@ -- | @getProxy@ returns the current proxy settings. If -- the auto-proxy flag is set to @True@, @getProxy@ will--- perform the necessary +-- perform the necessary getProxy :: BrowserAction t Proxy getProxy = do p <- gets bsProxy@@ -563,7 +564,7 @@ NoProxy{} -> do flg <- gets bsCheckProxy if not flg- then return p + then return p else do np <- liftIO $ fetchProxy True{-issue warning on stderr if ill-formed...-} -- note: this resets the check-proxy flag; a one-off affair.@@ -599,7 +600,7 @@ -- A common form of user agent string is @\"name\/version (details)\"@. For -- example @\"cabal-install/0.10.2 (HTTP 4000.1.2)\"@. Including the version -- of this HTTP package can be helpful if you ever need to track down HTTP--- compatability quirks. This version is available via 'httpPackageVersion'.+-- compatibility quirks. This version is available via 'httpPackageVersion'. -- For more info see <http://en.wikipedia.org/wiki/User_agent>. -- setUserAgent :: String -> BrowserAction t ()@@ -611,10 +612,10 @@ n <- gets bsUserAgent return (maybe defaultUserAgent id n) --- | @RequestState@ is an internal tallying type keeping track of various --- per-connection counters, like the number of authorization attempts and +-- | @RequestState@ is an internal tallying type keeping track of various+-- per-connection counters, like the number of authorization attempts and -- forwards we've gone through.-data RequestState +data RequestState = RequestState { reqDenies :: Int -- ^ number of 401 responses so far , reqRedirects :: Int -- ^ number of redirects so far@@ -638,7 +639,7 @@ -- at which they occurred. data BrowserEvent = BrowserEvent- { browserTimestamp :: ClockTime+ { browserTimestamp :: UTCTime , browserRequestID :: RequestID , browserRequestURI :: {-URI-}String , browserEventType :: BrowserEventType@@ -657,7 +658,7 @@ | AuthChallenge | AuthResponse -}- + -- | @setEventHandler onBrowserEvent@ configures event handling. -- If @onBrowserEvent@ is @Nothing@, event handling is turned off; -- setting it to @Just onEv@ causes the @onEv@ IO action to be@@ -668,8 +669,8 @@ buildBrowserEvent :: BrowserEventType -> {-URI-}String -> RequestID -> IO BrowserEvent buildBrowserEvent bt uri reqID = do- ct <- getClockTime- return BrowserEvent + ct <- getCurrentTime+ return BrowserEvent { browserTimestamp = ct , browserRequestID = reqID , browserRequestURI = uri@@ -685,7 +686,7 @@ evt <- liftIO $ buildBrowserEvent bt uri (bsRequestID st) evH evt -- if it fails, we fail. --- | The default number of hops we are willing not to go beyond for +-- | The default number of hops we are willing not to go beyond for -- request forwardings. defaultMaxRetries :: Int defaultMaxRetries = 4@@ -711,7 +712,7 @@ -- is returned along with the 'Response' itself. request :: HStream ty => Request ty- -> BrowserAction (HandleStream ty) (URI,Response ty)+ -> BrowserAction (HandleStream ty) (URI,Response ty) request req = nextRequest $ do res <- request' nullVal initialState req reportEvent ResponseFinish (show (rqURI req))@@ -720,22 +721,22 @@ Left e -> do let errStr = ("Network.Browser.request: Error raised " ++ show e) err errStr- fail errStr+ Prelude.fail errStr where initialState = nullRequestState nullVal = buf_empty bufferOps --- | Internal helper function, explicitly carrying along per-request +-- | Internal helper function, explicitly carrying along per-request -- counts. request' :: HStream ty => ty- -> RequestState- -> Request ty- -> BrowserAction (HandleStream ty) (Result (URI,Response ty))+ -> RequestState+ -> Request ty+ -> BrowserAction (HandleStream ty) (Result (URI,Response ty)) request' nullVal rqState rq = do let uri = rqURI rq failHTTPS uri- let uria = reqURIAuth rq + let uria = reqURIAuth rq -- add cookies to request cookies <- getCookiesFor (uriAuthToString uria) (uriPath uri) {- Not for now:@@ -744,20 +745,20 @@ xs -> case chopAtDelim ':' xs of (_,[]) -> id- (usr,pwd) -> withAuth- AuthBasic{ auUserName = usr+ (usr,pwd) -> withAuth+ AuthBasic{ auUserName = usr , auPassword = pwd- , auRealm = "/"- , auSite = uri- }) $ do+ , auRealm = "/"+ , auSite = uri+ }) $ do -}- when (not $ null cookies) + when (not $ null cookies) (out $ "Adding cookies to request. Cookie names: " ++ unwords (map ckName cookies)) -- add credentials to request- rq' <- - if not (reqStopOnDeny rqState) - then return rq - else do + rq' <-+ if not (reqStopOnDeny rqState)+ then return rq+ else do auth <- anticipateChallenge rq case auth of Nothing -> return rq@@ -765,35 +766,35 @@ let rq'' = if not $ null cookies then insertHeaders [cookiesToHeader cookies] rq' else rq' p <- getProxy def_ua <- gets bsUserAgent- let defaultOpts = - case p of - NoProxy -> defaultNormalizeRequestOptions{normUserAgent=def_ua}- Proxy _ ath ->- defaultNormalizeRequestOptions- { normForProxy = True- , normUserAgent = def_ua- , normCustoms = - maybe []- (\ authS -> [\ _ r -> insertHeader HdrProxyAuthorization (withAuthority authS r) r])- ath- }+ let defaultOpts =+ case p of+ NoProxy -> defaultNormalizeRequestOptions{normUserAgent=def_ua}+ Proxy _ ath ->+ defaultNormalizeRequestOptions+ { normForProxy = True+ , normUserAgent = def_ua+ , normCustoms =+ maybe []+ (\ authS -> [\ _ r -> insertHeader HdrProxyAuthorization (withAuthority authS r) r])+ ath+ } let final_req = normalizeRequest defaultOpts rq'' out ("Sending:\n" ++ show final_req)- e_rsp <- + e_rsp <- case p of NoProxy -> dorequest (reqURIAuth rq'') final_req Proxy str _ath -> do- let notURI - | null pt || null hst = - URIAuth{ uriUserInfo = ""- , uriRegName = str- , uriPort = ""- }- | otherwise = - URIAuth{ uriUserInfo = ""- , uriRegName = hst- , uriPort = pt- }+ let notURI+ | null pt || null hst =+ URIAuth{ uriUserInfo = ""+ , uriRegName = str+ , uriPort = ""+ }+ | otherwise =+ URIAuth{ uriUserInfo = ""+ , uriRegName = hst+ , uriPort = pt+ } -- If the ':' is dropped from port below, dorequest will assume port 80. Leave it! where (hst, pt) = span (':'/=) str -- Proxy can take multiple forms - look for http://host:port first,@@ -804,21 +805,21 @@ (parseURI str) out $ "proxy uri host: " ++ uriRegName proxyURIAuth ++ ", port: " ++ uriPort proxyURIAuth- dorequest proxyURIAuth final_req+ dorequest proxyURIAuth final_req mbMx <- getMaxErrorRetries case e_rsp of- Left v - | (reqRetries rqState < fromMaybe defaultMaxErrorRetries mbMx) && + Left v+ | (reqRetries rqState < fromMaybe defaultMaxErrorRetries mbMx) && (v == ErrorReset || v == ErrorClosed) -> do --empty connnection pool in case connection has become invalid- modify (\b -> b { bsConnectionPool=[] }) + modify (\b -> b { bsConnectionPool=[] }) request' nullVal rqState{reqRetries=succ (reqRetries rqState)} rq- | otherwise -> + | otherwise -> return (Left v)- Right rsp -> do + Right rsp -> do out ("Received:\n" ++ show rsp) -- add new cookies to browser state- handleCookies uri (uriAuthToString $ reqURIAuth rq) + handleCookies uri (uriAuthToString $ reqURIAuth rq) (retrieveHeaders HdrSetCookie rsp) -- Deal with "Connection: close" in response. handleConnectionClose (reqURIAuth rq) (retrieveHeaders HdrConnection rsp)@@ -827,27 +828,27 @@ (4,0,1) -- Credentials not sent or refused. | reqDenies rqState > fromMaybe defaultMaxAuthAttempts mbMxAuths -> do out "401 - credentials again refused; exceeded retry count (2)"- return (Right (uri,rsp))- | otherwise -> do+ return (Right (uri,rsp))+ | otherwise -> do out "401 - credentials not supplied or refused; retrying.." let hdrs = retrieveHeaders HdrWWWAuthenticate rsp- flg <- getAllowBasicAuth+ flg <- getAllowBasicAuth case pickChallenge flg (catMaybes $ map (headerToChallenge uri) hdrs) of Nothing -> do- out "no challenge"- return (Right (uri,rsp)) {- do nothing -}+ out "no challenge"+ return (Right (uri,rsp)) {- do nothing -} Just x -> do au <- challengeToAuthority uri x case au of Nothing -> do- out "no auth"- return (Right (uri,rsp)) {- do nothing -}+ out "no auth"+ return (Right (uri,rsp)) {- do nothing -} Just au' -> do out "Retrying request with new credentials"- request' nullVal- rqState{ reqDenies = succ(reqDenies rqState)- , reqStopOnDeny = False- }+ request' nullVal+ rqState{ reqDenies = succ(reqDenies rqState)+ , reqStopOnDeny = False+ } (insertHeader HdrAuthorization (withAuthority au' rq) rq) (4,0,7) -- Proxy Authentication required@@ -857,7 +858,7 @@ | otherwise -> do out "407 - proxy authentication required" let hdrs = retrieveHeaders HdrProxyAuthenticate rsp- flg <- getAllowBasicAuth+ flg <- getAllowBasicAuth case pickChallenge flg (catMaybes $ map (headerToChallenge uri) hdrs) of Nothing -> return (Right (uri,rsp)) {- do nothing -} Just x -> do@@ -874,56 +875,56 @@ out "Retrying with proxy authentication" setProxy (Proxy px (Just au')) request' nullVal- rqState{ reqDenies = succ(reqDenies rqState)- , reqStopOnDeny = False- }- rq+ rqState{ reqDenies = succ(reqDenies rqState)+ , reqStopOnDeny = False+ }+ rq (3,0,x) | x `elem` [2,3,1,7] -> do out ("30" ++ show x ++ " - redirect")- allow_redirs <- allowRedirect rqState- case allow_redirs of- False -> return (Right (uri,rsp))- _ -> do+ allow_redirs <- allowRedirect rqState+ case allow_redirs of+ False -> return (Right (uri,rsp))+ _ -> do case retrieveHeaders HdrLocation rsp of- [] -> do - err "No Location: header in redirect response"+ [] -> do+ err "No Location: header in redirect response" return (Right (uri,rsp))- (Header _ u:_) -> - case parseURIReference u of+ (Header _ u:_) ->+ case parseURIReference u of Nothing -> do err ("Parse of Location: header in a redirect response failed: " ++ u) return (Right (uri,rsp)) Just newURI- | {-uriScheme newURI_abs /= uriScheme uri && -}(not (supportedScheme newURI_abs)) -> do- err ("Unable to handle redirect, unsupported scheme: " ++ show newURI_abs)- return (Right (uri, rsp))- | otherwise -> do - out ("Redirecting to " ++ show newURI_abs ++ " ...") - + | {-uriScheme newURI_abs /= uriScheme uri && -}(not (supportedScheme newURI_abs)) -> do+ err ("Unable to handle redirect, unsupported scheme: " ++ show newURI_abs)+ return (Right (uri, rsp))+ | otherwise -> do+ out ("Redirecting to " ++ show newURI_abs ++ " ...")+ -- Redirect using GET request method, depending on -- response code. let toGet = x `elem` [2,3] method = if toGet then GET else rqMethod rq rq1 = rq { rqMethod=method, rqURI=newURI_abs } rq2 = if toGet then (replaceHeader HdrContentLength "0") (rq1 {rqBody = nullVal}) else rq1- + request' nullVal- rqState{ reqDenies = 0- , reqRedirects = succ(reqRedirects rqState)- , reqStopOnDeny = True- }+ rqState{ reqDenies = 0+ , reqRedirects = succ(reqRedirects rqState)+ , reqStopOnDeny = True+ } rq2 where newURI_abs = uriDefaultTo newURI uri (3,0,5) -> case retrieveHeaders HdrLocation rsp of- [] -> do - err "No Location header in proxy redirect response."+ [] -> do+ err "No Location header in proxy redirect response." return (Right (uri,rsp))- (Header _ u:_) -> - case parseURIReference u of+ (Header _ u:_) ->+ case parseURIReference u of Nothing -> do err ("Parse of Location header in a proxy redirect response failed: " ++ u) return (Right (uri,rsp))@@ -931,73 +932,73 @@ out ("Retrying with proxy " ++ show newuri ++ "...") setProxy (Proxy (uriToAuthorityString newuri) Nothing) request' nullVal rqState{ reqDenies = 0- , reqRedirects = 0- , reqRetries = succ (reqRetries rqState)- , reqStopOnDeny = True- }- rq+ , reqRedirects = 0+ , reqRetries = succ (reqRetries rqState)+ , reqStopOnDeny = True+ }+ rq _ -> return (Right (uri,rsp)) -- | The internal request handling state machine. dorequest :: (HStream ty) => URIAuth- -> Request ty- -> BrowserAction (HandleStream ty)- (Result (Response ty))+ -> Request ty+ -> BrowserAction (HandleStream ty)+ (Result (Response ty)) dorequest hst rqst = do pool <- gets bsConnectionPool let uPort = uriAuthPort Nothing{-ToDo: feed in complete URL-} hst conn <- liftIO $ filterM (\c -> c `isTCPConnectedTo` EndPoint (uriRegName hst) uPort) pool- rsp <- + rsp <- case conn of- [] -> do + [] -> do out ("Creating new connection to " ++ uriAuthToString hst)- reportEvent OpenConnection (show (rqURI rqst))+ reportEvent OpenConnection (show (rqURI rqst)) c <- liftIO $ openStream (uriRegName hst) uPort- updateConnectionPool c- dorequest2 c rqst+ updateConnectionPool c+ dorequest2 c rqst (c:_) -> do out ("Recovering connection to " ++ uriAuthToString hst)- reportEvent ReuseConnection (show (rqURI rqst))+ reportEvent ReuseConnection (show (rqURI rqst)) dorequest2 c rqst- case rsp of - Right (Response a b c _) -> + case rsp of+ Right (Response a b c _) -> reportEvent (ResponseEnd (a,b,c)) (show (rqURI rqst)) ; _ -> return () return rsp where dorequest2 c r = do dbg <- gets bsDebug st <- get- let + let onSendComplete = maybe (return ()) (\evh -> do- x <- buildBrowserEvent RequestSent (show (rqURI r)) (bsRequestID st)- runBA st (evh x)- return ())+ x <- buildBrowserEvent RequestSent (show (rqURI r)) (bsRequestID st)+ runBA st (evh x)+ return ()) (bsEvent st)- liftIO $ + liftIO $ maybe (sendHTTP_notify c r onSendComplete) (\ f -> do c' <- debugByteStream (f++'-': uriAuthToString hst) c- sendHTTP_notify c' r onSendComplete)- dbg+ sendHTTP_notify c' r onSendComplete)+ dbg updateConnectionPool :: HStream hTy => HandleStream hTy- -> BrowserAction (HandleStream hTy) ()+ -> BrowserAction (HandleStream hTy) () updateConnectionPool c = do pool <- gets bsConnectionPool let len_pool = length pool maxPoolSize <- fromMaybe defaultMaxPoolSize <$> gets bsMaxPoolSize when (len_pool > maxPoolSize) (liftIO $ close (last pool))- let pool' - | len_pool > maxPoolSize = init pool- | otherwise = pool+ let pool'+ | len_pool > maxPoolSize = init pool+ | otherwise = pool when (maxPoolSize > 0) $ modify (\b -> b { bsConnectionPool=c:pool' }) return ()- + -- | Default maximum number of open connections we are willing to have active. defaultMaxPoolSize :: Int defaultMaxPoolSize = 5@@ -1087,5 +1088,4 @@ , rqURI=u } _ -> error ("unexpected request: " ++ show m)-
Network/BufferType.hs view
@@ -6,7 +6,7 @@ -- Copyright : See LICENSE file -- License : BSD ----- Maintainer : Ganesh Sittampalam <http@projects.haskell.org>+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) --@@ -18,10 +18,10 @@ -- -- This module provides definitions for the standard buffer types that the -- package supports, i.e., for @String@ and @ByteString@ (strict and lazy.)--- +-- ----------------------------------------------------------------------------- module Network.BufferType- ( + ( BufferType(..) , BufferOp(..)@@ -44,7 +44,7 @@ -- that the library requires to operate over data embedded in HTTP -- requests and responses. That is, we use explicit dictionaries -- for the operations, but overload the name of the dicts themselves.--- +-- class BufferType bufType where bufferOps :: BufferOp bufType @@ -57,7 +57,7 @@ instance BufferType String where bufferOps = stringBufferOp --- | @BufferOp@ encodes the I/O operations of the underlying buffer over +-- | @BufferOp@ encodes the I/O operations of the underlying buffer over -- a Handle in an (explicit) dictionary type. May not be needed, but gives -- us flexibility in explicit overriding and wrapping up of these methods. --@@ -67,7 +67,7 @@ -- -- We supply three default @BufferOp@ values, for @String@ along with the -- strict and lazy versions of @ByteString@. To add others, provide @BufferOp@--- definitions for +-- definitions for data BufferOp a = BufferOp { buf_hGet :: Handle -> Int -> IO a@@ -92,8 +92,8 @@ -- | @strictBufferOp@ is the 'BufferOp' definition over @ByteString@s, -- the non-lazy kind. strictBufferOp :: BufferOp Strict.ByteString-strictBufferOp = - BufferOp +strictBufferOp =+ BufferOp { buf_hGet = Strict.hGet , buf_hGetContents = Strict.hGetContents , buf_hPut = Strict.hPut@@ -108,7 +108,7 @@ , buf_empty = Strict.empty , buf_isLineTerm = \ b -> Strict.length b == 2 && p_crlf == b || Strict.length b == 1 && p_lf == b- , buf_isEmpty = Strict.null + , buf_isEmpty = Strict.null } where p_crlf = Strict.pack crlf@@ -117,8 +117,8 @@ -- | @lazyBufferOp@ is the 'BufferOp' definition over @ByteString@s, -- the non-strict kind. lazyBufferOp :: BufferOp Lazy.ByteString-lazyBufferOp = - BufferOp +lazyBufferOp =+ BufferOp { buf_hGet = Lazy.hGet , buf_hGetContents = Lazy.hGetContents , buf_hPut = Lazy.hPut@@ -133,7 +133,7 @@ , buf_empty = Lazy.empty , buf_isLineTerm = \ b -> Lazy.length b == 2 && p_crlf == b || Lazy.length b == 1 && p_lf == b- , buf_isEmpty = Lazy.null + , buf_isEmpty = Lazy.null } where p_crlf = Lazy.pack crlf@@ -143,7 +143,7 @@ -- It is defined in terms of @strictBufferOp@ operations, -- unpacking/converting to @String@ when needed. stringBufferOp :: BufferOp String-stringBufferOp =BufferOp +stringBufferOp =BufferOp { buf_hGet = \ h n -> buf_hGet strictBufferOp h n >>= return . Strict.unpack , buf_hGetContents = \ h -> buf_hGetContents strictBufferOp h >>= return . Strict.unpack , buf_hPut = \ h s -> buf_hPut strictBufferOp h (Strict.pack s)@@ -154,11 +154,11 @@ , buf_toStr = id , buf_snoc = \ a x -> a ++ [toEnum (fromIntegral x)] , buf_splitAt = splitAt- , buf_span = \ p a -> + , buf_span = \ p a -> case Strict.span p (Strict.pack a) of- (x,y) -> (Strict.unpack x, Strict.unpack y)+ (x,y) -> (Strict.unpack x, Strict.unpack y) , buf_empty = [] , buf_isLineTerm = \ b -> b == crlf || b == lf- , buf_isEmpty = null + , buf_isEmpty = null }
Network/HTTP.hs view
@@ -3,8 +3,8 @@ -- Module : Network.HTTP -- Copyright : See LICENSE file -- License : BSD--- --- Maintainer : Ganesh Sittampalam <http@projects.haskell.org>+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) --@@ -27,28 +27,31 @@ -- namespace, letting you either use the default implementation here -- by importing @Network.HTTP@ or, for more specific uses, selectively -- import the modules in @Network.HTTP.*@. To wit, more than one kind of--- representation of the bulk data that flows across a HTTP connection is +-- representation of the bulk data that flows across a HTTP connection is -- supported. (see "Network.HTTP.HandleStream".)--- +-- -- /NOTE:/ The 'Request' send actions will normalize the @Request@ prior to transmission. -- Normalization such as having the request path be in the expected form and, possibly,--- introduce a default @Host:@ header if one isn't already present. If you do not +-- introduce a default @Host:@ header if one isn't already present.+-- Normalization also takes the @"user:pass\@"@ portion out of the the URI,+-- if it was supplied, and converts it into @Authorization: Basic$ header.+-- If you do not -- want the requests tampered with, but sent as-is, please import and use the -- the "Network.HTTP.HandleStream" or "Network.HTTP.Stream" modules instead. They--- export the same functions, but leaves construction and any normalization of +-- export the same functions, but leaves construction and any normalization of -- @Request@s to the user. -- -- /NOTE:/ This package only supports HTTP; it does not support HTTPS. -- Attempts to use HTTPS result in an error. ------------------------------------------------------------------------------module Network.HTTP +module Network.HTTP ( module Network.HTTP.Base , module Network.HTTP.Headers - {- the functionality that the implementation modules, - Network.HTTP.HandleStream and Network.HTTP.Stream,- exposes:- -}+ {- the functionality that the implementation modules,+ Network.HTTP.HandleStream and Network.HTTP.Stream,+ exposes:+ -} , simpleHTTP -- :: Request -> IO (Result Response) , simpleHTTP_ -- :: Stream s => s -> Request -> IO (Result Response) , sendHTTP -- :: Stream s => s -> Request -> IO (Result Response)@@ -57,12 +60,12 @@ , respondHTTP -- :: Stream s => s -> Response -> IO () , module Network.TCP- + , getRequest -- :: String -> Request_String , headRequest -- :: String -> Request_String , postRequest -- :: String -> Request_String , postRequestWithBody -- :: String -> String -> String -> Request_String- + , getResponseBody -- :: Result (Request ty) -> IO ty , getResponseCode -- :: Result (Request ty) -> IO ResponseCode ) where@@ -106,10 +109,10 @@ c <- openStream (host auth) (fromMaybe 80 (port auth)) let norm_r = normalizeRequest defaultNormalizeRequestOptions{normDoClose=True} r simpleHTTP_ c norm_r- + -- | Identical to 'simpleHTTP', but acting on an already opened stream. simpleHTTP_ :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty))-simpleHTTP_ s r = do +simpleHTTP_ s r = do let norm_r = normalizeRequest defaultNormalizeRequestOptions{normDoClose=True} r S.sendHTTP s norm_r @@ -118,7 +121,7 @@ -- closed upon receiving the response. sendHTTP :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) sendHTTP conn rq = do- let norm_r = normalizeRequest defaultNormalizeRequestOptions rq + let norm_r = normalizeRequest defaultNormalizeRequestOptions rq S.sendHTTP conn norm_r -- | @sendHTTP_notify hStream httpRequest action@ behaves like 'sendHTTP', but@@ -127,11 +130,11 @@ -- request transmission and its performance. sendHTTP_notify :: HStream ty => HandleStream ty- -> Request ty- -> IO ()- -> IO (Result (Response ty))+ -> Request ty+ -> IO ()+ -> IO (Result (Response ty)) sendHTTP_notify conn rq onSendComplete = do- let norm_r = normalizeRequest defaultNormalizeRequestOptions rq + let norm_r = normalizeRequest defaultNormalizeRequestOptions rq S.sendHTTP_notify conn norm_r onSendComplete -- | @receiveHTTP hStream@ reads a 'Request' from the 'HandleStream' @hStream@@@ -151,7 +154,7 @@ getRequest :: String -- ^URL to fetch -> Request_String -- ^The constructed request-getRequest urlString = +getRequest urlString = case parseURI urlString of Nothing -> error ("getRequest: Not a valid URL - " ++ urlString) Just u -> mkRequest GET u@@ -162,7 +165,7 @@ headRequest :: String -- ^URL to fetch -> Request_String -- ^The constructed request-headRequest urlString = +headRequest urlString = case parseURI urlString of Nothing -> error ("headRequest: Not a valid URL - " ++ urlString) Just u -> mkRequest HEAD u@@ -173,7 +176,7 @@ postRequest :: String -- ^URL to POST to -> Request_String -- ^The constructed request-postRequest urlString = +postRequest urlString = case parseURI urlString of Nothing -> error ("postRequest: Not a valid URL - " ++ urlString) Just u -> mkRequest POST u@@ -190,7 +193,7 @@ -> String -- ^Content-Type of body -> String -- ^The body of the request -> Request_String -- ^The constructed request-postRequestWithBody urlString typ body = +postRequestWithBody urlString typ body = case parseURI urlString of Nothing -> error ("postRequestWithBody: Not a valid URL - " ++ urlString) Just u -> setRequestBody (mkRequest POST u) (typ, body)@@ -202,7 +205,7 @@ getResponseBody (Left err) = fail (show err) getResponseBody (Right r) = return (rspBody r) --- | @getResponseBody response@ takes the response of a HTTP requesting action and+-- | @getResponseCode response@ takes the response of a HTTP requesting action and -- tries to extricate the status code of the 'Response' @response@. If the request action -- returned an error, an IO exception is raised. getResponseCode :: Result (Response ty) -> IO ResponseCode@@ -219,21 +222,21 @@ -- - comm timeouts -- - MIME & entity stuff (happening in separate module) -- - support \"*\" uri-request-string for OPTIONS request method--- --- +--+-- -- * Header notes: -- -- [@Host@] -- Required by HTTP\/1.1, if not supplied as part -- of a request a default Host value is extracted -- from the request-uri.--- --- [@Connection@] +--+-- [@Connection@] -- If this header is present in any request or -- response, and it's value is "close", then--- the current request\/response is the last +-- the current request\/response is the last -- to be allowed on that connection.--- +-- -- [@Expect@] -- Should a request contain a body, an Expect -- header will be added to the request. The added@@ -241,7 +244,7 @@ -- a 417 \"Expectation Failed\" response the request -- is attempted again without this added Expect -- header.--- +-- -- [@TransferEncoding,ContentLength,...@] -- if request is inconsistent with any of these -- header values then you may not receive any response@@ -254,7 +257,7 @@ -- [@1xx@] \"100 Continue\" will cause any unsent request body to be sent. -- \"101 Upgrade\" will be returned. -- Other 1xx responses are ignored.--- +-- -- [@417@] The reason for this code is \"Expectation failed\", indicating -- that the server did not like the Expect \"100-continue\" header -- added to a request. Receipt of 417 will induce another
Network/HTTP/Auth.hs view
@@ -4,14 +4,14 @@ -- Module : Network.HTTP.Auth -- Copyright : See LICENSE file -- License : BSD--- --- Maintainer : Ganesh Sittampalam <http@projects.haskell.org>+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) -- -- Representing HTTP Auth values in Haskell. -- Right now, it contains mostly functionality needed by 'Network.Browser'.--- +-- ----------------------------------------------------------------------------- module Network.HTTP.Auth ( Authority(..)@@ -38,7 +38,7 @@ -- | @Authority@ specifies the HTTP Authentication method to use for -- a given domain/realm; @Basic@ or @Digest@.-data Authority +data Authority = AuthBasic { auRealm :: String , auUsername :: String , auPassword :: String@@ -55,7 +55,7 @@ } -data Challenge +data Challenge = ChalBasic { chRealm :: String } | ChalDigest { chRealm :: String , chDomain :: [URI]@@ -74,29 +74,29 @@ show AlgMD5 = "md5" show AlgMD5sess = "md5-sess" --- | +-- | data Qop = QopAuth | QopAuthInt deriving(Eq,Show) -- | @withAuthority auth req@ generates a credentials value from the @auth@ 'Authority', -- in the context of the given request.--- +-- -- If a client nonce was to be used then this function might need to be of type ... -> BrowserAction String withAuthority :: Authority -> Request ty -> String withAuthority a rq = case a of AuthBasic{} -> "Basic " ++ base64encode (auUsername a ++ ':' : auPassword a) AuthDigest{} -> "Digest " ++- concat [ "username=" ++ quo (auUsername a)- , ",realm=" ++ quo (auRealm a)- , ",nonce=" ++ quo (auNonce a)- , ",uri=" ++ quo digesturi- , ",response=" ++ quo rspdigest+ concat [ "username=" ++ quo (auUsername a)+ , ",realm=" ++ quo (auRealm a)+ , ",nonce=" ++ quo (auNonce a)+ , ",uri=" ++ quo digesturi+ , ",response=" ++ quo rspdigest -- plus optional stuff:- , fromMaybe "" (fmap (\ alg -> ",algorithm=" ++ quo (show alg)) (auAlgorithm a))- , fromMaybe "" (fmap (\ o -> ",opaque=" ++ quo o) (auOpaque a))- , if null (auQop a) then "" else ",qop=auth"- ]+ , fromMaybe "" (fmap (\ alg -> ",algorithm=" ++ quo (show alg)) (auAlgorithm a))+ , fromMaybe "" (fmap (\ o -> ",opaque=" ++ quo o) (auOpaque a))+ , if null (auQop a) then "" else ",qop=auth"+ ] where quo s = '"':s ++ "\"" @@ -104,7 +104,7 @@ a1, a2 :: String a1 = auUsername a ++ ":" ++ auRealm a ++ ":" ++ auPassword a- + {- If the "qop" directive's value is "auth" or is unspecified, then A2 is:@@ -135,7 +135,7 @@ --- | @headerToChallenge base www_auth@ tries to convert the @WWW-Authenticate@ header +-- | @headerToChallenge base www_auth@ tries to convert the @WWW-Authenticate@ header -- @www_auth@ into a 'Challenge' value. headerToChallenge :: URI -> Header -> Maybe Challenge headerToChallenge baseURI (Header _ str) =@@ -173,12 +173,12 @@ -- with Maybe monad do { r <- lookup "realm" params ; n <- lookup "nonce" params- ; return $ + ; return $ ChalDigest { chRealm = r- , chDomain = (annotateURIs + , chDomain = (annotateURIs $ map parseURI- $ words - $ fromMaybe [] + $ words+ $ fromMaybe [] $ lookup "domain" params) , chNonce = n , chOpaque = lookup "opaque" params
Network/HTTP/Base.hs view
@@ -1,11 +1,11 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.Base -- Copyright : See LICENSE file -- License : BSD--- --- Maintainer : Ganesh Sittampalam <http@projects.haskell.org>+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) --@@ -27,12 +27,12 @@ , Request(..) , Response(..) , RequestMethod(..)- + , Request_String , Response_String , HTTPRequest , HTTPResponse- + -- ** URL Encoding , urlEncode , urlDecode@@ -41,7 +41,7 @@ -- ** URI authority parsing , URIAuthority(..) , parseURIAuthority- + -- internal , uriToAuthorityString -- :: URI -> String , uriAuthToString -- :: URIAuth -> String@@ -56,8 +56,8 @@ , ResponseData , ResponseCode , RequestData- - , NormalizeRequestOptions(..) ++ , NormalizeRequestOptions(..) , defaultNormalizeRequestOptions -- :: NormalizeRequestOptions ty , RequestNormalizer @@ -77,7 +77,7 @@ , uglyDeathTransfer , readTillEmpty1 , readTillEmpty2- + , defaultGETRequest , defaultGETRequest_ , mkRequest@@ -86,18 +86,18 @@ , defaultUserAgent , httpPackageVersion , libUA {- backwards compatibility, will disappear..soon -}- + , catchIO , catchIO_ , responseParseError- + , getRequestVersion , getResponseVersion , setRequestVersion , setResponseVersion , failHTTPS- + ) where import Network.URI@@ -107,7 +107,7 @@ ) import Control.Monad ( guard )-import Control.Monad.Error ()+ import Data.Bits ( (.&.), (.|.), shiftL, shiftR ) import Data.Word ( Word8 ) import Data.Char ( digitToInt, intToDigit, toLower, isDigit,@@ -120,10 +120,11 @@ import Network.BufferType ( BufferOp(..), BufferType(..) ) import Network.HTTP.Headers import Network.HTTP.Utils ( trim, crlf, sp, readsOne )+import qualified Network.HTTP.Base64 as Base64 (encode) import Text.Read.Lex (readDecP) import Text.ParserCombinators.ReadP- ( ReadP, readP_to_S, char, (<++), look, munch )+ ( ReadP, readP_to_S, char, (<++), look, munch, munch1 ) import Control.Exception as Exception (catch, IOException) @@ -134,11 +135,11 @@ ------------------ URI Authority parsing ------------------------ ----------------------------------------------------------------- -data URIAuthority = URIAuthority { user :: Maybe String, - password :: Maybe String,- host :: String,- port :: Maybe Int- } deriving (Eq,Show)+data URIAuthority = URIAuthority { user :: Maybe String,+ password :: Maybe String,+ host :: String,+ port :: Maybe Int+ } deriving (Eq,Show) -- | Parse the authority part of a URL. --@@ -153,18 +154,26 @@ pURIAuthority :: ReadP URIAuthority pURIAuthority = do- (u,pw) <- (pUserInfo `before` char '@') - <++ return (Nothing, Nothing)- h <- munch (/=':')- p <- orNothing (char ':' >> readDecP)- look >>= guard . null - return URIAuthority{ user=u, password=pw, host=h, port=p }+ (u,pw) <- (pUserInfo `before` char '@')+ <++ return (Nothing, Nothing)+ h <- rfc2732host <++ munch (/=':')+ p <- orNothing (char ':' >> readDecP)+ look >>= guard . null+ return URIAuthority{ user=u, password=pw, host=h, port=p } +-- RFC2732 adds support for '[literal-ipv6-address]' in the host part of a URL+rfc2732host :: ReadP String+rfc2732host = do+ _ <- char '['+ res <- munch1 (/=']')+ _ <- char ']'+ return res+ pUserInfo :: ReadP (Maybe String, Maybe String) pUserInfo = do- u <- orNothing (munch (`notElem` ":@"))- p <- orNothing (char ':' >> munch (/='@'))- return (u,p)+ u <- orNothing (munch (`notElem` ":@"))+ p <- orNothing (char ':' >> munch (/='@'))+ return (u,p) before :: Monad m => m a -> m b -> m a before a b = a >>= \x -> b >> return x@@ -177,20 +186,20 @@ uriToAuthorityString u = maybe "" uriAuthToString (uriAuthority u) uriAuthToString :: URIAuth -> String-uriAuthToString ua = - concat [ uriUserInfo ua +uriAuthToString ua =+ concat [ uriUserInfo ua , uriRegName ua- , uriPort ua- ]+ , uriPort ua+ ] uriAuthPort :: Maybe URI -> URIAuth -> Int-uriAuthPort mbURI u = +uriAuthPort mbURI u = case uriPort u of (':':s) -> readsOne id (default_port mbURI) s _ -> default_port mbURI where default_port Nothing = default_http- default_port (Just url) = + default_port (Just url) = case map toLower $ uriScheme url of "http:" -> default_http "https:" -> default_https@@ -200,7 +209,11 @@ default_http = 80 default_https = 443 +#if MIN_VERSION_base(4,13,0)+failHTTPS :: MonadFail m => URI -> m ()+#else failHTTPS :: Monad m => URI -> m ()+#endif failHTTPS uri | map toLower (uriScheme uri) == "https:" = fail "https not supported" | otherwise = return ()@@ -209,17 +222,17 @@ -- the information may either be in the request's URI or inside -- the Host: header. reqURIAuth :: Request ty -> URIAuth-reqURIAuth req = +reqURIAuth req = case uriAuthority (rqURI req) of Just ua -> ua _ -> case lookupHeader HdrHost (rqHeaders req) of Nothing -> error ("reqURIAuth: no URI authority for: " ++ show req)- Just h -> - case toHostPort h of- (ht,p) -> URIAuth { uriUserInfo = ""- , uriRegName = ht- , uriPort = p- }+ Just h ->+ case toHostPort h of+ (ht,p) -> URIAuth { uriUserInfo = ""+ , uriRegName = ht+ , uriPort = p+ } where -- Note: just in case you're wondering..the convention is to include the ':' -- in the port part..@@ -242,7 +255,7 @@ deriving(Eq) instance Show RequestMethod where- show x = + show x = case x of HEAD -> "HEAD" PUT -> "PUT"@@ -256,18 +269,18 @@ rqMethodMap :: [(String, RequestMethod)] rqMethodMap = [("HEAD", HEAD),- ("PUT", PUT),- ("GET", GET),- ("POST", POST),+ ("PUT", PUT),+ ("GET", GET),+ ("POST", POST), ("DELETE", DELETE),- ("OPTIONS", OPTIONS),- ("TRACE", TRACE),- ("CONNECT", CONNECT)]+ ("OPTIONS", OPTIONS),+ ("TRACE", TRACE),+ ("CONNECT", CONNECT)] --- +-- -- for backwards-ish compatibility; suggest -- migrating to new Req/Resp by adding type param.--- +-- type Request_String = Request String type Response_String = Response String @@ -300,9 +313,9 @@ show m ++ sp ++ alt_uri ++ sp ++ ver ++ crlf ++ foldr (++) [] (map show (dropHttpVersion h)) ++ crlf where- ver = fromMaybe httpVersion (getRequestVersion req)- alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/' - then u { uriPath = '/' : uriPath u } + ver = fromMaybe httpVersion (getRequestVersion req)+ alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/'+ then u { uriPath = '/' : uriPath u } else u instance HasHeaders (Request a) where@@ -319,7 +332,7 @@ type ResponseData = (ResponseCode,String,[Header]) -- | @RequestData@ contains the head of a HTTP request; method,--- its URL along with the auxillary/supporting header data.+-- its URL along with the auxiliary/supporting header data. type RequestData = (RequestMethod,URI,[Header]) -- | An HTTP Response.@@ -333,8 +346,8 @@ , rspHeaders :: [Header] , rspBody :: a }- --- This is an invalid representation of a received response, ++-- This is an invalid representation of a received response, -- since we have made the assumption that all responses are HTTP/1.1 instance Show (Response a) where show rsp@(Response (a,b,c) reason headers _) =@@ -375,17 +388,17 @@ defaultGETRequest uri = defaultGETRequest_ uri defaultGETRequest_ :: BufferType a => URI -> Request a-defaultGETRequest_ uri = mkRequest GET uri +defaultGETRequest_ uri = mkRequest GET uri -- | 'mkRequest method uri' constructs a well formed -- request for the given HTTP method and URI. It does not--- normalize the URI for the request _nor_ add the required +-- normalize the URI for the request _nor_ add the required -- Host: header. That is done either explicitly by the user -- or when requests are normalized prior to transmission. mkRequest :: BufferType ty => RequestMethod -> URI -> Request ty mkRequest meth uri = req where- req = + req = Request { rqURI = uri , rqBody = empty , rqHeaders = [ Header HdrContentLength "0"@@ -408,12 +421,12 @@ -- stub out the user info. updAuth = fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri) - withHost = + withHost = case uriToAuthorityString uri{uriAuthority=updAuth} of "" -> id h -> ((Header HdrHost h):) - uri_req + uri_req | forProxy = uri | otherwise = snd (splitRequestURI uri) -}@@ -459,12 +472,12 @@ where responseStatus _l _yes@(version:code:reason) = return (version,match code,concatMap (++" ") reason)- responseStatus l _no + responseStatus l _no | null l = failWith ErrorClosed -- an assumption | otherwise = parse_err l - parse_err l = - responseParseError + parse_err l =+ responseParseError "parseResponseHead" ("Response status line parse failure: " ++ l) @@ -482,7 +495,7 @@ -- the version info explicitly in their record types. You have to use -- {get,set}{Request,Response}Version for that. withVersion :: String -> [Header] -> [Header]-withVersion v hs +withVersion v hs | v == httpVersion = hs -- don't bother adding it if the default. | otherwise = (Header (HdrCustom "X-HTTP-Version") v) : hs @@ -498,7 +511,7 @@ -- | @getResponseVersion rsp@ returns the HTTP protocol version of--- the response @rsp@. If @Nothing@, the default 'httpVersion' can be +-- the response @rsp@. If @Nothing@, the default 'httpVersion' can be -- assumed. getResponseVersion :: Response a -> Maybe String getResponseVersion r = getHttpVersion r@@ -513,7 +526,7 @@ -- version info is represented internally. getHttpVersion :: HasHeaders a => a -> Maybe String-getHttpVersion r = +getHttpVersion r = fmap toVersion $ find isHttpVersion $ getHeaders r@@ -521,7 +534,7 @@ toVersion (Header _ x) = x setHttpVersion :: HasHeaders a => a -> String -> a-setHttpVersion r v = +setHttpVersion r v = setHeaders r $ withVersion v $ dropHttpVersion $@@ -532,7 +545,7 @@ isHttpVersion :: Header -> Bool isHttpVersion (Header (HdrCustom "X-HTTP-Version") _) = True-isHttpVersion _ = False +isHttpVersion _ = False @@ -566,9 +579,9 @@ where ans | rqst == HEAD = Done | otherwise = ExpectEntity- - ++ ----------------------------------------------------------------- ------------------ A little friendly funtionality --------------- -----------------------------------------------------------------@@ -671,7 +684,7 @@ urlEncode :: String -> String urlEncode [] = []-urlEncode (ch:t) +urlEncode (ch:t) | (isAscii ch && isAlphaNum ch) || ch `elem` "-_.~" = ch : urlEncode t | not (isAscii ch) = foldr escape (urlEncode t) (encodeChar ch) | otherwise = escape (fromIntegral (fromEnum ch)) (urlEncode t)@@ -704,24 +717,28 @@ -- | @getAuth req@ fishes out the authority portion of the URL in a request's @Host@ -- header.+#if MIN_VERSION_base(4,13,0)+getAuth :: MonadFail m => Request ty -> m URIAuthority+#else getAuth :: Monad m => Request ty -> m URIAuthority-getAuth r = +#endif+getAuth r = -- ToDo: verify that Network.URI functionality doesn't take care of this (now.) case parseURIAuthority auth of- Just x -> return x + Just x -> return x Nothing -> fail $ "Network.HTTP.Base.getAuth: Error parsing URI authority '" ++ auth ++ "'"- where + where auth = maybe (uriToAuthorityString uri) id (findHeader HdrHost r) uri = rqURI r {-# DEPRECATED normalizeRequestURI "Please use Network.HTTP.Base.normalizeRequest instead" #-} normalizeRequestURI :: Bool{-do close-} -> {-URI-}String -> Request ty -> Request ty-normalizeRequestURI doClose h r = +normalizeRequestURI doClose h r = (if doClose then replaceHeader HdrConnection "close" else id) $ insertHeaderIfMissing HdrHost h $ r { rqURI = (rqURI r){ uriScheme = "" , uriAuthority = Nothing- }}+ }} -- | @NormalizeRequestOptions@ brings together the various defaulting\/normalization options -- over 'Request's. Use 'defaultNormalizeRequestOptions' for the standard selection of option@@ -750,72 +767,90 @@ -- via the @NormalizeRequestOptions@ record. normalizeRequest :: NormalizeRequestOptions ty -> Request ty- -> Request ty+ -> Request ty normalizeRequest opts req = foldr (\ f -> f opts) req normalizers where --normalizers :: [RequestNormalizer ty]- normalizers = + normalizers = ( normalizeHostURI+ : normalizeBasicAuth : normalizeConnectionClose- : normalizeUserAgent + : normalizeUserAgent : normCustoms opts ) --- | @normalizeUserAgent ua x req@ augments the request @req@ with --- a @User-Agent: ua@ header if @req@ doesn't already have a +-- | @normalizeUserAgent ua x req@ augments the request @req@ with+-- a @User-Agent: ua@ header if @req@ doesn't already have a -- a @User-Agent:@ set. normalizeUserAgent :: RequestNormalizer ty-normalizeUserAgent opts req = +normalizeUserAgent opts req = case normUserAgent opts of Nothing -> req- Just ua -> + Just ua -> case findHeader HdrUserAgent req of Just u | u /= defaultUserAgent -> req _ -> replaceHeader HdrUserAgent ua req --- | @normalizeConnectionClose opts req@ sets the header @Connection: close@ +-- | @normalizeConnectionClose opts req@ sets the header @Connection: close@ -- to indicate one-shot behavior iff @normDoClose@ is @True@. i.e., it then -- _replaces_ any an existing @Connection:@ header in @req@. normalizeConnectionClose :: RequestNormalizer ty-normalizeConnectionClose opts req +normalizeConnectionClose opts req | normDoClose opts = replaceHeader HdrConnection "close" req | otherwise = req +-- | @normalizeBasicAuth opts req@ sets the header @Authorization: Basic...@+-- if the "user:pass@" part is present in the "http://user:pass@host/path"+-- of the URI. If Authorization header was present already it is not replaced.+normalizeBasicAuth :: RequestNormalizer ty+normalizeBasicAuth _ req =+ case getAuth req of+ Just uriauth ->+ case (user uriauth, password uriauth) of+ (Just u, Just p) ->+ insertHeaderIfMissing HdrAuthorization astr req+ where+ astr = "Basic " ++ base64encode (u ++ ":" ++ p)+ base64encode = Base64.encode . stringToOctets :: String -> String+ stringToOctets = map (fromIntegral . fromEnum) :: String -> [Word8]+ (_, _) -> req+ Nothing ->req+ -- | @normalizeHostURI forProxy req@ rewrites your request to have it -- follow the expected formats by the receiving party (proxy or server.)--- +-- normalizeHostURI :: RequestNormalizer ty-normalizeHostURI opts req = +normalizeHostURI opts req = case splitRequestURI uri of ("",_uri_abs)- | forProxy -> + | forProxy -> case findHeader HdrHost req of- Nothing -> req -- no host/authority in sight..not much we can do.- Just h -> req{rqURI=uri{ uriAuthority=Just URIAuth{uriUserInfo="", uriRegName=hst, uriPort=pNum}- , uriScheme=if (null (uriScheme uri)) then "http" else uriScheme uri- }}- where - hst = case span (/='@') user_hst of- (as,'@':bs) -> - case span (/=':') as of- (_,_:_) -> bs- _ -> user_hst- _ -> user_hst+ Nothing -> req -- no host/authority in sight..not much we can do.+ Just h -> req{rqURI=uri{ uriAuthority=Just URIAuth{uriUserInfo="", uriRegName=hst, uriPort=pNum}+ , uriScheme=if (null (uriScheme uri)) then "http" else uriScheme uri+ }}+ where+ hst = case span (/='@') user_hst of+ (as,'@':bs) ->+ case span (/=':') as of+ (_,_:_) -> bs+ _ -> user_hst+ _ -> user_hst - (user_hst, pNum) = - case span isDigit (reverse h) of- (ds,':':bs) -> (reverse bs, ':':reverse ds)- _ -> (h,"")- | otherwise -> + (user_hst, pNum) =+ case span isDigit (reverse h) of+ (ds,':':bs) -> (reverse bs, ':':reverse ds)+ _ -> (h,"")+ | otherwise -> case findHeader HdrHost req of- Nothing -> req -- no host/authority in sight..not much we can do...complain?- Just{} -> req- (h,uri_abs) - | forProxy -> insertHeaderIfMissing HdrHost h req + Nothing -> req -- no host/authority in sight..not much we can do...complain?+ Just{} -> req+ (h,uri_abs)+ | forProxy -> insertHeaderIfMissing HdrHost h req | otherwise -> replaceHeader HdrHost h req{rqURI=uri_abs} -- Note: _not_ stubbing out user:pass where- uri0 = rqURI req - -- stub out the user:pass + uri0 = rqURI req+ -- stub out the user:pass uri = uri0{uriAuthority=fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri0)} forProxy = normForProxy opts@@ -826,7 +861,7 @@ resource on an origin server or gateway. In this case the absolute path of the URI MUST be transmitted (see section 3.2.1, abs_path) as the Request-URI, and the network location of the URI (authority) MUST- be transmitted in a Host header field." + be transmitted in a Host header field." We assume that this is the case, so we take the host name from the Host header if there is one, otherwise from the request-URI. Then we make the request-URI an abs_path and make sure that there@@ -839,18 +874,18 @@ -- Adds a Host header if one is NOT ALREADY PRESENT.. {-# DEPRECATED normalizeHostHeader "Please use Network.HTTP.Base.normalizeRequest instead" #-} normalizeHostHeader :: Request ty -> Request ty-normalizeHostHeader rq = +normalizeHostHeader rq = insertHeaderIfMissing HdrHost (uriToAuthorityString $ rqURI rq)- rq- + rq+ -- Looks for a "Connection" header with the value "close". -- Returns True when this is found. findConnClose :: [Header] -> Bool findConnClose hdrs = maybe False (\ x -> map toLower (trim x) == "close")- (lookupHeader HdrConnection hdrs)+ (lookupHeader HdrConnection hdrs) -- | Used when we know exactly how many bytes to expect. linearTransfer :: (Int -> IO (Result a)) -> Int -> IO (Result ([Header],a))@@ -862,10 +897,10 @@ -- take data once and give up the rest. hopefulTransfer :: BufferOp a -> IO (Result a)- -> [a]- -> IO (Result ([Header],a))-hopefulTransfer bufOps readL strs - = readL >>= + -> [a]+ -> IO (Result ([Header],a))+hopefulTransfer bufOps readL strs+ = readL >>= either (\v -> return $ Left v) (\more -> if (buf_isEmpty bufOps more) then return (Right ([], buf_concat bufOps $ reverse strs))@@ -875,7 +910,7 @@ -- Also the only transfer variety likely to -- return any footers. chunkedTransfer :: BufferOp a- -> IO (Result a)+ -> IO (Result a) -> (Int -> IO (Result a)) -> IO (Result ([Header], a)) chunkedTransfer bufOps readL readBlk = chunkedTransferC bufOps readL readBlk [] 0@@ -883,36 +918,36 @@ chunkedTransferC :: BufferOp a -> IO (Result a) -> (Int -> IO (Result a))- -> [a]- -> Int- -> IO (Result ([Header], a))+ -> [a]+ -> Int+ -> IO (Result ([Header], a)) chunkedTransferC bufOps readL readBlk acc n = do v <- readL case v of Left e -> return (Left e)- Right line - | size == 0 -> + Right line+ | size == 0 -> -- last chunk read; look for trailing headers.. fmapE (\ strs -> do- ftrs <- parseHeaders (map (buf_toStr bufOps) strs)- -- insert (computed) Content-Length header.- let ftrs' = Header HdrContentLength (show n) : ftrs+ ftrs <- parseHeaders (map (buf_toStr bufOps) strs)+ -- insert (computed) Content-Length header.+ let ftrs' = Header HdrContentLength (show n) : ftrs return (ftrs',buf_concat bufOps (reverse acc))) - (readTillEmpty2 bufOps readL [])+ (readTillEmpty2 bufOps readL []) | otherwise -> do some <- readBlk size- case some of- Left e -> return (Left e)- Right cdata -> do- _ <- readL -- CRLF is mandated after the chunk block; ToDo: check that the line is empty.?- chunkedTransferC bufOps readL readBlk (cdata:acc) (n+size)+ case some of+ Left e -> return (Left e)+ Right cdata -> do+ _ <- readL -- CRLF is mandated after the chunk block; ToDo: check that the line is empty.?+ chunkedTransferC bufOps readL readBlk (cdata:acc) (n+size) where- size + size | buf_isEmpty bufOps line = 0- | otherwise = - case readHex (buf_toStr bufOps line) of+ | otherwise =+ case readHex (buf_toStr bufOps line) of (hx,_):_ -> hx _ -> 0 @@ -924,13 +959,13 @@ -- | Remove leading crlfs then call readTillEmpty2 (not required by RFC) readTillEmpty1 :: BufferOp a- -> IO (Result a)+ -> IO (Result a) -> IO (Result [a]) readTillEmpty1 bufOps readL = readL >>= either (return . Left)- (\ s -> - if buf_isLineTerm bufOps s+ (\ s ->+ if buf_isLineTerm bufOps s then readTillEmpty1 bufOps readL else readTillEmpty2 bufOps readL [s]) @@ -940,14 +975,14 @@ -- thing to do - so probably indicates an -- error condition. readTillEmpty2 :: BufferOp a- -> IO (Result a)- -> [a]- -> IO (Result [a])+ -> IO (Result a)+ -> [a]+ -> IO (Result [a]) readTillEmpty2 bufOps readL list = readL >>= either (return . Left) (\ s ->- if buf_isLineTerm bufOps s || buf_isEmpty bufOps s+ if buf_isLineTerm bufOps s || buf_isEmpty bufOps s then return (Right $ reverse (s:list)) else readTillEmpty2 bufOps readL (s:list))
Network/HTTP/Base64.hs view
@@ -8,8 +8,8 @@ -- Stability : experimental -- Portability : portable ----- Base64 encoding and decoding functions provided by Warwick Gray. --- See <http://homepages.paradise.net.nz/warrickg/haskell/http/#base64> +-- Base64 encoding and decoding functions provided by Warwick Gray.+-- See <http://homepages.paradise.net.nz/warrickg/haskell/http/#base64> -- and <http://www.faqs.org/rfcs/rfc2045.html>. -- -----------------------------------------------------------------------------@@ -148,8 +148,8 @@ MIME applications might be undesireable. -But: The Haskell98 Char type is at least 16bits (and often 32), these implementations assume only - 8 significant bits, which is more than enough for US-ASCII. +But: The Haskell98 Char type is at least 16bits (and often 32), these implementations assume only+ 8 significant bits, which is more than enough for US-ASCII. -} @@ -161,9 +161,9 @@ type Octet = Word8 encodeArray :: Array Int Char-encodeArray = array (0,64) - [ (0,'A'), (1,'B'), (2,'C'), (3,'D'), (4,'E'), (5,'F') - , (6,'G'), (7,'H'), (8,'I'), (9,'J'), (10,'K'), (11,'L') +encodeArray = array (0,64)+ [ (0,'A'), (1,'B'), (2,'C'), (3,'D'), (4,'E'), (5,'F')+ , (6,'G'), (7,'H'), (8,'I'), (9,'J'), (10,'K'), (11,'L') , (12,'M'), (13,'N'), (14,'O'), (15,'P'), (16,'Q'), (17,'R') , (18,'S'), (19,'T'), (20,'U'), (21,'V'), (22,'W'), (23,'X') , (24,'Y'), (25,'Z'), (26,'a'), (27,'b'), (28,'c'), (29,'d')@@ -177,11 +177,11 @@ -- Convert between 4 base64 (6bits ea) integers and 1 ordinary integer (32 bits) -- clearly the upmost/leftmost 8 bits of the answer are 0.--- Hack Alert: In the last entry of the answer, the upper 8 bits encode +-- Hack Alert: In the last entry of the answer, the upper 8 bits encode -- the integer number of 6bit groups encoded in that integer, ie 1, 2, 3. -- 0 represents a 4 :( int4_char3 :: [Int] -> [Char]-int4_char3 (a:b:c:d:t) = +int4_char3 (a:b:c:d:t) = let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6 .|. d) in (chr (n `shiftR` 16 .&. 0xff)) : (chr (n `shiftR` 8 .&. 0xff))@@ -192,7 +192,7 @@ in [ (chr (n `shiftR` 16 .&. 0xff)) , (chr (n `shiftR` 8 .&. 0xff)) ] -int4_char3 [a,b] = +int4_char3 [a,b] = let n = (a `shiftL` 18 .|. b `shiftL` 12) in [ (chr (n `shiftR` 16 .&. 0xff)) ] @@ -209,7 +209,7 @@ -- a trailing 2 character group gives 3 integers, -- while a trailing single character gives 2 integers. char3_int4 :: [Char] -> [Int]-char3_int4 (a:b:c:t) +char3_int4 (a:b:c:t) = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8 .|. ord c) in (n `shiftR` 18 .&. 0x3f) : (n `shiftR` 12 .&. 0x3f) : (n `shiftR` 6 .&. 0x3f) : (n .&. 0x3f) : char3_int4 t @@ -218,7 +218,7 @@ in [ (n `shiftR` 18 .&. 0x3f) , (n `shiftR` 12 .&. 0x3f) , (n `shiftR` 6 .&. 0x3f) ]- + char3_int4 [a] = let n = (ord a `shiftL` 16) in [(n `shiftR` 18 .&. 0x3f),(n `shiftR` 12 .&. 0x3f)]
Network/HTTP/Cookie.hs view
@@ -3,14 +3,14 @@ -- Module : Network.HTTP.Cookie -- Copyright : See LICENSE file -- License : BSD--- --- Maintainer : Ganesh Sittampalam <http@projects.haskell.org>+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) -- -- This module provides the data types and functions for working with HTTP cookies. -- Right now, it contains mostly functionality needed by 'Network.Browser'.--- +-- ----------------------------------------------------------------------------- module Network.HTTP.Cookie ( Cookie(..)@@ -38,8 +38,8 @@ -- | @Cookie@ is the Haskell representation of HTTP cookie values. -- See its relevant specs for authoritative details.-data Cookie - = MkCookie +data Cookie+ = MkCookie { ckDomain :: String , ckName :: String , ckValue :: String@@ -50,8 +50,8 @@ deriving(Show,Read) instance Eq Cookie where- a == b = ckDomain a == ckDomain b - && ckName a == ckName b + a == b = ckDomain a == ckDomain b+ && ckName a == ckName b && ckPath a == ckPath b -- | @cookieToHeaders ck@ serialises @Cookie@s to an HTTP request header.@@ -66,7 +66,7 @@ mkCookieHeaderValue1 c = ckName c ++ "=" ++ ckValue c -- | @cookieMatch (domain,path) ck@ performs the standard cookie--- match wrt the given domain and path. +-- match wrt the given domain and path. cookieMatch :: (String, String) -> Cookie -> Bool cookieMatch (dom,path) ck = ckDomain ck `isSuffixOf` dom &&@@ -75,13 +75,13 @@ Just p -> p `isPrefixOf` path --- | @processCookieHeaders dom hdrs@ +-- | @processCookieHeaders dom hdrs@ processCookieHeaders :: String -> [Header] -> ([String], [Cookie]) processCookieHeaders dom hdrs = foldr (headerToCookies dom) ([],[]) hdrs --- | @headerToCookies dom hdr acc@ +-- | @headerToCookies dom hdr acc@ headerToCookies :: String -> Header -> ([String], [Cookie]) -> ([String], [Cookie])-headerToCookies dom (Header HdrSetCookie val) (accErr, accCookie) = +headerToCookies dom (Header HdrSetCookie val) (accErr, accCookie) = case parse cookies "" val of Left{} -> (val:accErr, accCookie) Right x -> (accErr, x ++ accCookie)@@ -100,11 +100,11 @@ return $ mkCookie name val1 args cvalue :: Parser String- + spaces_l = many (satisfy isSpace) cvalue = quotedstring <|> many1 (satisfy $ not . (==';')) <|> return ""- + -- all keys in the result list MUST be in lower case cdetail :: Parser [(String,String)] cdetail = many $@@ -118,8 +118,8 @@ ) mkCookie :: String -> String -> [(String,String)] -> Cookie- mkCookie nm cval more = - MkCookie { ckName = nm+ mkCookie nm cval more =+ MkCookie { ckName = nm , ckValue = cval , ckDomain = map toLower (fromMaybe dom (lookup "domain" more)) , ckPath = lookup "path" more@@ -128,7 +128,7 @@ } headerToCookies _ _ acc = acc - + word, quotedstring :: Parser String
Network/HTTP/HandleStream.hs view
@@ -3,8 +3,8 @@ -- Module : Network.HTTP.HandleStream -- Copyright : See LICENSE file -- License : BSD--- --- Maintainer : Ganesh Sittampalam <http@projects.haskell.org>+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) --@@ -15,16 +15,16 @@ -- not perform any kind of normalization prior to transmission (or receipt); you are -- responsible for doing any such yourself, or, if you prefer, just switch to using -- "Network.HTTP" function instead.--- +-- ------------------------------------------------------------------------------module Network.HTTP.HandleStream +module Network.HTTP.HandleStream ( simpleHTTP -- :: Request ty -> IO (Result (Response ty)) , simpleHTTP_ -- :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) , sendHTTP -- :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) , sendHTTP_notify -- :: HStream ty => HandleStream ty -> Request ty -> IO () -> IO (Result (Response ty)) , receiveHTTP -- :: HStream ty => HandleStream ty -> IO (Result (Request ty)) , respondHTTP -- :: HStream ty => HandleStream ty -> Response ty -> IO ()- + , simpleHTTP_debug -- :: FilePath -> Request DebugString -> IO (Response DebugString) ) where @@ -52,7 +52,7 @@ -- | @simpleHTTP@ transmits a resource across a non-persistent connection. simpleHTTP :: HStream ty => Request ty -> IO (Result (Response ty))-simpleHTTP r = do +simpleHTTP r = do auth <- getAuth r failHTTPS (rqURI r) c <- openStream (host auth) (fromMaybe 80 (port auth))@@ -61,7 +61,7 @@ -- | @simpleHTTP_debug debugFile req@ behaves like 'simpleHTTP', but logs -- the HTTP operation via the debug file @debugFile@. simpleHTTP_debug :: HStream ty => FilePath -> Request ty -> IO (Result (Response ty))-simpleHTTP_debug httpLogFile r = do +simpleHTTP_debug httpLogFile r = do auth <- getAuth r failHTTPS (rqURI r) c0 <- openStream (host auth) (fromMaybe 80 (port auth))@@ -84,9 +84,9 @@ -- request transmission and its performance. sendHTTP_notify :: HStream ty => HandleStream ty- -> Request ty- -> IO ()- -> IO (Result (Response ty))+ -> Request ty+ -> IO ()+ -> IO (Result (Response ty)) sendHTTP_notify conn rq onSendComplete = do when providedClose $ (closeOnEnd conn True) onException (sendMain conn rq onSendComplete)@@ -106,9 +106,9 @@ -- Since we would wait forever, I have disabled use of 100-continue for now. sendMain :: HStream ty => HandleStream ty- -> Request ty- -> (IO ())- -> IO (Result (Response ty))+ -> Request ty+ -> (IO ())+ -> IO (Result (Response ty)) sendMain conn rqst onSendComplete = do --let str = if null (rqBody rqst) -- then show rqst@@ -128,7 +128,7 @@ switchResponse :: HStream ty => HandleStream ty- -> Bool {- allow retry? -}+ -> Bool {- allow retry? -} -> Bool {- is body sent? -} -> Result ResponseData -> Request ty@@ -138,12 +138,12 @@ -- if we attempt to use the same socket then there is an excellent -- chance that the socket is not in a completely closed state. -switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = +switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = case matchResponse (rqMethod rqst) cd of Continue | not bdy_sent -> do {- Time to send the body -} writeBlock conn (rqBody rqst) >>= either (return . Left)- (\ _ -> do+ (\ _ -> do rsp <- getResponseHead conn switchResponse conn allow_retry True rsp rqst) | otherwise -> do {- keep waiting -}@@ -155,11 +155,11 @@ other than "100-Continue" -} -- TODO review throwing away of result _ <- writeBlock conn ((buf_append bufferOps)- (buf_fromStr bufferOps (show rqst))- (rqBody rqst))+ (buf_fromStr bufferOps (show rqst))+ (rqBody rqst)) rsp <- getResponseHead conn switchResponse conn False bdy_sent rsp rqst- + Done -> do when (findConnClose hdrs) (closeOnEnd conn True)@@ -171,31 +171,31 @@ ExpectEntity -> do r <- fmapE (\ (ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy)) $ maybe (maybe (hopefulTransfer bo (readLine conn) [])- (\ x -> - readsOne (linearTransfer (readBlock conn))- (return$responseParseError "unrecognized content-length value" x)- x)- cl)- (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn))- (uglyDeathTransfer "sendHTTP"))+ (\ x ->+ readsOne (linearTransfer (readBlock conn))+ (return$responseParseError "unrecognized content-length value" x)+ x)+ cl)+ (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn))+ (uglyDeathTransfer "sendHTTP")) tc case r of Left{} -> do- close conn- return r- Right (Response _ _ hs _) -> do- when (findConnClose hs)+ close conn+ return r+ Right (Response _ _ hs _) -> do+ when (findConnClose hs) (closeOnEnd conn True)- return r+ return r where tc = lookupHeader HdrTransferEncoding hdrs cl = lookupHeader HdrContentLength hdrs bo = bufferOps- + -- reads and parses headers getResponseHead :: HStream ty => HandleStream ty -> IO (Result ResponseData)-getResponseHead conn = +getResponseHead conn = fmapE (\es -> parseResponseHead (map (buf_toStr bufferOps) es)) (readTillEmpty1 bufferOps (readLine conn)) @@ -208,18 +208,18 @@ getRequestHead = do fmapE (\es -> parseRequestHead (map (buf_toStr bufferOps) es)) (readTillEmpty1 bufferOps (readLine conn))- + processRequest (rm,uri,hdrs) = fmapE (\ (ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy)) $- maybe - (maybe (return (Right ([], buf_empty bo))) -- hopefulTransfer ""- (\ x -> readsOne (linearTransfer (readBlock conn))- (return$responseParseError "unrecognized Content-Length value" x)- x)- - cl)- (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn))- (uglyDeathTransfer "receiveHTTP"))+ maybe+ (maybe (return (Right ([], buf_empty bo))) -- hopefulTransfer ""+ (\ x -> readsOne (linearTransfer (readBlock conn))+ (return$responseParseError "unrecognized Content-Length value" x)+ x)++ cl)+ (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn))+ (uglyDeathTransfer "receiveHTTP")) tc where -- FIXME : Also handle 100-continue.@@ -231,7 +231,7 @@ -- the 'HandleStream' @hStream@. It could be used to implement simple web -- server interactions, performing the dual role to 'sendHTTP'. respondHTTP :: HStream ty => HandleStream ty -> Response ty -> IO ()-respondHTTP conn rsp = do +respondHTTP conn rsp = do -- TODO: review throwing away of result _ <- writeBlock conn (buf_fromStr bufferOps $ show rsp) -- write body immediately, don't wait for 100 CONTINUE@@ -245,7 +245,7 @@ headerName x = map toLower (trim x) ifChunked :: a -> a -> String -> a-ifChunked a b s = +ifChunked a b s = case headerName s of "chunked" -> a _ -> b
Network/HTTP/Headers.hs view
@@ -3,8 +3,8 @@ -- Module : Network.HTTP.Headers -- Copyright : See LICENSE file -- License : BSD--- --- Maintainer : Ganesh Sittampalam <http@projects.haskell.org>+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) --@@ -13,7 +13,7 @@ -- header values in 'Request's and 'Response's. To avoid having to provide -- separate set of operations for doing so, we introduce a type class 'HasHeaders' -- to facilitate writing such processing using overloading instead.--- +-- ----------------------------------------------------------------------------- module Network.HTTP.Headers ( HasHeaders(..) -- type class@@ -35,9 +35,9 @@ , parseHeader -- :: parseHeader :: String -> Result Header , parseHeaders -- :: [String] -> Result [Header]- + , headerMap -- :: [(String, HeaderName)]- + , HeaderSetter ) where @@ -70,15 +70,15 @@ -- Encoding HTTP header names differently, as Strings perhaps, is an -- equally fine choice..no decidedly clear winner, but let's stick -- with data constructors here.--- -data HeaderName +--+data HeaderName -- Generic Headers -- = HdrCacheControl | HdrConnection | HdrDate | HdrPragma- | HdrTransferEncoding - | HdrUpgrade + | HdrTransferEncoding+ | HdrUpgrade | HdrVia -- Request Headers -- | HdrAccept@@ -130,9 +130,164 @@ | HdrContentTransferEncoding -- | Allows for unrecognised or experimental headers. | HdrCustom String -- not in header map below.- deriving(Eq) --- | @headerMap@ is a straight assoc list for translating between header names +instance Eq HeaderName where+ HdrCustom a == HdrCustom b = (fmap toLower a) == (fmap toLower b)+ HdrCacheControl == HdrCacheControl = True+ HdrCacheControl == _ = False+ _ == HdrCacheControl = False+ HdrConnection == HdrConnection = True+ HdrConnection == _ = False+ _ == HdrConnection = False+ HdrDate == HdrDate = True+ HdrDate == _ = False+ _ == HdrDate = False+ HdrPragma == HdrPragma = True+ HdrPragma == _ = False+ _ == HdrPragma = False+ HdrTransferEncoding == HdrTransferEncoding = True+ HdrTransferEncoding == _ = False+ _ == HdrTransferEncoding = False+ HdrUpgrade == HdrUpgrade = True+ HdrUpgrade == _ = False+ _ == HdrUpgrade = False+ HdrVia == HdrVia = True+ HdrVia == _ = False+ _ == HdrVia = False+ HdrAccept == HdrAccept = True+ HdrAccept == _ = False+ _ == HdrAccept = False+ HdrAcceptCharset == HdrAcceptCharset = True+ HdrAcceptCharset == _ = False+ _ == HdrAcceptCharset = False+ HdrAcceptEncoding == HdrAcceptEncoding = True+ HdrAcceptEncoding == _ = False+ _ == HdrAcceptEncoding = False+ HdrAcceptLanguage == HdrAcceptLanguage = True+ HdrAcceptLanguage == _ = False+ _ == HdrAcceptLanguage = False+ HdrAuthorization == HdrAuthorization = True+ HdrAuthorization == _ = False+ _ == HdrAuthorization = False+ HdrCookie == HdrCookie = True+ HdrCookie == _ = False+ _ == HdrCookie = False+ HdrExpect == HdrExpect = True+ HdrExpect == _ = False+ _ == HdrExpect = False+ HdrFrom == HdrFrom = True+ HdrFrom == _ = False+ _ == HdrFrom = False+ HdrHost == HdrHost = True+ HdrHost == _ = False+ _ == HdrHost = False+ HdrIfModifiedSince == HdrIfModifiedSince = True+ HdrIfModifiedSince == _ = False+ _ == HdrIfModifiedSince = False+ HdrIfMatch == HdrIfMatch = True+ HdrIfMatch == _ = False+ _ == HdrIfMatch = False+ HdrIfNoneMatch == HdrIfNoneMatch = True+ HdrIfNoneMatch == _ = False+ _ == HdrIfNoneMatch = False+ HdrIfRange == HdrIfRange = True+ HdrIfRange == _ = False+ _ == HdrIfRange = False+ HdrIfUnmodifiedSince == HdrIfUnmodifiedSince = True+ HdrIfUnmodifiedSince == _ = False+ _ == HdrIfUnmodifiedSince = False+ HdrMaxForwards == HdrMaxForwards = True+ HdrMaxForwards == _ = False+ _ == HdrMaxForwards = False+ HdrProxyAuthorization == HdrProxyAuthorization = True+ HdrProxyAuthorization == _ = False+ _ == HdrProxyAuthorization = False+ HdrRange == HdrRange = True+ HdrRange == _ = False+ _ == HdrRange = False+ HdrReferer == HdrReferer = True+ HdrReferer == _ = False+ _ == HdrReferer = False+ HdrUserAgent == HdrUserAgent = True+ HdrUserAgent == _ = False+ _ == HdrUserAgent = False+ HdrAge == HdrAge = True+ HdrAge == _ = False+ _ == HdrAge = False+ HdrLocation == HdrLocation = True+ HdrLocation == _ = False+ _ == HdrLocation = False+ HdrProxyAuthenticate == HdrProxyAuthenticate = True+ HdrProxyAuthenticate == _ = False+ _ == HdrProxyAuthenticate = False+ HdrPublic == HdrPublic = True+ HdrPublic == _ = False+ _ == HdrPublic = False+ HdrRetryAfter == HdrRetryAfter = True+ HdrRetryAfter == _ = False+ _ == HdrRetryAfter = False+ HdrServer == HdrServer = True+ HdrServer == _ = False+ _ == HdrServer = False+ HdrSetCookie == HdrSetCookie = True+ HdrSetCookie == _ = False+ _ == HdrSetCookie = False+ HdrTE == HdrTE = True+ HdrTE == _ = False+ _ == HdrTE = False+ HdrTrailer == HdrTrailer = True+ HdrTrailer == _ = False+ _ == HdrTrailer = False+ HdrVary == HdrVary = True+ HdrVary == _ = False+ _ == HdrVary = False+ HdrWarning == HdrWarning = True+ HdrWarning == _ = False+ _ == HdrWarning = False+ HdrWWWAuthenticate == HdrWWWAuthenticate = True+ HdrWWWAuthenticate == _ = False+ _ == HdrWWWAuthenticate = False+ HdrAllow == HdrAllow = True+ HdrAllow == _ = False+ _ == HdrAllow = False+ HdrContentBase == HdrContentBase = True+ HdrContentBase == _ = False+ _ == HdrContentBase = False+ HdrContentEncoding == HdrContentEncoding = True+ HdrContentEncoding == _ = False+ _ == HdrContentEncoding = False+ HdrContentLanguage == HdrContentLanguage = True+ HdrContentLanguage == _ = False+ _ == HdrContentLanguage = False+ HdrContentLength == HdrContentLength = True+ HdrContentLength == _ = False+ _ == HdrContentLength = False+ HdrContentLocation == HdrContentLocation = True+ HdrContentLocation == _ = False+ _ == HdrContentLocation = False+ HdrContentMD5 == HdrContentMD5 = True+ HdrContentMD5 == _ = False+ _ == HdrContentMD5 = False+ HdrContentRange == HdrContentRange = True+ HdrContentRange == _ = False+ _ == HdrContentRange = False+ HdrContentType == HdrContentType = True+ HdrContentType == _ = False+ _ == HdrContentType = False+ HdrETag == HdrETag = True+ HdrETag == _ = False+ _ == HdrETag = False+ HdrExpires == HdrExpires = True+ HdrExpires == _ = False+ _ == HdrExpires = False+ HdrLastModified == HdrLastModified = True+ HdrLastModified == _ = False+ _ == HdrLastModified = False+ HdrContentTransferEncoding == HdrContentTransferEncoding = True+ HdrContentTransferEncoding == _ = False+ _ == HdrContentTransferEncoding = False++-- | @headerMap@ is a straight assoc list for translating between header names -- and values. headerMap :: [ (String,HeaderName) ] headerMap =@@ -227,12 +382,12 @@ newHeaders [] = [Header name value] -- | @replaceHeader hdr val o@ replaces the header @hdr@ with the--- value @val@, dropping any existing +-- value @val@, dropping any existing replaceHeader :: HasHeaders a => HeaderSetter a replaceHeader name value h = setHeaders h newHeaders where newHeaders = Header name value : [ x | x@(Header n _) <- getHeaders h, name /= n ]- + -- | @insertHeaders hdrs x@ appends multiple headers to @x@'s existing -- set. insertHeaders :: HasHeaders a => [Header] -> a -> a@@ -242,7 +397,7 @@ retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header] retrieveHeaders name x = filter matchname (getHeaders x) where- matchname (Header n _) = n == name + matchname (Header n _) = n == name -- | @findHeader hdrNm x@ looks up @hdrNm@ in @x@, returning the first -- header that matches, if any.@@ -253,7 +408,7 @@ -- list @hdrs@. lookupHeader :: HeaderName -> [Header] -> Maybe String lookupHeader _ [] = Nothing-lookupHeader v (Header n s:t) +lookupHeader v (Header n s:t) | v == n = Just s | otherwise = lookupHeader v t @@ -271,26 +426,26 @@ match :: String -> String -> Bool match s1 s2 = map toLower s1 == map toLower s2- + -- | @parseHeaders hdrs@ takes a sequence of strings holding header -- information and parses them into a set of headers (preserving their -- order in the input argument.) Handles header values split up over -- multiple lines. parseHeaders :: [String] -> Result [Header]-parseHeaders = catRslts [] . - map (parseHeader . clean) . - joinExtended ""+parseHeaders = catRslts [] .+ map (parseHeader . clean) .+ joinExtended "" where -- Joins consecutive lines where the second line -- begins with ' ' or '\t'. joinExtended old [] = [old] joinExtended old (h : t)- | isLineExtension h = joinExtended (old ++ ' ' : tail h) t+ | isLineExtension h = joinExtended (old ++ ' ' : tail h) t | otherwise = old : joinExtended h t- - isLineExtension (x:_) = x == ' ' || x == '\t'- isLineExtension _ = False + isLineExtension (x:_) = x == ' ' || x == '\t'+ isLineExtension _ = False+ clean [] = [] clean (h:t) | h `elem` "\t\r\n" = ' ' : clean t | otherwise = h : clean t@@ -299,8 +454,8 @@ -- errors here be reported or ignored? -- currently ignored. catRslts :: [a] -> [Result a] -> Result [a]- catRslts list (h:t) = + catRslts list (h:t) = case h of Left _ -> catRslts list t Right v -> catRslts (v:list) t- catRslts list [] = Right $ reverse list + catRslts list [] = Right $ reverse list
Network/HTTP/MD5Aux.hs view
@@ -1,6 +1,6 @@-module Network.HTTP.MD5Aux +module Network.HTTP.MD5Aux (md5, md5s, md5i,- MD5(..), ABCD(..), + MD5(..), ABCD(..), Zord64, Str(..), BoolList(..), WordList(..)) where import Data.Char (ord, chr)@@ -91,6 +91,7 @@ instance Num ABCD where ABCD (a1, b1, c1, d1) + ABCD (a2, b2, c2, d2) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2) + (-) = error "(-){ABCD}: no instance method defined" (*) = error "(*){ABCD}: no instance method defined" signum = error "signum{ABCD}: no instance method defined" fromInteger = error "fromInteger{ABCD}: no instance method defined"@@ -105,7 +106,7 @@ md5 m = md5_main False 0 magic_numbers m --- Returns a hex number ala the md5sum program+-- Returns a hex number à la md5sum program md5s :: (MD5 a) => a -> String md5s = abcd_to_string . md5
Network/HTTP/Proxy.hs view
@@ -4,13 +4,13 @@ -- Module : Network.HTTP.Proxy -- Copyright : See LICENSE file -- License : BSD--- --- Maintainer : Ganesh Sittampalam <http@projects.haskell.org>+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) -- -- Handling proxy server settings and their resolution.--- +-- ----------------------------------------------------------------------------- module Network.HTTP.Proxy ( Proxy(..)@@ -19,9 +19,19 @@ , parseProxy -- :: String -> Maybe Proxy ) where -import Control.Monad ( when, mplus, join, liftM2)+{-+#if !defined(WIN32) && defined(mingw32_HOST_OS)+#define WIN32 1+#endif+-} +import Control.Monad ( when, mplus, join, liftM2 )++#if defined(WIN32) import Network.HTTP.Base ( catchIO )+import Control.Monad ( liftM )+import Data.List ( isPrefixOf )+#endif import Network.HTTP.Utils ( dropWhileTail, chopAtDelim ) import Network.HTTP.Auth import Network.URI@@ -37,14 +47,20 @@ #if defined(WIN32) import System.Win32.Types ( DWORD, HKEY )-import System.Win32.Registry( hKEY_CURRENT_USER, regOpenKey, regCloseKey, regQueryValue, regQueryValueEx )+import System.Win32.Registry( hKEY_CURRENT_USER, regOpenKey, regCloseKey, regQueryValueEx ) import Control.Exception ( bracket ) import Foreign ( toBool, Storable(peek, sizeOf), castPtr, alloca )++#if MIN_VERSION_Win32(2,8,0)+import System.Win32.Registry( regQueryDefaultValue )+#else+import System.Win32.Registry( regQueryValue ) #endif+#endif -- | HTTP proxies (or not) are represented via 'Proxy', specifying if a -- proxy should be used for the request (see 'Network.Browser.setProxy')-data Proxy +data Proxy = NoProxy -- ^ Don't use a proxy. | Proxy String (Maybe Authority) -- ^ Use the proxy given. Should be of the@@ -67,16 +83,18 @@ -- Consults environment variable, and in case of Windows, by querying -- the Registry (cf. @registryProxyString@.) proxyString :: IO (Maybe String)-proxyString = liftM2 mplus envProxyString registryProxyString+proxyString = liftM2 mplus envProxyString windowsProxyString -registryProxyString :: IO (Maybe String)+windowsProxyString :: IO (Maybe String) #if !defined(WIN32)-registryProxyString = return Nothing+windowsProxyString = return Nothing #else+windowsProxyString = liftM (>>= parseWindowsProxy) registryProxyString+ registryProxyLoc :: (HKEY,String) registryProxyLoc = (hive, path) where- -- some sources say proxy settings should be at + -- some sources say proxy settings should be at -- HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows -- \CurrentVersion\Internet Settings\ProxyServer -- but if the user sets them with IE connection panel they seem to@@ -85,14 +103,49 @@ path = "Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings" -- read proxy settings from the windows registry; this is just a best--- effort and may not work on all setups. +-- effort and may not work on all setups.+registryProxyString :: IO (Maybe String) registryProxyString = catchIO (bracket (uncurry regOpenKey registryProxyLoc) regCloseKey $ \hkey -> do enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable" if enable+#if MIN_VERSION_Win32(2,8,0)+ then fmap Just $ regQueryDefaultValue hkey "ProxyServer"+#elif MIN_VERSION_Win32(2,6,0)+ then fmap Just $ regQueryValue hkey "ProxyServer"+#else then fmap Just $ regQueryValue hkey (Just "ProxyServer")+#endif else return Nothing) (\_ -> return Nothing)++-- the proxy string is in the format "http=x.x.x.x:yyyy;https=...;ftp=...;socks=..."+-- even though the following article indicates otherwise+-- https://support.microsoft.com/en-us/kb/819961+--+-- to be sure, parse strings where each entry in the ';'-separated list above is+-- either in the format "protocol=..." or "protocol://..."+--+-- only return the first "http" of them, if it exists+parseWindowsProxy :: String -> Maybe String+parseWindowsProxy s =+ case proxies of+ x:_ -> Just x+ _ -> Nothing+ where+ parts = split ';' s+ pr x = case break (== '=') x of+ (p, []) -> p -- might be in format http://+ (p, u) -> p ++ "://" ++ drop 1 u++ proxies = filter (isPrefixOf "http://") . map pr $ parts++ split :: Eq a => a -> [a] -> [[a]]+ split _ [] = []+ split a xs = case break (a ==) xs of+ (ys, []) -> [ys]+ (ys, _:zs) -> ys:split a zs+ #endif -- | @fetchProxy flg@ gets the local proxy settings and parse the string@@ -107,7 +160,7 @@ case mstr of Nothing -> return NoProxy Just str -> case parseProxy str of- Just p -> return p + Just p -> return p Nothing -> do when warnIfIllformed $ System.IO.hPutStrLn System.IO.stderr $ unlines [ "invalid http proxy uri: " ++ show str@@ -119,6 +172,7 @@ -- | @parseProxy str@ translates a proxy server string into a @Proxy@ value; -- returns @Nothing@ if not well-formed. parseProxy :: String -> Maybe Proxy+parseProxy "" = Nothing parseProxy str = join . fmap uri2proxy $ parseHttpURI str@@ -144,7 +198,7 @@ where f a@URIAuth{uriUserInfo=s} = a{uriUserInfo=dropWhileTail (=='@') s} --- +-- uri2proxy :: URI -> Maybe Proxy uri2proxy uri@URI{ uriScheme = "http:" , uriAuthority = Just (URIAuth auth' hst prt)@@ -156,7 +210,7 @@ [] -> Nothing as -> Just (AuthBasic "" (unEscapeString usr) (unEscapeString pwd) uri) where- (usr,pwd) = chopAtDelim ':' as+ (usr,pwd) = chopAtDelim ':' as uri2proxy _ = Nothing
Network/HTTP/Stream.hs view
@@ -3,8 +3,8 @@ -- Module : Network.HTTP.Stream -- Copyright : See LICENSE file -- License : BSD--- --- Maintainer : Ganesh Sittampalam <http@projects.haskell.org>+--+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) --@@ -20,9 +20,9 @@ -- not perform any kind of normalization prior to transmission (or receipt); you are -- responsible for doing any such yourself, or, if you prefer, just switch to using -- "Network.HTTP" function instead.--- +-- ------------------------------------------------------------------------------module Network.HTTP.Stream +module Network.HTTP.Stream ( module Network.Stream , simpleHTTP -- :: Request_String -> IO (Result Response_String)@@ -31,7 +31,7 @@ , sendHTTP_notify -- :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) , receiveHTTP -- :: Stream s => s -> IO (Result Request_String) , respondHTTP -- :: Stream s => s -> Response_String -> IO ()- + ) where -----------------------------------------------------------------@@ -68,7 +68,7 @@ -- | Simple way to transmit a resource across a non-persistent connection. simpleHTTP :: Request_String -> IO (Result Response_String)-simpleHTTP r = do +simpleHTTP r = do auth <- getAuth r c <- openTCPPort (host auth) (fromMaybe 80 (port auth)) simpleHTTP_ c r@@ -103,7 +103,7 @@ -- -- Since we would wait forever, I have disabled use of 100-continue for now. sendMain :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String)-sendMain conn rqst onSendComplete = do +sendMain conn rqst onSendComplete = do --let str = if null (rqBody rqst) -- then show rqst -- else show (insertHeader HdrExpect "100-continue" rqst)@@ -115,7 +115,7 @@ onSendComplete rsp <- getResponseHead conn switchResponse conn True False rsp rqst- + -- reads and parses headers getResponseHead :: Stream s => s -> IO (Result ResponseData) getResponseHead conn = do@@ -127,7 +127,7 @@ -- to the RFC. switchResponse :: Stream s => s- -> Bool {- allow retry? -}+ -> Bool {- allow retry? -} -> Bool {- is body sent? -} -> Result ResponseData -> Request_String@@ -150,7 +150,7 @@ } | otherwise -> {- keep waiting -} do { rsp <- getResponseHead conn- ; switchResponse conn allow_retry bdy_sent rsp rqst + ; switchResponse conn allow_retry bdy_sent rsp rqst } Retry -> {- Request with "Expect" header failed.@@ -160,15 +160,15 @@ _ <- writeBlock conn (show rqst ++ rqBody rqst) ; rsp <- getResponseHead conn ; switchResponse conn False bdy_sent rsp rqst- } - + }+ Done -> do- when (findConnClose hdrs)- (closeOnEnd conn True)+ when (findConnClose hdrs)+ (closeOnEnd conn True) return (Right $ Response cd rn hdrs "") DieHorribly str -> do- close conn+ close conn return $ responseParseError "sendHTTP" ("Invalid response: " ++ str) ExpectEntity ->@@ -176,24 +176,24 @@ cl = lookupHeader HdrContentLength hdrs in do { rslt <- case tc of- Nothing -> + Nothing -> case cl of Just x -> linearTransfer (readBlock conn) (read x :: Int) Nothing -> hopefulTransfer stringBufferOp {-null (++) []-} (readLine conn) []- Just x -> + Just x -> case map toLower (trim x) of "chunked" -> chunkedTransfer stringBufferOp- (readLine conn) (readBlock conn)+ (readLine conn) (readBlock conn) _ -> uglyDeathTransfer "sendHTTP" ; case rslt of- Left e -> close conn >> return (Left e)- Right (ftrs,bdy) -> do- when (findConnClose (hdrs++ftrs))- (closeOnEnd conn True)- return (Right (Response cd rn (hdrs++ftrs) bdy))+ Left e -> close conn >> return (Left e)+ Right (ftrs,bdy) -> do+ when (findConnClose (hdrs++ftrs))+ (closeOnEnd conn True)+ return (Right (Response cd rn (hdrs++ftrs) bdy)) } --- | Receive and parse a HTTP request from the given Stream. Should be used +-- | Receive and parse a HTTP request from the given Stream. Should be used -- for server side interactions. receiveHTTP :: Stream s => s -> IO (Result Request_String) receiveHTTP conn = getRequestHead >>= processRequest@@ -204,13 +204,13 @@ do { lor <- readTillEmpty1 stringBufferOp (readLine conn) ; return $ lor >>= parseRequestHead }- + processRequest (Left e) = return $ Left e- processRequest (Right (rm,uri,hdrs)) = - do -- FIXME : Also handle 100-continue.+ processRequest (Right (rm,uri,hdrs)) =+ do -- FIXME : Also handle 100-continue. let tc = lookupHeader HdrTransferEncoding hdrs cl = lookupHeader HdrContentLength hdrs- rslt <- case tc of+ rslt <- case tc of Nothing -> case cl of Just x -> linearTransfer (readBlock conn) (read x :: Int)@@ -218,14 +218,14 @@ Just x -> case map toLower (trim x) of "chunked" -> chunkedTransfer stringBufferOp- (readLine conn) (readBlock conn)+ (readLine conn) (readBlock conn) _ -> uglyDeathTransfer "receiveHTTP"- + return $ do- (ftrs,bdy) <- rslt- return (Request uri rm (hdrs++ftrs) bdy)+ (ftrs,bdy) <- rslt+ return (Request uri rm (hdrs++ftrs) bdy) --- | Very simple function, send a HTTP response over the given stream. This +-- | Very simple function, send a HTTP response over the given stream. This -- could be improved on to use different transfer types. respondHTTP :: Stream s => s -> Response_String -> IO () respondHTTP conn rsp = do -- TODO review throwing away of result@@ -233,4 +233,4 @@ -- write body immediately, don't wait for 100 CONTINUE -- TODO review throwing away of result _ <- writeBlock conn (rspBody rsp)- return ()+ return ()
Network/HTTP/Utils.hs view
@@ -4,7 +4,7 @@ -- Copyright : See LICENSE file -- License : BSD ----- Maintainer : Ganesh Sittampalam <http@projects.haskell.org>+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) --@@ -14,25 +14,31 @@ ( trim -- :: String -> String , trimL -- :: String -> String , trimR -- :: String -> String- + , crlf -- :: String , lf -- :: String , sp -- :: String , split -- :: Eq a => a -> [a] -> Maybe ([a],[a]) , splitBy -- :: Eq a => a -> [a] -> [[a]]- + , readsOne -- :: Read a => (a -> b) -> b -> String -> b , dropWhileTail -- :: (a -> Bool) -> [a] -> [a] , chopAtDelim -- :: Eq a => a -> [a] -> ([a],[a])- ++ , toUTF8BS+ , fromUTF8BS ) where- ++import Data.Bits import Data.Char import Data.List ( elemIndex ) import Data.Maybe ( fromMaybe )+import Data.Word ( Word8 ) +import qualified Data.ByteString as BS+ -- | @crlf@ is our beloved two-char line terminator. crlf :: String crlf = "\r\n"@@ -56,7 +62,7 @@ -- | @trim str@ removes leading and trailing whitespace from @str@. trim :: String -> String trim xs = trimR (trimL xs)- + -- | @trimL str@ removes leading whitespace (as defined by 'Data.Char.isSpace') -- from @str@. trimL :: String -> String@@ -68,14 +74,14 @@ trimR str = fromMaybe "" $ foldr trimIt Nothing str where trimIt x (Just xs) = Just (x:xs)- trimIt x Nothing + trimIt x Nothing | isSpace x = Nothing | otherwise = Just [x] -- | @splitMany delim ls@ removes the delimiter @delim@ from @ls@. splitBy :: Eq a => a -> [a] -> [[a]] splitBy _ [] = []-splitBy c xs = +splitBy c xs = case break (==c) xs of (_,[]) -> [xs] (as,_:bs) -> as : splitBy c bs@@ -84,7 +90,7 @@ -- the first result and passing it to @f@. If the 'read' -- doesn't succeed, return @def@. readsOne :: Read a => (a -> b) -> b -> String -> b-readsOne f n str = +readsOne f n str = case reads str of ((v,_):_) -> f v _ -> n@@ -109,3 +115,93 @@ case break (==elt) xs of (_,[]) -> (xs,[]) (as,_:bs) -> (as,bs)++toUTF8BS :: String -> BS.ByteString+toUTF8BS = BS.pack . encodeStringUtf8++fromUTF8BS :: BS.ByteString -> String+fromUTF8BS = decodeStringUtf8 . BS.unpack++-- | Encode 'String' to a list of UTF8-encoded octets+--+-- Code-points in the @U+D800@-@U+DFFF@ range will be encoded+-- as the replacement character (i.e. @U+FFFD@).+--+-- The code is extracted from Cabal library, written originally+-- Herbert Valerio Riedel under BSD-3-Clause license+encodeStringUtf8 :: String -> [Word8]+encodeStringUtf8 [] = []+encodeStringUtf8 (c:cs)+ | c <= '\x07F' = w8+ : encodeStringUtf8 cs+ | c <= '\x7FF' = (0xC0 .|. w8ShiftR 6 )+ : (0x80 .|. (w8 .&. 0x3F))+ : encodeStringUtf8 cs+ | c <= '\xD7FF'= (0xE0 .|. w8ShiftR 12 )+ : (0x80 .|. (w8ShiftR 6 .&. 0x3F))+ : (0x80 .|. (w8 .&. 0x3F))+ : encodeStringUtf8 cs+ | c <= '\xDFFF'= 0xEF : 0xBF : 0xBD -- U+FFFD+ : encodeStringUtf8 cs+ | c <= '\xFFFF'= (0xE0 .|. w8ShiftR 12 )+ : (0x80 .|. (w8ShiftR 6 .&. 0x3F))+ : (0x80 .|. (w8 .&. 0x3F))+ : encodeStringUtf8 cs+ | otherwise = (0xf0 .|. w8ShiftR 18 )+ : (0x80 .|. (w8ShiftR 12 .&. 0x3F))+ : (0x80 .|. (w8ShiftR 6 .&. 0x3F))+ : (0x80 .|. (w8 .&. 0x3F))+ : encodeStringUtf8 cs+ where+ w8 = fromIntegral (ord c) :: Word8+ w8ShiftR :: Int -> Word8+ w8ShiftR = fromIntegral . shiftR (ord c)++-- | Decode 'String' from UTF8-encoded octets.+--+-- Invalid data in the UTF8 stream (this includes code-points @U+D800@+-- through @U+DFFF@) will be decoded as the replacement character (@U+FFFD@).+--+-- See also 'encodeStringUtf8'+decodeStringUtf8 :: [Word8] -> String+decodeStringUtf8 = go+ where+ go :: [Word8] -> String+ go [] = []+ go (c : cs)+ | c <= 0x7F = chr (fromIntegral c) : go cs+ | c <= 0xBF = replacementChar : go cs+ | c <= 0xDF = twoBytes c cs+ | c <= 0xEF = moreBytes 3 0x800 cs (fromIntegral $ c .&. 0xF)+ | c <= 0xF7 = moreBytes 4 0x10000 cs (fromIntegral $ c .&. 0x7)+ | c <= 0xFB = moreBytes 5 0x200000 cs (fromIntegral $ c .&. 0x3)+ | c <= 0xFD = moreBytes 6 0x4000000 cs (fromIntegral $ c .&. 0x1)+ | otherwise = replacementChar : go cs++ twoBytes :: Word8 -> [Word8] -> String+ twoBytes c0 (c1:cs')+ | c1 .&. 0xC0 == 0x80+ = let d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6)+ .|. fromIntegral (c1 .&. 0x3F)+ in if d >= 0x80+ then chr d : go cs'+ else replacementChar : go cs'+ twoBytes _ cs' = replacementChar : go cs'++ moreBytes :: Int -> Int -> [Word8] -> Int -> [Char]+ moreBytes 1 overlong cs' acc+ | overlong <= acc && acc <= 0x10FFFF && (acc < 0xD800 || 0xDFFF < acc)+ = chr acc : go cs'++ | otherwise+ = replacementChar : go cs'++ moreBytes byteCount overlong (cn:cs') acc+ | cn .&. 0xC0 == 0x80+ = moreBytes (byteCount-1) overlong cs'+ ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F)++ moreBytes _ _ cs' _+ = replacementChar : go cs'++ replacementChar = '\xfffd'
Network/Stream.hs view
@@ -4,7 +4,7 @@ -- Copyright : See LICENSE file -- License : BSD ----- Maintainer : Ganesh Sittampalam <http@projects.haskell.org>+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) --@@ -32,24 +32,18 @@ , failMisc -- :: String -> Result a ) where -import Control.Monad.Error--data ConnError - = ErrorReset +data ConnError+ = ErrorReset | ErrorClosed | ErrorParse String | ErrorMisc String deriving(Show,Eq) -instance Error ConnError where- noMsg = strMsg "unknown error"- strMsg x = ErrorMisc x- -- in GHC 7.0 the Monad instance for Error no longer -- uses fail x = Left (strMsg x). failMisc is therefore -- used instead. failMisc :: String -> Result a-failMisc x = failWith (strMsg x)+failMisc x = failWith (ErrorMisc x) failParse :: String -> Result a failParse x = failWith (ErrorParse x)@@ -66,8 +60,8 @@ x <- a case x of Left e -> return (Left e)- Right r -> return (f r) - + Right r -> return (f r)+ -- | This is the type returned by many exported network functions. type Result a = Either ConnError {- error -} a {- result -}@@ -81,7 +75,7 @@ -- the input in any way, e.g. leave LF on line -- endings etc. Unless that is exactly the behaviour -- you want from your twisted instances ;)-class Stream x where +class Stream x where readLine :: x -> IO (Result String) readBlock :: x -> Int -> IO (Result String) writeBlock :: x -> String -> IO (Result ())
Network/StreamDebugger.hs view
@@ -4,7 +4,7 @@ -- Copyright : See LICENSE file -- License : BSD ----- Maintainer : Ganesh Sittampalam <http@projects.haskell.org>+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) --@@ -13,7 +13,7 @@ -- -- * Changes by Robin Bate Boerop <robin@bateboerop.name>: -- - Created. Made minor formatting changes.--- +-- ----------------------------------------------------------------------------- module Network.StreamDebugger ( StreamDebugger@@ -26,8 +26,8 @@ ( Handle, hFlush, hPutStrLn, IOMode(AppendMode), hClose, openFile, hSetBuffering, BufferMode(NoBuffering) )-import Network.TCP ( HandleStream, HStream, - StreamHooks(..), setStreamHooks, getStreamHooks )+import Network.TCP ( HandleStream, HStream,+ StreamHooks(..), setStreamHooks, getStreamHooks ) -- | Allows stream logging. Refer to 'debugStream' below. data StreamDebugger x@@ -37,17 +37,17 @@ readBlock (Dbg h x) n = do val <- readBlock x n hPutStrLn h ("--readBlock " ++ show n)- hPutStrLn h (show val)+ hPutStrLn h (show val) return val readLine (Dbg h x) = do val <- readLine x hPutStrLn h ("--readLine")- hPutStrLn h (show val)+ hPutStrLn h (show val) return val writeBlock (Dbg h x) str = do val <- writeBlock x str hPutStrLn h ("--writeBlock" ++ show str)- hPutStrLn h (show val)+ hPutStrLn h (show val) return val close (Dbg h x) = do hPutStrLn h "--closing..."@@ -57,22 +57,22 @@ hClose h closeOnEnd (Dbg h x) f = do hPutStrLn h ("--close-on-end.." ++ show f)- hFlush h + hFlush h closeOnEnd x f -- | Wraps a stream with logging I\/O. -- The first argument is a filename which is opened in @AppendMode@. debugStream :: (Stream a) => FilePath -> a -> IO (StreamDebugger a)-debugStream file stream = +debugStream file stream = do h <- openFile file AppendMode hPutStrLn h ("File \"" ++ file ++ "\" opened for appending.") return (Dbg h stream) debugByteStream :: HStream ty => FilePath -> HandleStream ty -> IO (HandleStream ty) debugByteStream file stream = do- sh <- getStreamHooks stream + sh <- getStreamHooks stream case sh of- Just h + Just h | hook_name h == file -> return stream -- reuse the stream hooks. _ -> do h <- openFile file AppendMode@@ -82,19 +82,19 @@ return stream debugStreamHooks :: HStream ty => Handle -> String -> StreamHooks ty-debugStreamHooks h nm = +debugStreamHooks h nm = StreamHooks { hook_readBlock = \ toStr n val -> do let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v} hPutStrLn h ("--readBlock " ++ show n) hPutStrLn h (either show show eval) , hook_readLine = \ toStr val -> do- let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v}+ let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v} hPutStrLn h ("--readLine")- hPutStrLn h (either show show eval)+ hPutStrLn h (either show show eval) , hook_writeBlock = \ toStr str val -> do hPutStrLn h ("--writeBlock " ++ show val)- hPutStrLn h (toStr str)+ hPutStrLn h (toStr str) , hook_close = do hPutStrLn h "--closing..." hFlush h
Network/StreamSocket.hs view
@@ -5,7 +5,7 @@ -- Copyright : See LICENSE file -- License : BSD ----- Maintainer : Ganesh Sittampalam <http@projects.haskell.org>+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) --@@ -17,8 +17,8 @@ -- - Created separate module for instance Stream Socket. -- -- * Changes by Simon Foster:--- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules--- +-- - Split module up into to separate Network.[Stream,TCP,HTTP] modules+-- ----------------------------------------------------------------------------- module Network.StreamSocket ( handleSocketError@@ -29,11 +29,15 @@ ( Stream(..), ConnError(ErrorReset, ErrorMisc), Result ) import Network.Socket- ( Socket, getSocketOption, shutdown, send, recv, sClose+ ( Socket, getSocketOption, shutdown , ShutdownCmd(ShutdownBoth), SocketOption(SoError) )+import Network.Socket.ByteString (send, recv)+import qualified Network.Socket+ ( close ) import Network.HTTP.Base ( catchIO )+import Network.HTTP.Utils ( fromUTF8BS, toUTF8BS ) import Control.Monad (liftM) import Control.Exception as Exception (IOException) import System.IO.Error (isEOFError)@@ -50,7 +54,7 @@ myrecv :: Socket -> Int -> IO String myrecv sock len = let handler e = if isEOFError e then return [] else ioError e- in catchIO (recv sock len) handler+ in catchIO (fmap fromUTF8BS (recv sock len)) handler instance Stream Socket where readBlock sk n = readBlockSocket sk n@@ -59,7 +63,7 @@ close sk = do -- This slams closed the connection (which is considered rude for TCP\/IP) shutdown sk ShutdownBoth- sClose sk+ Network.Socket.close sk closeOnEnd _sk _ = return () -- can't really deal with this, so do run the risk of leaking sockets here. readBlockSocket :: Socket -> Int -> IO (Result String)@@ -73,7 +77,7 @@ } -- Use of the following function is discouraged.--- The function reads in one character at a time, +-- The function reads in one character at a time, -- which causes many calls to the kernel recv() -- hence causes many context switches. readLineSocket :: Socket -> IO (Result String)@@ -84,10 +88,10 @@ if null c || c == "\n" then return (reverse str++c) else fn (head c:str)- + writeBlockSocket :: Socket -> String -> IO (Result ()) writeBlockSocket sk str = (liftM Right $ fn str) `catchIO` (handleSocketError sk) where fn [] = return ()- fn x = send sk x >>= \i -> fn (drop i x)+ fn x = send sk (toUTF8BS x) >>= \i -> fn (drop i x)
Network/TCP.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- |@@ -5,13 +6,13 @@ -- Copyright : See LICENSE file -- License : BSD ----- Maintainer : Ganesh Sittampalam <http@projects.haskell.org>+-- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) -- -- Some utility functions for working with the Haskell @network@ package. Mostly--- for internal use by the @Network.HTTP@ code, but --- +-- for internal use by the @Network.HTTP@ code.+-- ----------------------------------------------------------------------------- module Network.TCP ( Connection@@ -22,10 +23,10 @@ , openTCPConnection , socketConnection , isTCPConnectedTo- + , HandleStream , HStream(..)- + , StreamHooks(..) , nullHooks , setStreamHooks@@ -34,14 +35,17 @@ ) where -import Network.BSD (getHostByName, hostAddresses) import Network.Socket- ( Socket, SockAddr(SockAddrInet), SocketOption(KeepAlive)- , SocketType(Stream), inet_addr, connect+ ( Socket, SocketOption(KeepAlive)+ , SocketType(Stream), connect , shutdown, ShutdownCmd(..)- , sClose, setSocketOption, getPeerName- , socket, Family(AF_INET)+ , setSocketOption, getPeerName+ , socket, Family(AF_UNSPEC), defaultProtocol, getAddrInfo+ , defaultHints, addrFamily, withSocketsDo+ , addrSocketType, addrAddress )+import qualified Network.Socket+ ( close ) import qualified Network.Stream as Stream ( Stream(readBlock, readLine, writeBlock, close, closeOnEnd) ) import Network.Stream@@ -58,7 +62,7 @@ import Data.Char ( toLower ) import Data.Word ( Word8 ) import Control.Concurrent-import Control.Exception ( onException )+import Control.Exception ( IOException, bracketOnError, try ) import Control.Monad ( liftM, when ) import System.IO ( Handle, hFlush, IOMode(..), hClose ) import System.IO.Error ( isEOFError )@@ -85,14 +89,14 @@ EndPoint host1 port1 == EndPoint host2 port2 = map toLower host1 == map toLower host2 && port1 == port2 -data Conn a - = MkConn { connSock :: ! Socket- , connHandle :: Handle+data Conn a+ = MkConn { connSock :: !Socket+ , connHandle :: Handle , connBuffer :: BufferOp a- , connInput :: Maybe a+ , connInput :: Maybe a , connEndPoint :: EndPoint- , connHooks :: Maybe (StreamHooks a)- , connCloseEOF :: Bool -- True => close socket upon reaching end-of-stream.+ , connHooks :: Maybe (StreamHooks a)+ , connCloseEOF :: Bool -- True => close socket upon reaching end-of-stream. } | ConnClosed deriving(Eq)@@ -118,7 +122,7 @@ (==) _ _ = True nullHooks :: StreamHooks ty-nullHooks = StreamHooks +nullHooks = StreamHooks { hook_readLine = \ _ _ -> return () , hook_readBlock = \ _ _ _ -> return () , hook_writeBlock = \ _ _ _ -> return ()@@ -140,7 +144,7 @@ -- The library comes with instances for @ByteString@s and @String@, but -- should you want to plug in your own payload representation, defining -- your own @HStream@ instance _should_ be all that it takes.--- +-- class BufferType bufType => HStream bufType where openStream :: String -> Int -> IO (HandleStream bufType) openSocketStream :: String -> Int -> Socket -> IO (HandleStream bufType)@@ -150,7 +154,7 @@ close :: HandleStream bufType -> IO () closeQuick :: HandleStream bufType -> IO () closeOnEnd :: HandleStream bufType -> Bool -> IO ()- + instance HStream Strict.ByteString where openStream = openTCPConnection openSocketStream = socketConnection@@ -174,10 +178,10 @@ instance Stream.Stream Connection where readBlock (Connection c) = Network.TCP.readBlock c readLine (Connection c) = Network.TCP.readLine c- writeBlock (Connection c) = Network.TCP.writeBlock c + writeBlock (Connection c) = Network.TCP.writeBlock c close (Connection c) = Network.TCP.close c closeOnEnd (Connection c) f = Network.TCP.closeEOF c f- + instance HStream String where openStream = openTCPConnection openSocketStream = socketConnection@@ -186,7 +190,7 @@ -- This function uses a buffer, at this time the buffer is just 1000 characters. -- (however many bytes this is is left to the user to decypher) readLine ref = readLineBS ref- -- The 'Connection' object allows no outward buffering, + -- The 'Connection' object allows no outward buffering, -- since in general messages are serialised in their entirety. writeBlock ref str = writeBlockBS ref str -- (stringToBuf str) @@ -195,14 +199,14 @@ -- at any time before a call to this function. This function is idempotent. -- (I think the behaviour here is TCP specific) close c = closeIt c null True- + -- Closes a Connection without munching the rest of the stream. closeQuick c = closeIt c null False closeOnEnd c f = closeEOF c f- + -- | @openTCPPort uri port@ establishes a connection to a remote--- host, using 'getHostByName' which possibly queries the DNS system, hence +-- host, using 'getHostByName' which possibly queries the DNS system, hence -- may trigger a network connection. openTCPPort :: String -> Int -> IO Connection openTCPPort uri port = openTCPConnection uri port >>= return.Connection@@ -213,34 +217,64 @@ openTCPConnection uri port = openTCPConnection_ uri port False openTCPConnection_ :: BufferType ty => String -> Int -> Bool -> IO (HandleStream ty)-openTCPConnection_ uri port stashInput = withSocket $ \s -> do- setSocketOption s KeepAlive 1- hostA <- getHostAddr uri- let a = SockAddrInet (toEnum port) hostA- connect s a- socketConnection_ uri port s stashInput- where- withSocket action = do- s <- socket AF_INET Stream 6- onException (action s) (sClose s)- getHostAddr h = do- catchIO (inet_addr uri) -- handles ascii IP numbers- (\ _ -> do- host <- getHostByName_safe uri- case hostAddresses host of- [] -> fail ("openTCPConnection: no addresses in host entry for " ++ show h)- (ha:_) -> return ha)+openTCPConnection_ uri port stashInput = do+ -- HACK: uri is sometimes obtained by calling Network.URI.uriRegName, and this includes+ -- the surrounding square brackets for an RFC 2732 host like [::1]. It's not clear whether+ -- it should, or whether all call sites should be using something different instead, but+ -- the simplest short-term fix is to strip any surrounding square brackets here.+ -- It shouldn't affect any as this is the only situation they can occur - see RFC 3986.+ let fixedUri =+ case uri of+ '[':(rest@(c:_)) | last rest == ']'+ -> if c == 'v' || c == 'V'+ then error $ "Unsupported post-IPv6 address " ++ uri+ else init rest+ _ -> uri - getHostByName_safe h = - catchIO (getHostByName h)- (\ _ -> fail ("openTCPConnection: host lookup failure for " ++ show h)) + -- use withSocketsDo here in case the caller hasn't used it, which would make getAddrInfo fail on Windows+ -- although withSocketsDo is supposed to wrap the entire program, in practice it is safe to use it locally+ -- like this as it just does a once-only installation of a shutdown handler to run at program exit,+ -- rather than actually shutting down after the action+ addrinfos <- withSocketsDo $ getAddrInfo (Just $ defaultHints { addrFamily = AF_UNSPEC, addrSocketType = Stream }) (Just fixedUri) (Just . show $ port)++ let+ connectAddrInfo a = bracketOnError+ (socket (addrFamily a) Stream defaultProtocol) -- acquire+ Network.Socket.close -- release+ ( \s -> do+ setSocketOption s KeepAlive 1+ connect s (addrAddress a)+ socketConnection_ fixedUri port s stashInput )++ -- try multiple addresses; return Just connected socket or Nothing+ tryAddrInfos [] = return Nothing+ tryAddrInfos (h:t) =+ let next = \(_ :: IOException) -> tryAddrInfos t+ in try (connectAddrInfo h) >>= either next (return . Just)++ case addrinfos of+ [] -> fail "openTCPConnection: getAddrInfo returned no address information"++ -- single AddrInfo; call connectAddrInfo directly so that specific+ -- exception is thrown in event of failure+ [ai] -> connectAddrInfo ai `catchIO` (\e -> fail $+ "openTCPConnection: failed to connect to "+ ++ show (addrAddress ai) ++ ": " ++ show e)++ -- multiple AddrInfos; try each until we get a connection, or run out+ ais ->+ let+ err = fail $ "openTCPConnection: failed to connect; tried addresses: "+ ++ show (fmap addrAddress ais)+ in tryAddrInfos ais >>= maybe err return+ -- | @socketConnection@, like @openConnection@ but using a pre-existing 'Socket'. socketConnection :: BufferType ty => String -> Int- -> Socket- -> IO (HandleStream ty)+ -> Socket+ -> IO (HandleStream ty) socketConnection hst port sock = socketConnection_ hst port sock False -- Internal function used to control the on-demand streaming of input@@ -248,21 +282,21 @@ socketConnection_ :: BufferType ty => String -> Int- -> Socket- -> Bool- -> IO (HandleStream ty)+ -> Socket+ -> Bool+ -> IO (HandleStream ty) socketConnection_ hst port sock stashInput = do h <- socketToHandle sock ReadWriteMode mb <- case stashInput of { True -> liftM Just $ buf_hGetContents bufferOps h; _ -> return Nothing }- let conn = MkConn + let conn = MkConn { connSock = sock- , connHandle = h- , connBuffer = bufferOps- , connInput = mb- , connEndPoint = EndPoint hst port- , connHooks = Nothing- , connCloseEOF = False- }+ , connHandle = h+ , connBuffer = bufferOps+ , connInput = mb+ , connEndPoint = EndPoint hst port+ , connHooks = Nothing+ , connCloseEOF = False+ } v <- newMVar conn return (HandleStream v) @@ -286,7 +320,7 @@ suck readL hClose (connHandle conn) shutdown sk ShutdownReceive- sClose sk+ Network.Socket.close sk suck :: IO Bool -> IO () suck rd = do@@ -297,21 +331,14 @@ -- and that the connection peer matches the given -- host name (which is recorded locally). isConnectedTo :: Connection -> EndPoint -> IO Bool-isConnectedTo (Connection conn) endPoint = do- v <- readMVar (getRef conn)- case v of- ConnClosed -> print "aa" >> return False- _ - | connEndPoint v == endPoint ->- catchIO (getPeerName (connSock v) >> return True) (const $ return False)- | otherwise -> return False+isConnectedTo (Connection conn) endPoint = isTCPConnectedTo conn endPoint isTCPConnectedTo :: HandleStream ty -> EndPoint -> IO Bool isTCPConnectedTo conn endPoint = do v <- readMVar (getRef conn) case v of ConnClosed -> return False- _ + _ | connEndPoint v == endPoint -> catchIO (getPeerName (connSock v) >> return True) (const $ return False) | otherwise -> return False@@ -321,7 +348,7 @@ x <- bufferGetBlock ref n maybe (return ()) (\ h -> hook_readBlock h (buf_toStr $ connBuffer conn) n x)- (connHooks' conn)+ (connHooks' conn) return x -- This function uses a buffer, at this time the buffer is just 1000 characters.@@ -331,17 +358,17 @@ x <- bufferReadLine ref maybe (return ()) (\ h -> hook_readLine h (buf_toStr $ connBuffer conn) x)- (connHooks' conn)+ (connHooks' conn) return x --- The 'Connection' object allows no outward buffering, +-- The 'Connection' object allows no outward buffering, -- since in general messages are serialised in their entirety. writeBlockBS :: HandleStream a -> a -> IO (Result ()) writeBlockBS ref b = onNonClosedDo ref $ \ conn -> do x <- bufferPutBlock (connBuffer conn) (connHandle conn) b maybe (return ()) (\ h -> hook_writeBlock h (buf_toStr $ connBuffer conn) b x)- (connHooks' conn)+ (connHooks' conn) return x closeIt :: HStream ty => HandleStream ty -> (ty -> Bool) -> Bool -> IO ()@@ -352,7 +379,7 @@ conn <- readMVar (getRef c) maybe (return ()) (hook_close)- (connHooks' conn)+ (connHooks' conn) closeEOF :: HandleStream ty -> Bool -> IO () closeEOF c flg = modifyMVar_ (getRef c) (\ co -> return co{connCloseEOF=flg})@@ -367,14 +394,14 @@ _ -> do catchIO (buf_hGet (connBuffer conn) (connHandle conn) n >>= return.return) (\ e ->- if isEOFError e - then do- when (connCloseEOF conn) $ catchIO (closeQuick ref) (\ _ -> return ())- return (return (buf_empty (connBuffer conn)))- else return (failMisc (show e)))+ if isEOFError e+ then do+ when (connCloseEOF conn) $ catchIO (closeQuick ref) (\ _ -> return ())+ return (return (buf_empty (connBuffer conn)))+ else return (failMisc (show e))) bufferPutBlock :: BufferOp a -> Handle -> a -> IO (Result ())-bufferPutBlock ops h b = +bufferPutBlock ops h b = catchIO (buf_hPut ops h b >> hFlush h >> return (return ())) (\ e -> return (failMisc (show e))) @@ -387,19 +414,19 @@ modifyMVar_ (getRef ref) (\ co -> return co{connInput=Just b1}) return (return (buf_append (connBuffer conn) a newl)) _ -> catchIO- (buf_hGetLine (connBuffer conn) (connHandle conn) >>= - return . return . appendNL (connBuffer conn))+ (buf_hGetLine (connBuffer conn) (connHandle conn) >>=+ return . return . appendNL (connBuffer conn)) (\ e -> if isEOFError e then do- when (connCloseEOF conn) $ catchIO (closeQuick ref) (\ _ -> return ())- return (return (buf_empty (connBuffer conn)))+ when (connCloseEOF conn) $ catchIO (closeQuick ref) (\ _ -> return ())+ return (return (buf_empty (connBuffer conn))) else return (failMisc (show e))) where -- yes, this s**ks.. _may_ have to be addressed if perf -- suggests worthiness. appendNL ops b = buf_snoc ops b nl- + nl :: Word8 nl = fromIntegral (fromEnum '\n') @@ -409,4 +436,4 @@ case x of ConnClosed{} -> return (failWith ErrorClosed) _ -> act x- +
+ test/Httpd.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE CPP #-}++module Httpd+ ( Request, Response, Server+ , mkResponse+ , reqMethod, reqURI, reqHeaders, reqBody+ , shed+#ifdef WARP_TESTS+ , warp+#endif+ )+ where++import Control.Applicative+import Control.Arrow ( (***) )+import Control.DeepSeq+import Control.Monad+import Control.Monad.Trans ( liftIO )+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy.Char8 as BLC+#ifdef WARP_TESTS+import qualified Data.CaseInsensitive as CI+#endif+import Data.Maybe ( fromJust )+import Network.URI ( URI, parseRelativeReference )++import Network.Socket+ ( getAddrInfo, AddrInfo, defaultHints, addrAddress, addrFamily+ , addrFlags, addrSocketType, AddrInfoFlag(AI_PASSIVE), socket, Family(AF_UNSPEC,AF_INET6)+ , defaultProtocol, SocketType(Stream), listen, setSocketOption, SocketOption(ReuseAddr)+ )+#ifdef WARP_TESTS+#if MIN_VERSION_network(2,4,0)+import Network.Socket ( bind )+#else+import Network.Socket ( bindSocket, Socket, SockAddr )+#endif+#endif++import qualified Network.Shed.Httpd as Shed+ ( Request, Response(Response), initServer+ , reqMethod, reqURI, reqHeaders, reqBody+ )+#ifdef WARP_TESTS+#if !MIN_VERSION_wai(3,0,0)+import qualified Data.Conduit.Lazy as Warp+#endif++import qualified Network.HTTP.Types as Warp+ ( Status(..) )+import qualified Network.Wai as Warp+import qualified Network.Wai.Handler.Warp as Warp+ ( runSettingsSocket, defaultSettings, setPort )+#endif++data Request = Request+ {+ reqMethod :: String,+ reqURI :: URI,+ reqHeaders :: [(String, String)],+ reqBody :: String+ }++data Response = Response+ {+ respStatus :: Int,+ respHeaders :: [(String, String)],+ respBody :: String+ }++mkResponse :: Int -> [(String, String)] -> String -> Response+mkResponse = Response++type Server = Int -> (Request -> IO Response) -> IO ()++shed :: Server+shed port handler =+ () <$ Shed.initServer+ port+ (liftM responseToShed . handler . requestFromShed)+ where+ responseToShed (Response status hdrs body) =+ Shed.Response status hdrs body+ chomp = reverse . strip '\r' . reverse+ strip c (c':str) | c == c' = str+ strip c str = str+ requestFromShed request =+ Request+ {+ reqMethod = Shed.reqMethod request,+ reqURI = Shed.reqURI request,+ reqHeaders = map (id *** chomp) $ Shed.reqHeaders request,+ reqBody = Shed.reqBody request+ }++#if !MIN_VERSION_bytestring(0,10,0)+instance NFData B.ByteString where+ rnf = rnf . B.length+#endif++#ifdef WARP_TESTS+#if !MIN_VERSION_network(2,4,0)+bind :: Socket -> SockAddr -> IO ()+bind = bindSocket+#endif++warp :: Bool -> Server+warp ipv6 port handler = do+ addrinfos <- getAddrInfo (Just $ defaultHints { addrFamily = AF_UNSPEC, addrSocketType = Stream })+ (Just $ if ipv6 then "::1" else "127.0.0.1")+ (Just . show $ port)+ case addrinfos of+ [] -> fail "Couldn't obtain address information in warp"+ (addri:_) -> do+ sock <- socket (addrFamily addri) Stream defaultProtocol+ setSocketOption sock ReuseAddr 1+ bind sock (addrAddress addri)+ listen sock 5+#if MIN_VERSION_wai(3,0,0)+ Warp.runSettingsSocket (Warp.setPort port Warp.defaultSettings) sock $ \warpRequest warpRespond -> do+ request <- requestFromWarp warpRequest+ response <- handler request+ warpRespond (responseToWarp response)+#else+ Warp.runSettingsSocket (Warp.setPort port Warp.defaultSettings) sock $ \warpRequest -> do+ request <- requestFromWarp warpRequest+ response <- handler request+ return (responseToWarp response)+#endif+ where+ responseToWarp (Response status hdrs body) =+ Warp.responseLBS+ (Warp.Status status B.empty)+ (map headerToWarp hdrs)+ (BLC.pack body)+ headerToWarp (name, value) = (CI.mk (BC.pack name), BC.pack value)+ headerFromWarp (name, value) =+ (BC.unpack (CI.original name), BC.unpack value)+ requestFromWarp request = do+#if MIN_VERSION_wai(3,0,1)+ body <- fmap BLC.unpack $ Warp.strictRequestBody request+#else+ body <- fmap BLC.unpack $ Warp.lazyRequestBody request+ body `deepseq` return ()+#endif+ return $+ Request+ {+ reqMethod = BC.unpack (Warp.requestMethod request),+ reqURI = fromJust . parseRelativeReference .+ BC.unpack . Warp.rawPathInfo $+ request,+ reqHeaders = map headerFromWarp (Warp.requestHeaders request),+ reqBody = body+ }+#endif
+ test/UnitTests.hs view
@@ -0,0 +1,69 @@+module UnitTests ( unitTests ) where++import Network.HTTP.Base+import Network.HTTP.Headers+import Network.URI++import Data.Maybe ( fromJust )++import Test.Framework ( testGroup )+import Test.Framework.Providers.HUnit+import Test.HUnit++parseIPv4Address :: Assertion+parseIPv4Address =+ assertEqual "127.0.0.1 address is recognised"+ (Just (URIAuthority {user = Nothing, password = Nothing, host = "127.0.0.1", port = Just 5313}))+ (parseURIAuthority (uriToAuthorityString (fromJust (parseURI "http://127.0.0.1:5313/foo"))))+++parseIPv6Address :: Assertion+parseIPv6Address =+ assertEqual "::1 address"+ (Just (URIAuthority {user = Nothing, password = Nothing, host = "::1", port = Just 5313}))+ (parseURIAuthority (uriToAuthorityString (fromJust (parseURI "http://[::1]:5313/foo"))))++customHeaderNameComparison :: Assertion+customHeaderNameComparison =+ assertEqual "custom header name" (HdrCustom "foo") (HdrCustom "Foo")++customHeaderLookup :: Assertion+customHeaderLookup =+ let val = "header value"+ h = Header (HdrCustom "foo") val++ in assertEqual "custom header lookup" (Just val)+ (lookupHeader (HdrCustom "Foo") [h])++caseInsensitiveHeaderParse :: Assertion+caseInsensitiveHeaderParse =+ let expected = [ Header HdrContentType "blah"+ , Header (HdrCustom "X-Unknown") "unused"+ ]+ input = [ "content-type: blah"+ , "X-Unknown: unused"+ ]++ match actual =+ length actual == length expected &&+ and [ hdrName a == hdrName b && hdrValue a == hdrValue b+ | (a, b) <- zip expected actual+ ]++ in case parseHeaders input of+ Left _ -> assertFailure "Failed header parse"+ Right actual -> assert (match actual)++unitTests =+ [testGroup "Unit tests"+ [ testGroup "URI parsing"+ [ testCase "Parse IPv4 address" parseIPv4Address+ , testCase "Parse IPv6 address" parseIPv6Address+ ]+ ]+ , testGroup "Header tests"+ [ testCase "Custom header name case-insensitive match" customHeaderNameComparison+ , testCase "Custom header lookup" customHeaderLookup+ , testCase "Case-insensitive parsing" caseInsensitiveHeaderParse+ ]+ ]
test/httpTests.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ImplicitParams, ViewPatterns, NoMonomorphismRestriction #-}+{-# LANGUAGE ImplicitParams, ViewPatterns, NoMonomorphismRestriction, CPP #-} import Control.Concurrent import Control.Applicative ((<$))@@ -12,6 +12,7 @@ import System.IO.Error (userError) import qualified Httpd+import qualified UnitTests import Network.Browser import Network.HTTP@@ -22,6 +23,7 @@ import Network.URI (uriPath, parseURI) import System.Environment (getArgs)+import System.Info (os) import System.IO (getChar) import Test.Framework (defaultMainWithArgs, testGroup)@@ -82,6 +84,22 @@ (show (Just "text/plain", Just "4", sendBody)) body +userpwAuthFailure :: (?baduserpwUrl :: ServerAddress) => Assertion+userpwAuthFailure = do+ response <- simpleHTTP (getRequest (?baduserpwUrl "/auth/basic"))+ code <- getResponseCode response+ body <- getResponseBody response+ assertEqual "HTTP status code" ((4, 0, 1),+ "Just \"Basic dGVzdDp3cm9uZ3B3ZA==\"") (code, body)+ -- in case of 401, the server returns the contents of the Authz header++userpwAuthSuccess :: (?userpwUrl :: ServerAddress) => Assertion+userpwAuthSuccess = do+ response <- simpleHTTP (getRequest (?userpwUrl "/auth/basic"))+ code <- getResponseCode response+ body <- getResponseBody response+ assertEqual "Receiving expected response" ((2, 0, 0), "Here's the secret") (code, body)+ basicAuthFailure :: (?testUrl :: ServerAddress) => Assertion basicAuthFailure = do response <- simpleHTTP (getRequest (?testUrl "/auth/basic"))@@ -121,7 +139,7 @@ result <- -- sample code from Network.Browser haddock, with URL changed -- Note there's also a copy of the example in the .cabal file- do + do (_, rsp) <- Network.Browser.browse $ do setAllowRedirects True -- handle HTTP redirects@@ -129,7 +147,7 @@ return (take 100 (rspBody rsp)) assertEqual "Receiving expected response" (take 100 haskellOrgText) result --- A vanilla HTTP request using Browser shouln't send a cookie header+-- A vanilla HTTP request using Browser shouldn't send a cookie header browserNoCookie :: (?testUrl :: ServerAddress) => Assertion browserNoCookie = do (_, response) <- browse $ do@@ -151,7 +169,6 @@ browserOneCookie = do (_, response) <- browse $ do setOutHandler (const $ return ())- setMaxPoolSize (Just 0) -- TODO remove this: workaround for github issue 14 -- This first requests returns a single Set-Cookie: hello=world _ <- request $ getRequest (?testUrl "/browser/one-cookie/1") @@ -166,7 +183,6 @@ browserTwoCookies = do (_, response) <- browse $ do setOutHandler (const $ return ())- setMaxPoolSize (Just 0) -- TODO remove this: workaround for github issue 14 -- This first request returns two cookies _ <- request $ getRequest (?testUrl "/browser/two-cookies/1") @@ -182,7 +198,6 @@ browserFollowsRedirect n = do (_, response) <- browse $ do setOutHandler (const $ return ())- setMaxPoolSize (Just 0) -- TODO remove this: workaround for github issue 14 request $ getRequest (?testUrl "/browser/redirect/relative/" ++ show n ++ "/basic/get") assertEqual "Receiving expected response from server" ((2, 0, 0), "It works.")@@ -192,7 +207,6 @@ browserReturnsRedirect n = do (_, response) <- browse $ do setOutHandler (const $ return ())- setMaxPoolSize (Just 0) -- TODO remove this: workaround for github issue 14 request $ getRequest (?testUrl "/browser/redirect/relative/" ++ show n ++ "/basic/get") assertEqual "Receiving expected response from server" ((n `div` 100, n `mod` 100 `div` 10, n `mod` 10), "")@@ -205,7 +219,6 @@ browserBasicAuth = do (_, response) <- browse $ do setOutHandler (const $ return ())- setMaxPoolSize (Just 0) -- TODO remove this: workaround for github issue 14 setAuthorityGen authGenBasic @@ -222,7 +235,6 @@ browserDigestAuth = do (_, response) <- browse $ do setOutHandler (const $ return ())- setMaxPoolSize (Just 0) -- TODO remove this: workaround for github issue 14 setAuthorityGen authGenDigest @@ -413,7 +425,7 @@ -- first bits of result text from haskell.org (just to give some representative text) haskellOrgText = "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">\-\<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\" dir=\"ltr\">\+\\t<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\" dir=\"ltr\">\ \\t<head>\ \\t\t<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />\ \\t\t\t\t<meta name=\"keywords\" content=\"Haskell,Applications and libraries,Books,Foreign Function Interface,Functional programming,Hac Boston,HakkuTaikai,HaskellImplementorsWorkshop/2011,Haskell Communities and Activities Report,Haskell in education,Haskell in industry\" />"@@ -441,7 +453,7 @@ => Httpd.Request -> IO Httpd.Response processRequest req = do- case (Httpd.reqMethod req, Network.URI.uriPath (Httpd.reqURI req)) of + case (Httpd.reqMethod req, Network.URI.uriPath (Httpd.reqURI req)) of ("GET", "/basic/get") -> return $ Httpd.mkResponse 200 [] "It works." ("GET", "/basic/get2") -> return $ Httpd.mkResponse 200 [] "It works (2)." ("GET", "/basic/head") -> return $ Httpd.mkResponse 200 [] "Body for /basic/head."@@ -508,7 +520,7 @@ altProcessRequest :: Httpd.Request -> IO Httpd.Response altProcessRequest req = do- case (Httpd.reqMethod req, Network.URI.uriPath (Httpd.reqURI req)) of + case (Httpd.reqMethod req, Network.URI.uriPath (Httpd.reqURI req)) of ("GET", "/basic/get") -> return $ Httpd.mkResponse 200 [] "This is the alternate server." ("GET", "/basic/get2") -> return $ Httpd.mkResponse 200 [] "This is the alternate server (2)." _ -> return $ Httpd.mkResponse 500 [] "Unknown request"@@ -524,6 +536,8 @@ , testCase "Secure GET request" secureGetRequest , testCase "Basic POST request" basicPostRequest , testCase "Basic HEAD request" basicHeadRequest+ , testCase "URI user:pass Auth failure" userpwAuthFailure+ , testCase "URI user:pass Auth success" userpwAuthSuccess , testCase "Basic Auth failure" basicAuthFailure , testCase "Basic Auth success" basicAuthSuccess , testCase "UTF-8 urlEncode" utf8URLEncode@@ -534,9 +548,8 @@ testGroup "Browser tests" [ testGroup "Basic" [- -- github issue 14- -- testCase "Two requests" browserTwoRequests testCase "Network.Browser example code" browserExample+ , testCase "Two requests" browserTwoRequests ] , testGroup "Secure" [@@ -581,46 +594,59 @@ [ testCase "Alternate server" browserAlt , testCase "Both servers" browserBoth , testCase "Both servers (reversed)" browserBothReversed- -- github issue 14- -- , testCase "Two requests - alternate server" browserTwoRequestsAlt- -- , testCase "Two requests - both servers" browserTwoRequestsBoth+ , testCase "Two requests - alternate server" browserTwoRequestsAlt+ , testCase "Two requests - both servers" browserTwoRequestsBoth ] -urlRoot :: Int -> String-urlRoot 80 = "http://localhost"-urlRoot n = "http://localhost:" ++ show n+data InetFamily = IPv4 | IPv6 -secureRoot :: Int -> String-secureRoot 443 = "https://localhost"-secureRoot n = "https://localhost:" ++ show n+familyToLocalhost :: InetFamily -> String+familyToLocalhost IPv4 = "127.0.0.1"+familyToLocalhost IPv6 = "[::1]" +urlRoot :: InetFamily -> String -> Int -> String+urlRoot fam userpw 80 = "http://" ++ userpw ++ familyToLocalhost fam+urlRoot fam userpw n = "http://" ++ userpw ++ familyToLocalhost fam ++ ":" ++ show n++secureRoot :: InetFamily -> String -> Int -> String+secureRoot fam userpw 443 = "https://" ++ userpw ++ familyToLocalhost fam+secureRoot fam userpw n = "https://" ++ userpw ++ familyToLocalhost fam ++ ":" ++ show n+ type ServerAddress = String -> String -httpAddress, httpsAddress :: Int -> ServerAddress-httpAddress port p = urlRoot port ++ p-httpsAddress port p = secureRoot port ++ p+httpAddress, httpsAddress :: InetFamily -> String -> Int -> ServerAddress+httpAddress fam userpw port p = urlRoot fam userpw port ++ p+httpsAddress fam userpw port p = secureRoot fam userpw port ++ p main :: IO () main = do args <- getArgs - let servers = [("httpd-shed", Httpd.shed), ("warp", Httpd.warp)]+ let servers =+ [ ("httpd-shed", Httpd.shed, IPv4)+#ifdef WARP_TESTS+ , ("warp.v6", Httpd.warp True, IPv6)+ , ("warp.v4", Httpd.warp False, IPv4)+#endif+ ] basePortNum, altPortNum :: Int basePortNum = 5812 altPortNum = 80 numberedServers = zip [basePortNum..] servers let setupNormalTests = do- flip mapM numberedServers $ \(portNum, (serverName, server)) -> do- let ?testUrl = httpAddress portNum- ?secureTestUrl = httpsAddress portNum+ flip mapM numberedServers $ \(portNum, (serverName, server, family)) -> do+ let ?testUrl = httpAddress family "" portNum+ ?userpwUrl = httpAddress family "test:password@" portNum+ ?baduserpwUrl = httpAddress family "test:wrongpwd@" portNum+ ?secureTestUrl = httpsAddress family "" portNum _ <- forkIO $ server portNum processRequest return $ testGroup serverName [basicTests, browserTests] let setupAltTests = do- let (portNum, (_, server)) = head numberedServers- let ?testUrl = httpAddress portNum- ?altTestUrl = httpAddress altPortNum+ let (portNum, (_, server,family)) = head numberedServers+ let ?testUrl = httpAddress family "" portNum+ ?altTestUrl = httpAddress family "" altPortNum _ <- forkIO $ server altPortNum altProcessRequest return port80Tests @@ -635,8 +661,8 @@ normalTests <- setupNormalTests altTests <- setupAltTests _ <- threadDelay 1000000 -- Give the server time to start :-(- defaultMainWithArgs (normalTests ++ [altTests]) args+ defaultMainWithArgs (UnitTests.unitTests ++ normalTests ++ [altTests]) args args -> do -- run the test harness as normal normalTests <- setupNormalTests _ <- threadDelay 1000000 -- Give the server time to start :-(- defaultMainWithArgs normalTests args+ defaultMainWithArgs (UnitTests.unitTests ++ normalTests) args