HTTP 4000.2.23 → 4000.5.0
raw patch · 21 files changed
Files
- CHANGES +14/−0
- HTTP.cabal +76/−64
- Network/Browser.hs +97/−97
- Network/BufferType.hs +14/−14
- Network/HTTP.hs +29/−29
- Network/HTTP/Auth.hs +12/−12
- Network/HTTP/Base.hs +80/−72
- Network/HTTP/Base64.hs +12/−12
- Network/HTTP/Cookie.hs +14/−14
- Network/HTTP/HandleStream.hs +12/−12
- Network/HTTP/Headers.hs +174/−19
- Network/HTTP/MD5Aux.hs +3/−3
- Network/HTTP/Proxy.hs +20/−7
- Network/HTTP/Stream.hs +15/−15
- Network/HTTP/Utils.hs +104/−8
- Network/Stream.hs +6/−12
- Network/StreamDebugger.hs +7/−7
- Network/StreamSocket.hs +12/−8
- Network/TCP.hs +56/−38
- test/UnitTests.hs +37/−0
- test/httpTests.hs +4/−4
CHANGES view
@@ -1,3 +1,17 @@+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.
HTTP.cabal view
@@ -1,8 +1,8 @@+Cabal-Version: 3.0 Name: HTTP-Version: 4000.2.23-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 <ganesh@earth.li>@@ -40,40 +40,58 @@ > 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 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- default: False- 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: True+ default: False manual: True -flag network-uri- description: Get Network.URI from the network-uri package- default: True- Library+ Autogen-modules: Paths_HTTP Exposed-modules: Network.BufferType, Network.Stream,@@ -92,41 +110,39 @@ Other-modules: Network.HTTP.Base64, Network.HTTP.MD5Aux,- Network.HTTP.Utils+ Network.HTTP.Utils, Paths_HTTP GHC-options: -fwarn-missing-signatures -Wall -- note the test harness constraints should be kept in sync with these -- where dependencies are shared- Build-depends: base >= 4.3.0.0 && < 4.9, parsec >= 2.0 && < 3.2- Build-depends: array >= 0.3.0.2 && < 0.6, old-time >= 1.0.0.0 && < 1.2, bytestring >= 0.9.1.5 && < 0.11-- Extensions: FlexibleInstances-- if flag(mtl1)- Build-depends: mtl >= 1.1.1.0 && < 1.2- CPP-Options: -DMTL1- else- Build-depends: mtl >= 2.0 && < 2.3-- if flag(network-uri)- Build-depends: network-uri == 2.6.*, network == 2.6.*- else- Build-depends: network >= 2.2.1.8 && < 2.6+ 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 - build-tools: ghc >= 7.0 && < 7.12+ default-language: Haskell98+ default-extensions: FlexibleInstances if flag(warn-as-error) ghc-options: -Werror if os(windows)- Build-depends: Win32 >= 2.2.0.0 && < 2.4+ Build-depends: Win32 >= 2.2.0.0 && < 2.15 Test-Suite test type: exitcode-stdio-1.0 - build-tools: ghc >= 7.0 && < 7.12-+ default-language: Haskell98 hs-source-dirs: test main-is: httpTests.hs @@ -134,39 +150,35 @@ Httpd UnitTests - -- note: version constraints for dependencies shared with the library- -- should be the same- build-depends: HTTP,- HUnit >= 1.2.0.1 && < 1.4,- httpd-shed >= 0.4 && < 0.5,- mtl >= 1.1.1.0 && < 2.3,- bytestring >= 0.9.1.5 && < 0.11,- deepseq >= 1.3.0.0 && < 1.5,- pureMD5 >= 0.2.4 && < 2.2,- base >= 4.3.0.0 && < 4.9,- split >= 0.1.3 && < 0.3,- test-framework >= 0.2.0 && < 0.9,- test-framework-hunit >= 0.3.0 && <0.4+ ghc-options: -Wall - if flag(network-uri)- Build-depends: network-uri == 2.6.*, network == 2.6.*- else- Build-depends: network >= 2.2.1.5 && < 2.6+ 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,- http-types >= 0.8.0 && < 1.0,- wai >= 2.1.0 && < 3.3,- warp >= 2.1.0 && < 3.3+ 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.0.8 && < 1.1+ build-depends: conduit < 1.1 else- build-depends:- conduit >= 1.1 && < 1.3,- conduit-extra >= 1.1 && < 1.2--+ build-depends: conduit >= 1.1, conduit-extra >= 1.1 && < 1.4
Network/Browser.hs view
@@ -4,15 +4,15 @@ Module : Network.Browser Copyright : See LICENSE file License : BSD- + 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@@ -720,12 +721,12 @@ 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@@ -735,7 +736,7 @@ 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@@ -766,7 +767,7 @@ p <- getProxy def_ua <- gets bsUserAgent let defaultOpts =- case p of + case p of NoProxy -> defaultNormalizeRequestOptions{normUserAgent=def_ua} Proxy _ ath -> defaultNormalizeRequestOptions@@ -779,11 +780,11 @@ } 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 + let notURI | null pt || null hst = URIAuth{ uriUserInfo = "" , uriRegName = str@@ -807,18 +808,18 @@ 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)@@ -886,10 +887,10 @@ False -> return (Right (uri,rsp)) _ -> do case retrieveHeaders HdrLocation rsp of- [] -> do + [] -> do err "No Location: header in redirect response" return (Right (uri,rsp))- (Header _ u:_) -> + (Header _ u:_) -> case parseURIReference u of Nothing -> do err ("Parse of Location: header in a redirect response failed: " ++ u)@@ -900,14 +901,14 @@ 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)@@ -919,10 +920,10 @@ (3,0,5) -> case retrieveHeaders HdrLocation rsp of- [] -> do + [] -> do err "No Location header in proxy redirect response." return (Right (uri,rsp))- (Header _ u:_) -> + (Header _ u:_) -> case parseURIReference u of Nothing -> do err ("Parse of Location header in a proxy redirect response failed: " ++ u)@@ -948,9 +949,9 @@ 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)) c <- liftIO $ openStream (uriRegName hst) uPort@@ -960,15 +961,15 @@ out ("Recovering connection to " ++ uriAuthToString hst) 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@@ -976,7 +977,7 @@ runBA st (evh x) return ()) (bsEvent st)- liftIO $ + liftIO $ maybe (sendHTTP_notify c r onSendComplete) (\ f -> do c' <- debugByteStream (f++'-': uriAuthToString hst) c@@ -992,12 +993,12 @@ maxPoolSize <- fromMaybe defaultMaxPoolSize <$> gets bsMaxPoolSize when (len_pool > maxPoolSize) (liftIO $ close (last pool))- let 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
@@ -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) , buf_empty = [] , buf_isLineTerm = \ b -> b == crlf || b == lf- , buf_isEmpty = null + , buf_isEmpty = null }
Network/HTTP.hs view
@@ -3,7 +3,7 @@ -- Module : Network.HTTP -- Copyright : See LICENSE file -- License : BSD--- +-- -- Maintainer : Ganesh Sittampalam <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested)@@ -27,31 +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. -- 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 +-- 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)@@ -60,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@@ -109,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 @@ -121,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@@ -134,7 +134,7 @@ -> 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@@@ -154,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@@ -165,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@@ -176,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@@ -193,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)@@ -205,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@@ -222,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@@ -244,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@@ -257,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 <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,13 +74,13 @@ 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@@ -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,10 +1,10 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Network.HTTP.Base -- Copyright : See LICENSE file -- License : BSD--- +-- -- 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,@@ -186,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 ] 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@@ -209,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 ()@@ -218,7 +222,7 @@ -- 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@@ -251,7 +255,7 @@ deriving(Eq) instance Show RequestMethod where- show x = + show x = case x of HEAD -> "HEAD" PUT -> "PUT"@@ -273,10 +277,10 @@ ("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 @@ -310,8 +314,8 @@ ++ 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 } + alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/'+ then u { uriPath = '/' : uriPath u } else u instance HasHeaders (Request a) where@@ -328,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.@@ -342,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 _) =@@ -384,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"@@ -417,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) -}@@ -468,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) @@ -491,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 @@ -507,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@@ -522,7 +526,7 @@ -- version info is represented internally. getHttpVersion :: HasHeaders a => a -> Maybe String-getHttpVersion r = +getHttpVersion r = fmap toVersion $ find isHttpVersion $ getHeaders r@@ -530,7 +534,7 @@ toVersion (Header _ x) = x setHttpVersion :: HasHeaders a => a -> String -> a-setHttpVersion r v = +setHttpVersion r v = setHeaders r $ withVersion v $ dropHttpVersion $@@ -541,7 +545,7 @@ isHttpVersion :: Header -> Bool isHttpVersion (Header (HdrCustom "X-HTTP-Version") _) = True-isHttpVersion _ = False +isHttpVersion _ = False @@ -575,9 +579,9 @@ where ans | rqst == HEAD = Done | otherwise = ExpectEntity- - ++ ----------------------------------------------------------------- ------------------ A little friendly funtionality --------------- -----------------------------------------------------------------@@ -680,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)@@ -713,19 +717,23 @@ -- | @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 = ""@@ -763,31 +771,31 @@ 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 @@ -810,18 +818,18 @@ -- | @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 + where hst = case span (/='@') user_hst of (as,'@':bs) -> case span (/=':') as of@@ -833,16 +841,16 @@ case span isDigit (reverse h) of (ds,':':bs) -> (reverse bs, ':':reverse ds) _ -> (h,"")- | otherwise -> + | 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 + (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@@ -853,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@@ -866,11 +874,11 @@ -- 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- + -- Looks for a "Connection" header with the value "close". -- Returns True when this is found. findConnClose :: [Header] -> Bool@@ -891,8 +899,8 @@ -> IO (Result a) -> [a] -> IO (Result ([Header],a))-hopefulTransfer bufOps readL strs - = readL >>= +hopefulTransfer bufOps readL strs+ = readL >>= either (\v -> return $ Left v) (\more -> if (buf_isEmpty bufOps more) then return (Right ([], buf_concat bufOps $ reverse strs))@@ -917,8 +925,8 @@ 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)@@ -936,9 +944,9 @@ _ <- 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 = + | otherwise = case readHex (buf_toStr bufOps line) of (hx,_):_ -> hx _ -> 0@@ -956,7 +964,7 @@ readTillEmpty1 bufOps readL = readL >>= either (return . Left)- (\ s -> + (\ s -> if buf_isLineTerm bufOps s then readTillEmpty1 bufOps readL else readTillEmpty2 bufOps readL [s])
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 <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,7 +118,7 @@ ) mkCookie :: String -> String -> [(String,String)] -> Cookie- mkCookie nm cval more = + mkCookie nm cval more = MkCookie { ckName = nm , ckValue = cval , ckDomain = map toLower (fromMaybe dom (lookup "domain" more))@@ -128,7 +128,7 @@ } headerToCookies _ _ acc = acc - + word, quotedstring :: Parser String
Network/HTTP/HandleStream.hs view
@@ -3,7 +3,7 @@ -- Module : Network.HTTP.HandleStream -- Copyright : See LICENSE file -- License : BSD--- +-- -- 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))@@ -138,7 +138,7 @@ -- 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 -}@@ -159,7 +159,7 @@ (rqBody rqst)) rsp <- getResponseHead conn switchResponse conn False bdy_sent rsp rqst- + Done -> do when (findConnClose hdrs) (closeOnEnd conn True)@@ -192,10 +192,10 @@ 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)) @@ -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,7 +3,7 @@ -- Module : Network.HTTP.Headers -- Copyright : See LICENSE file -- License : BSD--- +-- -- 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,14 +426,14 @@ 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) . +parseHeaders = catRslts [] .+ map (parseHeader . clean) . joinExtended "" where -- Joins consecutive lines where the second line@@ -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)@@ -106,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 <ganesh@earth.li> -- Stability : experimental -- Portability : non-portable (not tested) -- -- Handling proxy server settings and their resolution.--- +-- ----------------------------------------------------------------------------- module Network.HTTP.Proxy ( Proxy(..)@@ -47,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@@ -88,7 +94,7 @@ 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@@ -97,13 +103,19 @@ 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) @@ -160,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@@ -185,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)
Network/HTTP/Stream.hs view
@@ -3,7 +3,7 @@ -- Module : Network.HTTP.Stream -- Copyright : See LICENSE file -- License : BSD--- +-- -- 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@@ -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,8 +160,8 @@ _ <- writeBlock conn (show rqst ++ rqBody rqst) ; rsp <- getResponseHead conn ; switchResponse conn False bdy_sent rsp rqst- } - + }+ Done -> do when (findConnClose hdrs) (closeOnEnd conn True)@@ -176,11 +176,11 @@ 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)@@ -193,7 +193,7 @@ 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@@ -220,12 +220,12 @@ "chunked" -> chunkedTransfer stringBufferOp (readLine conn) (readBlock conn) _ -> uglyDeathTransfer "receiveHTTP"- + return $ do (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
Network/HTTP/Utils.hs view
@@ -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
@@ -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
@@ -13,7 +13,7 @@ -- -- * Changes by Robin Bate Boerop <robin@bateboerop.name>: -- - Created. Made minor formatting changes.--- +-- ----------------------------------------------------------------------------- module Network.StreamDebugger ( StreamDebugger@@ -26,7 +26,7 @@ ( Handle, hFlush, hPutStrLn, IOMode(AppendMode), hClose, openFile, hSetBuffering, BufferMode(NoBuffering) )-import Network.TCP ( HandleStream, HStream, +import Network.TCP ( HandleStream, HStream, StreamHooks(..), setStreamHooks, getStreamHooks ) -- | Allows stream logging. Refer to 'debugStream' below.@@ -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,7 +82,7 @@ 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}
Network/StreamSocket.hs view
@@ -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 #-} ----------------------------------------------------------------------------- -- |@@ -22,10 +23,10 @@ , openTCPConnection , socketConnection , isTCPConnectedTo- + , HandleStream , HStream(..)- + , StreamHooks(..) , nullHooks , setStreamHooks@@ -38,11 +39,13 @@ ( Socket, SocketOption(KeepAlive) , SocketType(Stream), connect , shutdown, ShutdownCmd(..)- , sClose, setSocketOption, getPeerName+ , 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@@ -59,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 )@@ -86,8 +89,8 @@ EndPoint host1 port1 == EndPoint host2 port2 = map toLower host1 == map toLower host2 && port1 == port2 -data Conn a - = MkConn { connSock :: ! Socket+data Conn a+ = MkConn { connSock :: !Socket , connHandle :: Handle , connBuffer :: BufferOp a , connInput :: Maybe a@@ -119,7 +122,7 @@ (==) _ _ = True nullHooks :: StreamHooks ty-nullHooks = StreamHooks +nullHooks = StreamHooks { hook_readLine = \ _ _ -> return () , hook_readBlock = \ _ _ _ -> return () , hook_writeBlock = \ _ _ _ -> return ()@@ -141,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)@@ -151,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@@ -175,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@@ -187,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) @@ -196,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@@ -234,16 +237,38 @@ -- 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"- (a:_) -> do- s <- socket (addrFamily a) Stream defaultProtocol- onException (do- setSocketOption s KeepAlive 1- connect s (addrAddress a)- socketConnection_ fixedUri port s stashInput- ) (sClose s) + -- 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@@ -263,7 +288,7 @@ 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@@ -295,7 +320,7 @@ suck readL hClose (connHandle conn) shutdown sk ShutdownReceive- sClose sk+ Network.Socket.close sk suck :: IO Bool -> IO () suck rd = do@@ -306,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@@ -343,7 +361,7 @@ (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@@ -383,7 +401,7 @@ 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))) @@ -396,7 +414,7 @@ modifyMVar_ (getRef ref) (\ co -> return co{connInput=Just b1}) return (return (buf_append (connBuffer conn) a newl)) _ -> catchIO- (buf_hGetLine (connBuffer conn) (connHandle conn) >>= + (buf_hGetLine (connBuffer conn) (connHandle conn) >>= return . return . appendNL (connBuffer conn)) (\ e -> if isEOFError e@@ -408,7 +426,7 @@ -- 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') @@ -418,4 +436,4 @@ case x of ConnClosed{} -> return (failWith ErrorClosed) _ -> act x- +
test/UnitTests.hs view
@@ -1,6 +1,7 @@ module UnitTests ( unitTests ) where import Network.HTTP.Base+import Network.HTTP.Headers import Network.URI import Data.Maybe ( fromJust )@@ -22,11 +23,47 @@ (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
@@ -139,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@@ -147,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@@ -453,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."@@ -520,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"