diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,10 @@ +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) diff --git a/HTTP.cabal b/HTTP.cabal --- a/HTTP.cabal +++ b/HTTP.cabal @@ -1,8 +1,8 @@ +Cabal-Version: 3.0 Name: HTTP -Version: 4000.3.16 -Cabal-Version: >= 1.10 +Version: 4000.5.0 Build-type: Simple -License: BSD3 +License: BSD-3-Clause License-file: LICENSE Author: Warrick Gray Maintainer: Ganesh Sittampalam @@ -56,16 +56,26 @@ Extra-Source-Files: CHANGES -tested-with: GHC==9.0.1, GHC==8.10.4, GHC==8.8.3, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2, GHC==7.0.4 +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 @@ -80,11 +90,8 @@ 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, @@ -103,35 +110,34 @@ 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.16, parsec >= 2.0 && < 3.2 - Build-depends: array >= 0.3.0.2 && < 0.6, bytestring >= 0.9.1.5 && < 0.12 - Build-depends: time >= 1.1.2.3 && < 1.12 + build-depends: + base >= 4.6.0.0 && < 4.22 + , array >= 0.3.0.2 && < 0.6 + , bytestring >= 0.9.1.5 && < 0.13 + , parsec >= 2.0 && < 3.2 + , time >= 1.1.2.3 && < 1.15 + , transformers >= 0.2.0.0 && < 0.7 + -- transformers-0.2.0.0 is the first to have Control.Monad.IO.Class + -- The following dependencies are refined by flags, but they should + -- still be mentioned here on the top-level. + , mtl >= 2.0.0.0 && < 2.4 + , network >= 2.6 && < 3.3 + , network-uri >= 2.6 && < 2.7 default-language: Haskell98 default-extensions: FlexibleInstances - if flag(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 && < 3.2 - else - Build-depends: network >= 2.4 && < 2.6 - if flag(warn-as-error) ghc-options: -Werror if os(windows) - Build-depends: Win32 >= 2.2.0.0 && < 2.11 + Build-depends: Win32 >= 2.2.0.0 && < 2.15 Test-Suite test type: exitcode-stdio-1.0 @@ -146,37 +152,33 @@ ghc-options: -Wall - -- note: version constraints for dependencies shared with the library - -- should be the same - build-depends: HTTP, - HUnit >= 1.2.0.1 && < 1.7, - httpd-shed >= 0.4 && < 0.5, - mtl >= 1.1.1.0 && < 2.3, - bytestring >= 0.9.1.5 && < 0.12, - deepseq >= 1.3.0.0 && < 1.5, - pureMD5 >= 0.2.4 && < 2.2, - base >= 4.3.0.0 && < 4.16, - split >= 0.1.3 && < 0.3, - test-framework >= 0.2.0 && < 0.9, - test-framework-hunit >= 0.3.0 && <0.4 - - if flag(network-uri) - Build-depends: network-uri == 2.6.*, network >= 2.6 && < 3.2 - else - Build-depends: network >= 2.3 && < 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.4 + 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.4, - conduit-extra >= 1.1 && < 1.4 + build-depends: conduit >= 1.1, conduit-extra >= 1.1 && < 1.4 diff --git a/Network/Browser.hs b/Network/Browser.hs --- a/Network/Browser.hs +++ b/Network/Browser.hs @@ -4,15 +4,15 @@ Module : Network.Browser Copyright : See LICENSE file License : BSD - + Maintainer : Ganesh Sittampalam 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 @@ -140,13 +140,14 @@ 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 @@ -209,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 }) @@ -253,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 @@ -273,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] @@ -306,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}) @@ -359,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 @@ -410,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) "} ") @@ -418,20 +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) #if MIN_VERSION_base(4,9,0) , MonadFail #endif ) -#endif runBA :: BrowserState conn -> BrowserAction conn a -> IO a runBA bs = flip evalStateT bs . unBA @@ -441,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 @@ -463,7 +456,7 @@ , bsConnectionPool = [] , bsCheckProxy = defaultAutoProxyDetect , bsProxy = noProxy - , bsDebug = Nothing + , bsDebug = Nothing , bsEvent = Nothing , bsRequestID = 0 , bsUserAgent = Nothing @@ -484,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} @@ -522,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}) @@ -550,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 = @@ -560,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 @@ -571,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. @@ -607,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 . -- setUserAgent :: String -> BrowserAction t () @@ -619,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 @@ -665,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 @@ -677,7 +670,7 @@ buildBrowserEvent :: BrowserEventType -> {-URI-}String -> RequestID -> IO BrowserEvent buildBrowserEvent bt uri reqID = do ct <- getCurrentTime - return BrowserEvent + return BrowserEvent { browserTimestamp = ct , browserRequestID = reqID , browserRequestURI = uri @@ -693,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 @@ -733,7 +726,7 @@ 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 @@ -743,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: @@ -752,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 @@ -774,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 @@ -787,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 @@ -815,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) @@ -894,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) @@ -908,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) @@ -927,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) @@ -956,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 @@ -968,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 @@ -984,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 @@ -1000,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 @@ -1095,5 +1088,4 @@ , rqURI=u } _ -> error ("unexpected request: " ++ show m) - diff --git a/Network/BufferType.hs b/Network/BufferType.hs --- a/Network/BufferType.hs +++ b/Network/BufferType.hs @@ -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 } diff --git a/Network/HTTP.hs b/Network/HTTP.hs --- a/Network/HTTP.hs +++ b/Network/HTTP.hs @@ -3,7 +3,7 @@ -- Module : Network.HTTP -- Copyright : See LICENSE file -- License : BSD --- +-- -- Maintainer : Ganesh Sittampalam -- 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) @@ -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 diff --git a/Network/HTTP/Auth.hs b/Network/HTTP/Auth.hs --- a/Network/HTTP/Auth.hs +++ b/Network/HTTP/Auth.hs @@ -4,14 +4,14 @@ -- Module : Network.HTTP.Auth -- Copyright : See LICENSE file -- License : BSD --- +-- -- Maintainer : Ganesh Sittampalam -- 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 diff --git a/Network/HTTP/Base.hs b/Network/HTTP/Base.hs --- a/Network/HTTP/Base.hs +++ b/Network/HTTP/Base.hs @@ -4,7 +4,7 @@ -- Module : Network.HTTP.Base -- Copyright : See LICENSE file -- License : BSD --- +-- -- Maintainer : Ganesh Sittampalam -- 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.Class () + 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 @@ -222,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 @@ -255,7 +255,7 @@ deriving(Eq) instance Show RequestMethod where - show x = + show x = case x of HEAD -> "HEAD" PUT -> "PUT" @@ -277,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 @@ -314,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 @@ -332,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. @@ -346,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 _) = @@ -388,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" @@ -421,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) -} @@ -472,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) @@ -495,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 @@ -511,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 @@ -526,7 +526,7 @@ -- version info is represented internally. getHttpVersion :: HasHeaders a => a -> Maybe String -getHttpVersion r = +getHttpVersion r = fmap toVersion $ find isHttpVersion $ getHeaders r @@ -534,7 +534,7 @@ toVersion (Header _ x) = x setHttpVersion :: HasHeaders a => a -> String -> a -setHttpVersion r v = +setHttpVersion r v = setHeaders r $ withVersion v $ dropHttpVersion $ @@ -545,7 +545,7 @@ isHttpVersion :: Header -> Bool isHttpVersion (Header (HdrCustom "X-HTTP-Version") _) = True -isHttpVersion _ = False +isHttpVersion _ = False @@ -579,9 +579,9 @@ where ans | rqst == HEAD = Done | otherwise = ExpectEntity - - + + ----------------------------------------------------------------- ------------------ A little friendly funtionality --------------- ----------------------------------------------------------------- @@ -684,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) @@ -722,18 +722,18 @@ #else getAuth :: Monad m => Request ty -> m URIAuthority #endif -getAuth r = +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 = "" @@ -771,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 @@ -818,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 @@ -841,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 @@ -861,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 @@ -874,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 @@ -899,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)) @@ -925,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) @@ -944,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 @@ -964,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]) diff --git a/Network/HTTP/Base64.hs b/Network/HTTP/Base64.hs --- a/Network/HTTP/Base64.hs +++ b/Network/HTTP/Base64.hs @@ -8,8 +8,8 @@ -- Stability : experimental -- Portability : portable -- --- Base64 encoding and decoding functions provided by Warwick Gray. --- See +-- Base64 encoding and decoding functions provided by Warwick Gray. +-- See -- and . -- ----------------------------------------------------------------------------- @@ -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)] diff --git a/Network/HTTP/Cookie.hs b/Network/HTTP/Cookie.hs --- a/Network/HTTP/Cookie.hs +++ b/Network/HTTP/Cookie.hs @@ -3,14 +3,14 @@ -- Module : Network.HTTP.Cookie -- Copyright : See LICENSE file -- License : BSD --- +-- -- Maintainer : Ganesh Sittampalam -- 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 diff --git a/Network/HTTP/HandleStream.hs b/Network/HTTP/HandleStream.hs --- a/Network/HTTP/HandleStream.hs +++ b/Network/HTTP/HandleStream.hs @@ -3,7 +3,7 @@ -- Module : Network.HTTP.HandleStream -- Copyright : See LICENSE file -- License : BSD --- +-- -- Maintainer : Ganesh Sittampalam -- 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 diff --git a/Network/HTTP/Headers.hs b/Network/HTTP/Headers.hs --- a/Network/HTTP/Headers.hs +++ b/Network/HTTP/Headers.hs @@ -3,7 +3,7 @@ -- Module : Network.HTTP.Headers -- Copyright : See LICENSE file -- License : BSD --- +-- -- Maintainer : Ganesh Sittampalam -- 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 @@ -287,7 +287,7 @@ HdrContentTransferEncoding == _ = False _ == HdrContentTransferEncoding = False --- | @headerMap@ is a straight assoc list for translating between header names +-- | @headerMap@ is a straight assoc list for translating between header names -- and values. headerMap :: [ (String,HeaderName) ] headerMap = @@ -382,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 @@ -397,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. @@ -408,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 @@ -426,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 @@ -454,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 diff --git a/Network/HTTP/MD5Aux.hs b/Network/HTTP/MD5Aux.hs --- a/Network/HTTP/MD5Aux.hs +++ b/Network/HTTP/MD5Aux.hs @@ -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 diff --git a/Network/HTTP/Proxy.hs b/Network/HTTP/Proxy.hs --- a/Network/HTTP/Proxy.hs +++ b/Network/HTTP/Proxy.hs @@ -4,13 +4,13 @@ -- Module : Network.HTTP.Proxy -- Copyright : See LICENSE file -- License : BSD --- +-- -- Maintainer : Ganesh Sittampalam -- Stability : experimental -- Portability : non-portable (not tested) -- -- Handling proxy server settings and their resolution. --- +-- ----------------------------------------------------------------------------- module Network.HTTP.Proxy ( Proxy(..) @@ -60,7 +60,7 @@ -- | 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 @@ -94,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 @@ -103,7 +103,7 @@ 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 @@ -198,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) diff --git a/Network/HTTP/Stream.hs b/Network/HTTP/Stream.hs --- a/Network/HTTP/Stream.hs +++ b/Network/HTTP/Stream.hs @@ -3,7 +3,7 @@ -- Module : Network.HTTP.Stream -- Copyright : See LICENSE file -- License : BSD --- +-- -- Maintainer : Ganesh Sittampalam -- 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 diff --git a/Network/HTTP/Utils.hs b/Network/HTTP/Utils.hs --- a/Network/HTTP/Utils.hs +++ b/Network/HTTP/Utils.hs @@ -14,23 +14,23 @@ ( 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 ) @@ -62,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 @@ -74,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 @@ -90,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 diff --git a/Network/Stream.hs b/Network/Stream.hs --- a/Network/Stream.hs +++ b/Network/Stream.hs @@ -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 ()) diff --git a/Network/StreamDebugger.hs b/Network/StreamDebugger.hs --- a/Network/StreamDebugger.hs +++ b/Network/StreamDebugger.hs @@ -13,7 +13,7 @@ -- -- * Changes by Robin Bate Boerop : -- - 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} diff --git a/Network/StreamSocket.hs b/Network/StreamSocket.hs --- a/Network/StreamSocket.hs +++ b/Network/StreamSocket.hs @@ -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 @@ -77,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) @@ -88,7 +88,7 @@ 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 diff --git a/Network/TCP.hs b/Network/TCP.hs --- a/Network/TCP.hs +++ b/Network/TCP.hs @@ -23,10 +23,10 @@ , openTCPConnection , socketConnection , isTCPConnectedTo - + , HandleStream , HStream(..) - + , StreamHooks(..) , nullHooks , setStreamHooks @@ -89,7 +89,7 @@ EndPoint host1 port1 == EndPoint host2 port2 = map toLower host1 == map toLower host2 && port1 == port2 -data Conn a +data Conn a = MkConn { connSock :: !Socket , connHandle :: Handle , connBuffer :: BufferOp a @@ -122,7 +122,7 @@ (==) _ _ = True nullHooks :: StreamHooks ty -nullHooks = StreamHooks +nullHooks = StreamHooks { hook_readLine = \ _ _ -> return () , hook_readBlock = \ _ _ _ -> return () , hook_writeBlock = \ _ _ _ -> return () @@ -144,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) @@ -154,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 @@ -178,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 @@ -190,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) @@ -199,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 @@ -288,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 @@ -338,7 +338,7 @@ 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 @@ -361,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 @@ -401,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))) @@ -414,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 @@ -426,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') @@ -436,4 +436,4 @@ case x of ConnClosed{} -> return (failWith ErrorClosed) _ -> act x - + diff --git a/test/httpTests.hs b/test/httpTests.hs --- a/test/httpTests.hs +++ b/test/httpTests.hs @@ -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"