Hello community, here is the log from the commit of package ghc-HTTP for openSUSE:Factory checked in at 2015-12-01 09:19:28 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-HTTP (Old) and /work/SRC/openSUSE:Factory/.ghc-HTTP.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-HTTP" Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-HTTP/ghc-HTTP.changes 2015-06-30 10:18:58.000000000 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-HTTP.new/ghc-HTTP.changes 2015-12-01 09:19:31.000000000 +0100 @@ -1,0 +2,5 @@ +Sun Nov 29 17:14:52 UTC 2015 - [email protected] + +- update to 4000.2.21 + +------------------------------------------------------------------- Old: ---- HTTP-4000.2.20.tar.gz New: ---- HTTP-4000.2.21.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-HTTP.spec ++++++ --- /var/tmp/diff_new_pack.Vb9Rb2/_old 2015-12-01 09:19:32.000000000 +0100 +++ /var/tmp/diff_new_pack.Vb9Rb2/_new 2015-12-01 09:19:32.000000000 +0100 @@ -19,7 +19,7 @@ %global pkg_name HTTP Name: ghc-HTTP -Version: 4000.2.20 +Version: 4000.2.21 Release: 0 Summary: A library for client-side HTTP License: BSD-3-Clause ++++++ HTTP-4000.2.20.tar.gz -> HTTP-4000.2.21.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.20/HTTP.cabal new/HTTP-4000.2.21/HTTP.cabal --- old/HTTP-4000.2.20/HTTP.cabal 2015-06-21 19:17:52.000000000 +0200 +++ new/HTTP-4000.2.21/HTTP.cabal 2015-11-23 19:59:29.000000000 +0100 @@ -1,5 +1,5 @@ Name: HTTP -Version: 4000.2.20 +Version: 4000.2.21 Cabal-Version: >= 1.8 Build-type: Simple License: BSD3 @@ -9,9 +9,9 @@ Homepage: https://github.com/haskell/HTTP Category: Network Synopsis: A library for client-side HTTP -Description: +Description: - The HTTP package supports client-side web programming in Haskell. It lets you set up + The HTTP package supports client-side web programming in Haskell. It lets you set up HTTP connections, transmitting requests and processing the responses coming back, all from within the comforts of Haskell. It's dependent on the network package to operate, but other than that, the implementation is all written in Haskell. @@ -74,12 +74,12 @@ default: True Library - Exposed-modules: + Exposed-modules: Network.BufferType, Network.Stream, Network.StreamDebugger, Network.StreamSocket, - Network.TCP, + Network.TCP, Network.HTTP, Network.HTTP.Headers, Network.HTTP.Base, @@ -112,7 +112,7 @@ 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: network >= 2.2.1.8 && < 2.6 build-tools: ghc >= 7.0 && < 7.12 @@ -137,7 +137,7 @@ -- note: version constraints for dependencies shared with the library -- should be the same build-depends: HTTP, - HUnit >= 1.2.0.1 && < 1.3, + 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, diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.20/Network/Browser.hs new/HTTP-4000.2.21/Network/Browser.hs --- old/HTTP-4000.2.20/Network/Browser.hs 2015-06-21 19:17:52.000000000 +0200 +++ new/HTTP-4000.2.21/Network/Browser.hs 2015-11-23 19:59:29.000000000 +0100 @@ -711,7 +711,7 @@ -- is returned along with the 'Response' itself. request :: HStream ty => Request ty - -> BrowserAction (HandleStream ty) (URI,Response ty) + -> BrowserAction (HandleStream ty) (URI,Response ty) request req = nextRequest $ do res <- request' nullVal initialState req reportEvent ResponseFinish (show (rqURI req)) @@ -729,9 +729,9 @@ -- counts. request' :: HStream ty => ty - -> RequestState - -> Request ty - -> BrowserAction (HandleStream ty) (Result (URI,Response ty)) + -> RequestState + -> Request ty + -> BrowserAction (HandleStream ty) (Result (URI,Response ty)) request' nullVal rqState rq = do let uri = rqURI rq failHTTPS uri @@ -765,18 +765,18 @@ let rq'' = if not $ null cookies then insertHeaders [cookiesToHeader cookies] rq' else rq' p <- getProxy def_ua <- gets bsUserAgent - let defaultOpts = + let defaultOpts = case p of - NoProxy -> defaultNormalizeRequestOptions{normUserAgent=def_ua} - Proxy _ ath -> - defaultNormalizeRequestOptions - { normForProxy = True - , normUserAgent = def_ua - , normCustoms = - maybe [] - (\ authS -> [\ _ r -> insertHeader HdrProxyAuthorization (withAuthority authS r) r]) - ath - } + NoProxy -> defaultNormalizeRequestOptions{normUserAgent=def_ua} + Proxy _ ath -> + defaultNormalizeRequestOptions + { normForProxy = True + , normUserAgent = def_ua + , normCustoms = + maybe [] + (\ authS -> [\ _ r -> insertHeader HdrProxyAuthorization (withAuthority authS r) r]) + ath + } let final_req = normalizeRequest defaultOpts rq'' out ("Sending:\n" ++ show final_req) e_rsp <- @@ -784,16 +784,16 @@ NoProxy -> dorequest (reqURIAuth rq'') final_req Proxy str _ath -> do let notURI - | null pt || null hst = - URIAuth{ uriUserInfo = "" - , uriRegName = str - , uriPort = "" - } - | otherwise = - URIAuth{ uriUserInfo = "" - , uriRegName = hst - , uriPort = pt - } + | null pt || null hst = + URIAuth{ uriUserInfo = "" + , uriRegName = str + , uriPort = "" + } + | otherwise = + URIAuth{ uriUserInfo = "" + , uriRegName = hst + , uriPort = pt + } -- If the ':' is dropped from port below, dorequest will assume port 80. Leave it! where (hst, pt) = span (':'/=) str -- Proxy can take multiple forms - look for http://host:port first, @@ -804,7 +804,7 @@ (parseURI str) out $ "proxy uri host: " ++ uriRegName proxyURIAuth ++ ", port: " ++ uriPort proxyURIAuth - dorequest proxyURIAuth final_req + dorequest proxyURIAuth final_req mbMx <- getMaxErrorRetries case e_rsp of Left v @@ -827,27 +827,27 @@ (4,0,1) -- Credentials not sent or refused. | reqDenies rqState > fromMaybe defaultMaxAuthAttempts mbMxAuths -> do out "401 - credentials again refused; exceeded retry count (2)" - return (Right (uri,rsp)) - | otherwise -> do + return (Right (uri,rsp)) + | otherwise -> do out "401 - credentials not supplied or refused; retrying.." let hdrs = retrieveHeaders HdrWWWAuthenticate rsp - flg <- getAllowBasicAuth + flg <- getAllowBasicAuth case pickChallenge flg (catMaybes $ map (headerToChallenge uri) hdrs) of Nothing -> do - out "no challenge" - return (Right (uri,rsp)) {- do nothing -} + out "no challenge" + return (Right (uri,rsp)) {- do nothing -} Just x -> do au <- challengeToAuthority uri x case au of Nothing -> do - out "no auth" - return (Right (uri,rsp)) {- do nothing -} + out "no auth" + return (Right (uri,rsp)) {- do nothing -} Just au' -> do out "Retrying request with new credentials" - request' nullVal - rqState{ reqDenies = succ(reqDenies rqState) - , reqStopOnDeny = False - } + request' nullVal + rqState{ reqDenies = succ(reqDenies rqState) + , reqStopOnDeny = False + } (insertHeader HdrAuthorization (withAuthority au' rq) rq) (4,0,7) -- Proxy Authentication required @@ -857,7 +857,7 @@ | otherwise -> do out "407 - proxy authentication required" let hdrs = retrieveHeaders HdrProxyAuthenticate rsp - flg <- getAllowBasicAuth + flg <- getAllowBasicAuth case pickChallenge flg (catMaybes $ map (headerToChallenge uri) hdrs) of Nothing -> return (Right (uri,rsp)) {- do nothing -} Just x -> do @@ -874,32 +874,32 @@ out "Retrying with proxy authentication" setProxy (Proxy px (Just au')) request' nullVal - rqState{ reqDenies = succ(reqDenies rqState) - , reqStopOnDeny = False - } - rq + rqState{ reqDenies = succ(reqDenies rqState) + , reqStopOnDeny = False + } + rq (3,0,x) | x `elem` [2,3,1,7] -> do out ("30" ++ show x ++ " - redirect") - allow_redirs <- allowRedirect rqState - case allow_redirs of - False -> return (Right (uri,rsp)) - _ -> do + allow_redirs <- allowRedirect rqState + case allow_redirs of + False -> return (Right (uri,rsp)) + _ -> do case retrieveHeaders HdrLocation rsp of [] -> do - err "No Location: header in redirect response" + err "No Location: header in redirect response" return (Right (uri,rsp)) (Header _ u:_) -> - case parseURIReference u of + case parseURIReference u of Nothing -> do err ("Parse of Location: header in a redirect response failed: " ++ u) return (Right (uri,rsp)) Just newURI - | {-uriScheme newURI_abs /= uriScheme uri && -}(not (supportedScheme newURI_abs)) -> do - err ("Unable to handle redirect, unsupported scheme: " ++ show newURI_abs) - return (Right (uri, rsp)) - | otherwise -> do - out ("Redirecting to " ++ show newURI_abs ++ " ...") + | {-uriScheme newURI_abs /= uriScheme uri && -}(not (supportedScheme newURI_abs)) -> do + err ("Unable to handle redirect, unsupported scheme: " ++ show newURI_abs) + return (Right (uri, rsp)) + | otherwise -> do + out ("Redirecting to " ++ show newURI_abs ++ " ...") -- Redirect using GET request method, depending on -- response code. @@ -909,10 +909,10 @@ rq2 = if toGet then (replaceHeader HdrContentLength "0") (rq1 {rqBody = nullVal}) else rq1 request' nullVal - rqState{ reqDenies = 0 - , reqRedirects = succ(reqRedirects rqState) - , reqStopOnDeny = True - } + rqState{ reqDenies = 0 + , reqRedirects = succ(reqRedirects rqState) + , reqStopOnDeny = True + } rq2 where newURI_abs = uriDefaultTo newURI uri @@ -920,10 +920,10 @@ (3,0,5) -> case retrieveHeaders HdrLocation rsp of [] -> do - err "No Location header in proxy redirect response." + err "No Location header in proxy redirect response." return (Right (uri,rsp)) (Header _ u:_) -> - case parseURIReference u of + case parseURIReference u of Nothing -> do err ("Parse of Location header in a proxy redirect response failed: " ++ u) return (Right (uri,rsp)) @@ -931,19 +931,19 @@ out ("Retrying with proxy " ++ show newuri ++ "...") setProxy (Proxy (uriToAuthorityString newuri) Nothing) request' nullVal rqState{ reqDenies = 0 - , reqRedirects = 0 - , reqRetries = succ (reqRetries rqState) - , reqStopOnDeny = True - } - rq + , reqRedirects = 0 + , reqRetries = succ (reqRetries rqState) + , reqStopOnDeny = True + } + rq _ -> return (Right (uri,rsp)) -- | The internal request handling state machine. dorequest :: (HStream ty) => URIAuth - -> Request ty - -> BrowserAction (HandleStream ty) - (Result (Response ty)) + -> Request ty + -> BrowserAction (HandleStream ty) + (Result (Response ty)) dorequest hst rqst = do pool <- gets bsConnectionPool let uPort = uriAuthPort Nothing{-ToDo: feed in complete URL-} hst @@ -952,13 +952,13 @@ case conn of [] -> do out ("Creating new connection to " ++ uriAuthToString hst) - reportEvent OpenConnection (show (rqURI rqst)) + reportEvent OpenConnection (show (rqURI rqst)) c <- liftIO $ openStream (uriRegName hst) uPort - updateConnectionPool c - dorequest2 c rqst + updateConnectionPool c + dorequest2 c rqst (c:_) -> do out ("Recovering connection to " ++ uriAuthToString hst) - reportEvent ReuseConnection (show (rqURI rqst)) + reportEvent ReuseConnection (show (rqURI rqst)) dorequest2 c rqst case rsp of Right (Response a b c _) -> @@ -972,20 +972,20 @@ onSendComplete = maybe (return ()) (\evh -> do - x <- buildBrowserEvent RequestSent (show (rqURI r)) (bsRequestID st) - runBA st (evh x) - return ()) + x <- buildBrowserEvent RequestSent (show (rqURI r)) (bsRequestID st) + runBA st (evh x) + return ()) (bsEvent st) liftIO $ maybe (sendHTTP_notify c r onSendComplete) (\ f -> do c' <- debugByteStream (f++'-': uriAuthToString hst) c - sendHTTP_notify c' r onSendComplete) - dbg + sendHTTP_notify c' r onSendComplete) + dbg updateConnectionPool :: HStream hTy => HandleStream hTy - -> BrowserAction (HandleStream hTy) () + -> BrowserAction (HandleStream hTy) () updateConnectionPool c = do pool <- gets bsConnectionPool let len_pool = length pool @@ -993,8 +993,8 @@ when (len_pool > maxPoolSize) (liftIO $ close (last pool)) let pool' - | len_pool > maxPoolSize = init pool - | otherwise = pool + | len_pool > maxPoolSize = init pool + | otherwise = pool when (maxPoolSize > 0) $ modify (\b -> b { bsConnectionPool=c:pool' }) return () diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.20/Network/BufferType.hs new/HTTP-4000.2.21/Network/BufferType.hs --- old/HTTP-4000.2.20/Network/BufferType.hs 2015-06-21 19:17:52.000000000 +0200 +++ new/HTTP-4000.2.21/Network/BufferType.hs 2015-11-23 19:59:29.000000000 +0100 @@ -156,7 +156,7 @@ , buf_splitAt = splitAt , buf_span = \ p a -> case Strict.span p (Strict.pack a) of - (x,y) -> (Strict.unpack x, Strict.unpack y) + (x,y) -> (Strict.unpack x, Strict.unpack y) , buf_empty = [] , buf_isLineTerm = \ b -> b == crlf || b == lf , buf_isEmpty = null diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.20/Network/HTTP/Auth.hs new/HTTP-4000.2.21/Network/HTTP/Auth.hs --- old/HTTP-4000.2.20/Network/HTTP/Auth.hs 2015-06-21 19:17:52.000000000 +0200 +++ new/HTTP-4000.2.21/Network/HTTP/Auth.hs 2015-11-23 19:59:29.000000000 +0100 @@ -87,16 +87,16 @@ AuthBasic{} -> "Basic " ++ base64encode (auUsername a ++ ':' : auPassword a) AuthDigest{} -> "Digest " ++ - concat [ "username=" ++ quo (auUsername a) - , ",realm=" ++ quo (auRealm a) - , ",nonce=" ++ quo (auNonce a) - , ",uri=" ++ quo digesturi - , ",response=" ++ quo rspdigest + concat [ "username=" ++ quo (auUsername a) + , ",realm=" ++ quo (auRealm a) + , ",nonce=" ++ quo (auNonce a) + , ",uri=" ++ quo digesturi + , ",response=" ++ quo rspdigest -- plus optional stuff: - , fromMaybe "" (fmap (\ alg -> ",algorithm=" ++ quo (show alg)) (auAlgorithm a)) - , fromMaybe "" (fmap (\ o -> ",opaque=" ++ quo o) (auOpaque a)) - , if null (auQop a) then "" else ",qop=auth" - ] + , fromMaybe "" (fmap (\ alg -> ",algorithm=" ++ quo (show alg)) (auAlgorithm a)) + , fromMaybe "" (fmap (\ o -> ",opaque=" ++ quo o) (auOpaque a)) + , if null (auQop a) then "" else ",qop=auth" + ] where quo s = '"':s ++ "\"" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.20/Network/HTTP/Base.hs new/HTTP-4000.2.21/Network/HTTP/Base.hs --- old/HTTP-4000.2.20/Network/HTTP/Base.hs 2015-06-21 19:17:52.000000000 +0200 +++ new/HTTP-4000.2.21/Network/HTTP/Base.hs 2015-11-23 19:59:29.000000000 +0100 @@ -135,11 +135,11 @@ ------------------ URI Authority parsing ------------------------ ----------------------------------------------------------------- -data URIAuthority = URIAuthority { user :: Maybe String, - password :: Maybe String, - host :: String, - port :: Maybe Int - } deriving (Eq,Show) +data URIAuthority = URIAuthority { user :: Maybe String, + password :: Maybe String, + host :: String, + port :: Maybe Int + } deriving (Eq,Show) -- | Parse the authority part of a URL. -- @@ -154,12 +154,12 @@ pURIAuthority :: ReadP URIAuthority pURIAuthority = do - (u,pw) <- (pUserInfo `before` char '@') - <++ return (Nothing, Nothing) - h <- rfc2732host <++ munch (/=':') - p <- orNothing (char ':' >> readDecP) - look >>= guard . null - return URIAuthority{ user=u, password=pw, host=h, port=p } + (u,pw) <- (pUserInfo `before` char '@') + <++ return (Nothing, Nothing) + h <- rfc2732host <++ munch (/=':') + p <- orNothing (char ':' >> readDecP) + look >>= guard . null + return URIAuthority{ user=u, password=pw, host=h, port=p } -- RFC2732 adds support for '[literal-ipv6-address]' in the host part of a URL rfc2732host :: ReadP String @@ -171,9 +171,9 @@ pUserInfo :: ReadP (Maybe String, Maybe String) pUserInfo = do - u <- orNothing (munch (`notElem` ":@")) - p <- orNothing (char ':' >> munch (/='@')) - return (u,p) + u <- orNothing (munch (`notElem` ":@")) + p <- orNothing (char ':' >> munch (/='@')) + return (u,p) before :: Monad m => m a -> m b -> m a before a b = a >>= \x -> b >> return x @@ -189,8 +189,8 @@ uriAuthToString ua = concat [ uriUserInfo ua , uriRegName ua - , uriPort ua - ] + , uriPort ua + ] uriAuthPort :: Maybe URI -> URIAuth -> Int uriAuthPort mbURI u = @@ -223,12 +223,12 @@ Just ua -> ua _ -> case lookupHeader HdrHost (rqHeaders req) of Nothing -> error ("reqURIAuth: no URI authority for: " ++ show req) - Just h -> - case toHostPort h of - (ht,p) -> URIAuth { uriUserInfo = "" - , uriRegName = ht - , uriPort = p - } + Just h -> + case toHostPort h of + (ht,p) -> URIAuth { uriUserInfo = "" + , uriRegName = ht + , uriPort = p + } where -- Note: just in case you're wondering..the convention is to include the ':' -- in the port part.. @@ -265,13 +265,13 @@ rqMethodMap :: [(String, RequestMethod)] rqMethodMap = [("HEAD", HEAD), - ("PUT", PUT), - ("GET", GET), - ("POST", POST), + ("PUT", PUT), + ("GET", GET), + ("POST", POST), ("DELETE", DELETE), - ("OPTIONS", OPTIONS), - ("TRACE", TRACE), - ("CONNECT", CONNECT)] + ("OPTIONS", OPTIONS), + ("TRACE", TRACE), + ("CONNECT", CONNECT)] -- -- for backwards-ish compatibility; suggest @@ -309,7 +309,7 @@ show m ++ sp ++ alt_uri ++ sp ++ ver ++ crlf ++ foldr (++) [] (map show (dropHttpVersion h)) ++ crlf where - ver = fromMaybe httpVersion (getRequestVersion req) + ver = fromMaybe httpVersion (getRequestVersion req) alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/' then u { uriPath = '/' : uriPath u } else u @@ -730,7 +730,7 @@ insertHeaderIfMissing HdrHost h $ r { rqURI = (rqURI r){ uriScheme = "" , uriAuthority = Nothing - }} + }} -- | @NormalizeRequestOptions@ brings together the various defaulting\/normalization options -- over 'Request's. Use 'defaultNormalizeRequestOptions' for the standard selection of option @@ -759,7 +759,7 @@ -- via the @NormalizeRequestOptions@ record. normalizeRequest :: NormalizeRequestOptions ty -> Request ty - -> Request ty + -> Request ty normalizeRequest opts req = foldr (\ f -> f opts) req normalizers where --normalizers :: [RequestNormalizer ty] @@ -817,26 +817,26 @@ ("",_uri_abs) | 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 - }} + Nothing -> req -- no host/authority in sight..not much we can do. + Just h -> req{rqURI=uri{ uriAuthority=Just URIAuth{uriUserInfo="", uriRegName=hst, uriPort=pNum} + , uriScheme=if (null (uriScheme uri)) then "http" else uriScheme uri + }} where - hst = case span (/='@') user_hst of - (as,'@':bs) -> - case span (/=':') as of - (_,_:_) -> bs - _ -> user_hst - _ -> user_hst - - (user_hst, pNum) = - case span isDigit (reverse h) of - (ds,':':bs) -> (reverse bs, ':':reverse ds) - _ -> (h,"") + hst = case span (/='@') user_hst of + (as,'@':bs) -> + case span (/=':') as of + (_,_:_) -> bs + _ -> user_hst + _ -> user_hst + + (user_hst, pNum) = + case span isDigit (reverse h) of + (ds,':':bs) -> (reverse bs, ':':reverse ds) + _ -> (h,"") | otherwise -> case findHeader HdrHost req of - Nothing -> req -- no host/authority in sight..not much we can do...complain? - Just{} -> req + Nothing -> req -- no host/authority in sight..not much we can do...complain? + Just{} -> req (h,uri_abs) | forProxy -> insertHeaderIfMissing HdrHost h req | otherwise -> replaceHeader HdrHost h req{rqURI=uri_abs} -- Note: _not_ stubbing out user:pass @@ -869,7 +869,7 @@ normalizeHostHeader rq = insertHeaderIfMissing HdrHost (uriToAuthorityString $ rqURI rq) - rq + rq -- Looks for a "Connection" header with the value "close". -- Returns True when this is found. @@ -877,7 +877,7 @@ findConnClose hdrs = maybe False (\ x -> map toLower (trim x) == "close") - (lookupHeader HdrConnection hdrs) + (lookupHeader HdrConnection hdrs) -- | Used when we know exactly how many bytes to expect. linearTransfer :: (Int -> IO (Result a)) -> Int -> IO (Result ([Header],a)) @@ -889,8 +889,8 @@ -- take data once and give up the rest. hopefulTransfer :: BufferOp a -> IO (Result a) - -> [a] - -> IO (Result ([Header],a)) + -> [a] + -> IO (Result ([Header],a)) hopefulTransfer bufOps readL strs = readL >>= either (\v -> return $ Left v) @@ -902,7 +902,7 @@ -- Also the only transfer variety likely to -- return any footers. chunkedTransfer :: BufferOp a - -> IO (Result a) + -> IO (Result a) -> (Int -> IO (Result a)) -> IO (Result ([Header], a)) chunkedTransfer bufOps readL readBlk = chunkedTransferC bufOps readL readBlk [] 0 @@ -910,9 +910,9 @@ chunkedTransferC :: BufferOp a -> IO (Result a) -> (Int -> IO (Result a)) - -> [a] - -> Int - -> IO (Result ([Header], a)) + -> [a] + -> Int + -> IO (Result ([Header], a)) chunkedTransferC bufOps readL readBlk acc n = do v <- readL case v of @@ -921,25 +921,25 @@ | size == 0 -> -- last chunk read; look for trailing headers.. fmapE (\ strs -> do - ftrs <- parseHeaders (map (buf_toStr bufOps) strs) - -- insert (computed) Content-Length header. - let ftrs' = Header HdrContentLength (show n) : ftrs + ftrs <- parseHeaders (map (buf_toStr bufOps) strs) + -- insert (computed) Content-Length header. + let ftrs' = Header HdrContentLength (show n) : ftrs return (ftrs',buf_concat bufOps (reverse acc))) - (readTillEmpty2 bufOps readL []) + (readTillEmpty2 bufOps readL []) | otherwise -> do some <- readBlk size - case some of - Left e -> return (Left e) - Right cdata -> do - _ <- readL -- CRLF is mandated after the chunk block; ToDo: check that the line is empty.? - chunkedTransferC bufOps readL readBlk (cdata:acc) (n+size) + case some of + Left e -> return (Left e) + Right cdata -> do + _ <- readL -- CRLF is mandated after the chunk block; ToDo: check that the line is empty.? + chunkedTransferC bufOps readL readBlk (cdata:acc) (n+size) where size | buf_isEmpty bufOps line = 0 | otherwise = - case readHex (buf_toStr bufOps line) of + case readHex (buf_toStr bufOps line) of (hx,_):_ -> hx _ -> 0 @@ -951,13 +951,13 @@ -- | Remove leading crlfs then call readTillEmpty2 (not required by RFC) readTillEmpty1 :: BufferOp a - -> IO (Result a) + -> IO (Result a) -> IO (Result [a]) readTillEmpty1 bufOps readL = readL >>= either (return . Left) (\ s -> - if buf_isLineTerm bufOps s + if buf_isLineTerm bufOps s then readTillEmpty1 bufOps readL else readTillEmpty2 bufOps readL [s]) @@ -967,14 +967,14 @@ -- thing to do - so probably indicates an -- error condition. readTillEmpty2 :: BufferOp a - -> IO (Result a) - -> [a] - -> IO (Result [a]) + -> IO (Result a) + -> [a] + -> IO (Result [a]) readTillEmpty2 bufOps readL list = readL >>= either (return . Left) (\ s -> - if buf_isLineTerm bufOps s || buf_isEmpty bufOps s + if buf_isLineTerm bufOps s || buf_isEmpty bufOps s then return (Right $ reverse (s:list)) else readTillEmpty2 bufOps readL (s:list)) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.20/Network/HTTP/Cookie.hs new/HTTP-4000.2.21/Network/HTTP/Cookie.hs --- old/HTTP-4000.2.20/Network/HTTP/Cookie.hs 2015-06-21 19:17:52.000000000 +0200 +++ new/HTTP-4000.2.21/Network/HTTP/Cookie.hs 2015-11-23 19:59:29.000000000 +0100 @@ -119,7 +119,7 @@ mkCookie :: String -> String -> [(String,String)] -> Cookie mkCookie nm cval more = - MkCookie { ckName = nm + MkCookie { ckName = nm , ckValue = cval , ckDomain = map toLower (fromMaybe dom (lookup "domain" more)) , ckPath = lookup "path" more diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.20/Network/HTTP/HandleStream.hs new/HTTP-4000.2.21/Network/HTTP/HandleStream.hs --- old/HTTP-4000.2.20/Network/HTTP/HandleStream.hs 2015-06-21 19:17:52.000000000 +0200 +++ new/HTTP-4000.2.21/Network/HTTP/HandleStream.hs 2015-11-23 19:59:29.000000000 +0100 @@ -84,9 +84,9 @@ -- request transmission and its performance. sendHTTP_notify :: HStream ty => HandleStream ty - -> Request ty - -> IO () - -> IO (Result (Response ty)) + -> Request ty + -> IO () + -> IO (Result (Response ty)) sendHTTP_notify conn rq onSendComplete = do when providedClose $ (closeOnEnd conn True) onException (sendMain conn rq onSendComplete) @@ -106,9 +106,9 @@ -- Since we would wait forever, I have disabled use of 100-continue for now. sendMain :: HStream ty => HandleStream ty - -> Request ty - -> (IO ()) - -> IO (Result (Response ty)) + -> Request ty + -> (IO ()) + -> IO (Result (Response ty)) sendMain conn rqst onSendComplete = do --let str = if null (rqBody rqst) -- then show rqst @@ -128,7 +128,7 @@ switchResponse :: HStream ty => HandleStream ty - -> Bool {- allow retry? -} + -> Bool {- allow retry? -} -> Bool {- is body sent? -} -> Result ResponseData -> Request ty @@ -143,7 +143,7 @@ Continue | not bdy_sent -> do {- Time to send the body -} writeBlock conn (rqBody rqst) >>= either (return . Left) - (\ _ -> do + (\ _ -> do rsp <- getResponseHead conn switchResponse conn allow_retry True rsp rqst) | otherwise -> do {- keep waiting -} @@ -155,8 +155,8 @@ other than "100-Continue" -} -- TODO review throwing away of result _ <- writeBlock conn ((buf_append bufferOps) - (buf_fromStr bufferOps (show rqst)) - (rqBody rqst)) + (buf_fromStr bufferOps (show rqst)) + (rqBody rqst)) rsp <- getResponseHead conn switchResponse conn False bdy_sent rsp rqst @@ -171,22 +171,22 @@ ExpectEntity -> do r <- fmapE (\ (ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy)) $ maybe (maybe (hopefulTransfer bo (readLine conn) []) - (\ x -> - readsOne (linearTransfer (readBlock conn)) - (return$responseParseError "unrecognized content-length value" x) - x) - cl) - (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn)) - (uglyDeathTransfer "sendHTTP")) + (\ x -> + readsOne (linearTransfer (readBlock conn)) + (return$responseParseError "unrecognized content-length value" x) + x) + cl) + (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn)) + (uglyDeathTransfer "sendHTTP")) tc case r of Left{} -> do - close conn - return r - Right (Response _ _ hs _) -> do - when (findConnClose hs) + close conn + return r + Right (Response _ _ hs _) -> do + when (findConnClose hs) (closeOnEnd conn True) - return r + return r where tc = lookupHeader HdrTransferEncoding hdrs @@ -208,18 +208,18 @@ getRequestHead = do fmapE (\es -> parseRequestHead (map (buf_toStr bufferOps) es)) (readTillEmpty1 bufferOps (readLine conn)) - + processRequest (rm,uri,hdrs) = fmapE (\ (ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy)) $ - maybe - (maybe (return (Right ([], buf_empty bo))) -- hopefulTransfer "" - (\ x -> readsOne (linearTransfer (readBlock conn)) - (return$responseParseError "unrecognized Content-Length value" x) - x) - - cl) - (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn)) - (uglyDeathTransfer "receiveHTTP")) + maybe + (maybe (return (Right ([], buf_empty bo))) -- hopefulTransfer "" + (\ x -> readsOne (linearTransfer (readBlock conn)) + (return$responseParseError "unrecognized Content-Length value" x) + x) + + cl) + (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn)) + (uglyDeathTransfer "receiveHTTP")) tc where -- FIXME : Also handle 100-continue. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.20/Network/HTTP/Headers.hs new/HTTP-4000.2.21/Network/HTTP/Headers.hs --- old/HTTP-4000.2.20/Network/HTTP/Headers.hs 2015-06-21 19:17:52.000000000 +0200 +++ new/HTTP-4000.2.21/Network/HTTP/Headers.hs 2015-11-23 19:59:29.000000000 +0100 @@ -279,17 +279,17 @@ parseHeaders :: [String] -> Result [Header] parseHeaders = catRslts [] . map (parseHeader . clean) . - joinExtended "" + joinExtended "" where -- Joins consecutive lines where the second line -- begins with ' ' or '\t'. joinExtended old [] = [old] joinExtended old (h : t) - | isLineExtension h = joinExtended (old ++ ' ' : tail h) t + | isLineExtension h = joinExtended (old ++ ' ' : tail h) t | otherwise = old : joinExtended h t - - isLineExtension (x:_) = x == ' ' || x == '\t' - isLineExtension _ = False + + isLineExtension (x:_) = x == ' ' || x == '\t' + isLineExtension _ = False clean [] = [] clean (h:t) | h `elem` "\t\r\n" = ' ' : clean t diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.20/Network/HTTP/MD5Aux.hs new/HTTP-4000.2.21/Network/HTTP/MD5Aux.hs --- old/HTTP-4000.2.20/Network/HTTP/MD5Aux.hs 2015-06-21 19:17:52.000000000 +0200 +++ new/HTTP-4000.2.21/Network/HTTP/MD5Aux.hs 2015-11-23 19:59:29.000000000 +0100 @@ -91,6 +91,7 @@ instance Num ABCD where ABCD (a1, b1, c1, d1) + ABCD (a2, b2, c2, d2) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2) + (-) = error "(-){ABCD}: no instance method defined" (*) = error "(*){ABCD}: no instance method defined" signum = error "signum{ABCD}: no instance method defined" fromInteger = error "fromInteger{ABCD}: no instance method defined" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.20/Network/HTTP/Proxy.hs new/HTTP-4000.2.21/Network/HTTP/Proxy.hs --- old/HTTP-4000.2.20/Network/HTTP/Proxy.hs 2015-06-21 19:17:52.000000000 +0200 +++ new/HTTP-4000.2.21/Network/HTTP/Proxy.hs 2015-11-23 19:59:29.000000000 +0100 @@ -25,7 +25,7 @@ #endif -} -import Control.Monad ( when, mplus, join, liftM, liftM2) +import Control.Monad ( when, mplus, join, liftM2) #if defined(WIN32) import Network.HTTP.Base ( catchIO ) @@ -196,7 +196,7 @@ [] -> Nothing as -> Just (AuthBasic "" (unEscapeString usr) (unEscapeString pwd) uri) where - (usr,pwd) = chopAtDelim ':' as + (usr,pwd) = chopAtDelim ':' as uri2proxy _ = Nothing diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.20/Network/HTTP/Stream.hs new/HTTP-4000.2.21/Network/HTTP/Stream.hs --- old/HTTP-4000.2.20/Network/HTTP/Stream.hs 2015-06-21 19:17:52.000000000 +0200 +++ new/HTTP-4000.2.21/Network/HTTP/Stream.hs 2015-11-23 19:59:29.000000000 +0100 @@ -127,7 +127,7 @@ -- to the RFC. switchResponse :: Stream s => s - -> Bool {- allow retry? -} + -> Bool {- allow retry? -} -> Bool {- is body sent? -} -> Result ResponseData -> Request_String @@ -163,12 +163,12 @@ } Done -> do - when (findConnClose hdrs) - (closeOnEnd conn True) + when (findConnClose hdrs) + (closeOnEnd conn True) return (Right $ Response cd rn hdrs "") DieHorribly str -> do - close conn + close conn return $ responseParseError "sendHTTP" ("Invalid response: " ++ str) ExpectEntity -> @@ -183,14 +183,14 @@ Just x -> case map toLower (trim x) of "chunked" -> chunkedTransfer stringBufferOp - (readLine conn) (readBlock conn) + (readLine conn) (readBlock conn) _ -> uglyDeathTransfer "sendHTTP" ; case rslt of - Left e -> close conn >> return (Left e) - Right (ftrs,bdy) -> do - when (findConnClose (hdrs++ftrs)) - (closeOnEnd conn True) - return (Right (Response cd rn (hdrs++ftrs) bdy)) + Left e -> close conn >> return (Left e) + Right (ftrs,bdy) -> do + when (findConnClose (hdrs++ftrs)) + (closeOnEnd conn True) + return (Right (Response cd rn (hdrs++ftrs) bdy)) } -- | Receive and parse a HTTP request from the given Stream. Should be used @@ -204,13 +204,13 @@ do { lor <- readTillEmpty1 stringBufferOp (readLine conn) ; return $ lor >>= parseRequestHead } - + processRequest (Left e) = return $ Left e - processRequest (Right (rm,uri,hdrs)) = - do -- FIXME : Also handle 100-continue. + processRequest (Right (rm,uri,hdrs)) = + do -- FIXME : Also handle 100-continue. let tc = lookupHeader HdrTransferEncoding hdrs cl = lookupHeader HdrContentLength hdrs - rslt <- case tc of + rslt <- case tc of Nothing -> case cl of Just x -> linearTransfer (readBlock conn) (read x :: Int) @@ -218,12 +218,12 @@ Just x -> case map toLower (trim x) of "chunked" -> chunkedTransfer stringBufferOp - (readLine conn) (readBlock conn) + (readLine conn) (readBlock conn) _ -> uglyDeathTransfer "receiveHTTP" return $ do - (ftrs,bdy) <- rslt - return (Request uri rm (hdrs++ftrs) bdy) + (ftrs,bdy) <- rslt + return (Request uri rm (hdrs++ftrs) bdy) -- | Very simple function, send a HTTP response over the given stream. This -- could be improved on to use different transfer types. @@ -233,4 +233,4 @@ -- write body immediately, don't wait for 100 CONTINUE -- TODO review throwing away of result _ <- writeBlock conn (rspBody rsp) - return () + return () diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.20/Network/HTTP.hs new/HTTP-4000.2.21/Network/HTTP.hs --- old/HTTP-4000.2.20/Network/HTTP.hs 2015-06-21 19:17:52.000000000 +0200 +++ new/HTTP-4000.2.21/Network/HTTP.hs 2015-11-23 19:59:29.000000000 +0100 @@ -130,9 +130,9 @@ -- request transmission and its performance. sendHTTP_notify :: HStream ty => HandleStream ty - -> Request ty - -> IO () - -> IO (Result (Response ty)) + -> Request ty + -> IO () + -> IO (Result (Response ty)) sendHTTP_notify conn rq onSendComplete = do let norm_r = normalizeRequest defaultNormalizeRequestOptions rq S.sendHTTP_notify conn norm_r onSendComplete diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.20/Network/StreamDebugger.hs new/HTTP-4000.2.21/Network/StreamDebugger.hs --- old/HTTP-4000.2.20/Network/StreamDebugger.hs 2015-06-21 19:17:52.000000000 +0200 +++ new/HTTP-4000.2.21/Network/StreamDebugger.hs 2015-11-23 19:59:29.000000000 +0100 @@ -27,7 +27,7 @@ hSetBuffering, BufferMode(NoBuffering) ) import Network.TCP ( HandleStream, HStream, - StreamHooks(..), setStreamHooks, getStreamHooks ) + StreamHooks(..), setStreamHooks, getStreamHooks ) -- | Allows stream logging. Refer to 'debugStream' below. data StreamDebugger x @@ -37,17 +37,17 @@ readBlock (Dbg h x) n = do val <- readBlock x n hPutStrLn h ("--readBlock " ++ show n) - hPutStrLn h (show val) + hPutStrLn h (show val) return val readLine (Dbg h x) = do val <- readLine x hPutStrLn h ("--readLine") - hPutStrLn h (show val) + hPutStrLn h (show val) return val writeBlock (Dbg h x) str = do val <- writeBlock x str hPutStrLn h ("--writeBlock" ++ show str) - hPutStrLn h (show val) + hPutStrLn h (show val) return val close (Dbg h x) = do hPutStrLn h "--closing..." @@ -89,12 +89,12 @@ hPutStrLn h ("--readBlock " ++ show n) hPutStrLn h (either show show eval) , hook_readLine = \ toStr val -> do - let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v} + let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v} hPutStrLn h ("--readLine") - hPutStrLn h (either show show eval) + hPutStrLn h (either show show eval) , hook_writeBlock = \ toStr str val -> do hPutStrLn h ("--writeBlock " ++ show val) - hPutStrLn h (toStr str) + hPutStrLn h (toStr str) , hook_close = do hPutStrLn h "--closing..." hFlush h diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/HTTP-4000.2.20/Network/TCP.hs new/HTTP-4000.2.21/Network/TCP.hs --- old/HTTP-4000.2.20/Network/TCP.hs 2015-06-21 19:17:52.000000000 +0200 +++ new/HTTP-4000.2.21/Network/TCP.hs 2015-11-23 19:59:29.000000000 +0100 @@ -88,12 +88,12 @@ data Conn a = MkConn { connSock :: ! Socket - , connHandle :: Handle + , connHandle :: Handle , connBuffer :: BufferOp a - , connInput :: Maybe a + , connInput :: Maybe a , connEndPoint :: EndPoint - , connHooks :: Maybe (StreamHooks a) - , connCloseEOF :: Bool -- True => close socket upon reaching end-of-stream. + , connHooks :: Maybe (StreamHooks a) + , connCloseEOF :: Bool -- True => close socket upon reaching end-of-stream. } | ConnClosed deriving(Eq) @@ -248,8 +248,8 @@ socketConnection :: BufferType ty => String -> Int - -> Socket - -> IO (HandleStream ty) + -> Socket + -> IO (HandleStream ty) socketConnection hst port sock = socketConnection_ hst port sock False -- Internal function used to control the on-demand streaming of input @@ -257,21 +257,21 @@ socketConnection_ :: BufferType ty => String -> Int - -> Socket - -> Bool - -> IO (HandleStream ty) + -> Socket + -> Bool + -> IO (HandleStream ty) socketConnection_ hst port sock stashInput = do h <- socketToHandle sock ReadWriteMode mb <- case stashInput of { True -> liftM Just $ buf_hGetContents bufferOps h; _ -> return Nothing } let conn = MkConn { connSock = sock - , connHandle = h - , connBuffer = bufferOps - , connInput = mb - , connEndPoint = EndPoint hst port - , connHooks = Nothing - , connCloseEOF = False - } + , connHandle = h + , connBuffer = bufferOps + , connInput = mb + , connEndPoint = EndPoint hst port + , connHooks = Nothing + , connCloseEOF = False + } v <- newMVar conn return (HandleStream v) @@ -330,7 +330,7 @@ x <- bufferGetBlock ref n maybe (return ()) (\ h -> hook_readBlock h (buf_toStr $ connBuffer conn) n x) - (connHooks' conn) + (connHooks' conn) return x -- This function uses a buffer, at this time the buffer is just 1000 characters. @@ -340,7 +340,7 @@ x <- bufferReadLine ref maybe (return ()) (\ h -> hook_readLine h (buf_toStr $ connBuffer conn) x) - (connHooks' conn) + (connHooks' conn) return x -- The 'Connection' object allows no outward buffering, @@ -350,7 +350,7 @@ x <- bufferPutBlock (connBuffer conn) (connHandle conn) b maybe (return ()) (\ h -> hook_writeBlock h (buf_toStr $ connBuffer conn) b x) - (connHooks' conn) + (connHooks' conn) return x closeIt :: HStream ty => HandleStream ty -> (ty -> Bool) -> Bool -> IO () @@ -361,7 +361,7 @@ conn <- readMVar (getRef c) maybe (return ()) (hook_close) - (connHooks' conn) + (connHooks' conn) closeEOF :: HandleStream ty -> Bool -> IO () closeEOF c flg = modifyMVar_ (getRef c) (\ co -> return co{connCloseEOF=flg}) @@ -376,11 +376,11 @@ _ -> do catchIO (buf_hGet (connBuffer conn) (connHandle conn) n >>= return.return) (\ e -> - if isEOFError e - then do - when (connCloseEOF conn) $ catchIO (closeQuick ref) (\ _ -> return ()) - return (return (buf_empty (connBuffer conn))) - else return (failMisc (show e))) + if isEOFError e + then do + when (connCloseEOF conn) $ catchIO (closeQuick ref) (\ _ -> return ()) + return (return (buf_empty (connBuffer conn))) + else return (failMisc (show e))) bufferPutBlock :: BufferOp a -> Handle -> a -> IO (Result ()) bufferPutBlock ops h b = @@ -397,12 +397,12 @@ return (return (buf_append (connBuffer conn) a newl)) _ -> catchIO (buf_hGetLine (connBuffer conn) (connHandle conn) >>= - return . return . appendNL (connBuffer conn)) + return . return . appendNL (connBuffer conn)) (\ e -> if isEOFError e then do - when (connCloseEOF conn) $ catchIO (closeQuick ref) (\ _ -> return ()) - return (return (buf_empty (connBuffer conn))) + when (connCloseEOF conn) $ catchIO (closeQuick ref) (\ _ -> return ()) + return (return (buf_empty (connBuffer conn))) else return (failMisc (show e))) where -- yes, this s**ks.. _may_ have to be addressed if perf
