diff -Nru haskell-http-30010004/HTTP.cabal haskell-http-30010105/HTTP.cabal --- haskell-http-30010004/HTTP.cabal 2007-12-13 06:51:16.000000000 -0600 +++ haskell-http-30010105/HTTP.cabal 2008-11-30 04:59:49.000000000 -0600 @@ -1,10 +1,11 @@ -Name: HTTP -Version: 3001.0.4 -Cabal-Version: >= 1.2 -Build-type: Simple -License: BSD3 -License-file: LICENSE -Copyright: +Name: HTTP +Version: 3001.1.5 +Cabal-Version: >= 1.2 +Build-type: Simple +License: BSD3 +License-file: LICENSE +Category: Network +Copyright: Copyright (c) 2002, Warrick Gray Copyright (c) 2002-2005, Ian Lynagh Copyright (c) 2003-2006, Bjorn Bringert @@ -12,10 +13,11 @@ Copyright (c) 2004, Ganesh Sittampalam Copyright (c) 2004-2005, Dominic Steinitz Copyright 2007 Robin Bate Boerop -Author: Warrick Gray <warrick.g...@hotmail.com> -Maintainer: Bjorn Bringert <bj...@bringert.net> -Homepage: http://www.haskell.org/http/ -Description: A library for client-side HTTP +Author: Warrick Gray <warrick.g...@hotmail.com> +Maintainer: Bjorn Bringert <bj...@bringert.net> +Homepage: http://www.haskell.org/http/ +Description: A library for client-side HTTP +Synopsis: A library for client-side HTTP Flag old-base description: Old, monolithic base @@ -35,9 +37,10 @@ Network.HTTP.MD5, Network.HTTP.MD5Aux GHC-options: -fwarn-missing-signatures + Extensions: DeriveDataTypeable Build-depends: network, parsec if flag(old-base) Build-depends: base < 3 else - Build-depends: base >= 3, array + Build-depends: base >= 3 && < 4, array diff -Nru haskell-http-30010004/Network/Browser.hs haskell-http-30010105/Network/Browser.hs --- haskell-http-30010004/Network/Browser.hs 2007-12-13 06:51:16.000000000 -0600 +++ haskell-http-30010105/Network/Browser.hs 2008-11-30 04:59:49.000000000 -0600 @@ -31,7 +31,7 @@ module Network.Browser ( BrowserState, BrowserAction, -- browser monad, effectively a state monad. - Cookie, + Cookie(..), Form(..), Proxy(..), @@ -242,7 +242,7 @@ spaces = many (satisfy isSpace) - cvalue = quotedstring <|> many1 (satisfy $ not . (==';')) + cvalue = quotedstring <|> many (satisfy $ not . (==';')) -- all keys in the result list MUST be in lower case cdetail :: Parser [(String,String)] @@ -312,8 +312,8 @@ 3) pick a challenge to respond to, usually the strongest challenge understood by the client, using "pickChallenge" 4) generate a username/password combination using the browsers - "bsAuthorityGen" function (the default behaviour is to ask - the user) + "bsAuthorityGen" function (the default behaviour is to do nothing + which means to not retry with a new username/password combination) 5) build an Authority object based upon the challenge and user data, store this new Authority in the browser state 6) convert the Authority to a request header and add this @@ -653,8 +653,9 @@ -- | Apply a browser action to a state. browse :: BrowserAction a -> IO a -browse act = do x <- lift act defaultBrowserState - return (snd x) +browse act = do (bs, x) <- lift act defaultBrowserState + closePooledConnections bs + return x where defaultBrowserState :: BrowserState defaultBrowserState = @@ -662,7 +663,7 @@ , bsOut = putStrLn , bsCookies = [] , bsCookieFilter = defaultCookieFilter - , bsAuthorityGen = (error "bsAuthGen wanted") + , bsAuthorityGen = \_ _ -> return Nothing , bsAuthorities = [] , bsAllowRedirects = True , bsAllowBasicAuth = False @@ -671,6 +672,14 @@ , bsDebug = Nothing } +-- | +-- Close all connections that are in bs' connection pool. +-- This should have some sort of exception handling, soldier on until +-- all the connections have been closed. Not sure about portability +-- issues. +closePooledConnections :: BrowserState -> IO () +closePooledConnections = mapM_ close . bsConnectionPool + -- | Alter browser state alterBS :: (BrowserState -> BrowserState) -> BrowserAction () alterBS f = BA (\b -> return (f b,())) diff -Nru haskell-http-30010004/Network/HTTP/Headers.hs haskell-http-30010105/Network/HTTP/Headers.hs --- haskell-http-30010004/Network/HTTP/Headers.hs 2007-12-13 06:51:16.000000000 -0600 +++ haskell-http-30010105/Network/HTTP/Headers.hs 2008-11-30 04:59:49.000000000 -0600 @@ -55,6 +55,8 @@ , findHeader , lookupHeader , parseHeaders + , parseHeader + , headerMap ) where import Data.Char (isSpace, toLower) diff -Nru haskell-http-30010004/Network/HTTP/MD5Aux.hs haskell-http-30010105/Network/HTTP/MD5Aux.hs --- haskell-http-30010004/Network/HTTP/MD5Aux.hs 2007-12-13 06:51:16.000000000 -0600 +++ haskell-http-30010105/Network/HTTP/MD5Aux.hs 2008-11-30 04:59:49.000000000 -0600 @@ -4,9 +4,10 @@ Zord64, Str(..), BoolList(..), WordList(..)) where import Data.Char (ord, chr) -import Data.Bits (rotateL, shiftL, shiftR, (.&.), (.|.), xor, complement) +import Data.Bits (Bits, rotateL, shiftL, shiftR, (.&.), (.|.), xor, complement) import Data.Word (Word32, Word64) +rotL :: Bits a => a -> Int -> a rotL x = rotateL x type Zord64 = Word64 @@ -86,8 +87,8 @@ finished (WordList (_, z)) = z == 0 -instance Num ABCD where - ABCD (a1, b1, c1, d1) + ABCD (a2, b2, c2, d2) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2) +add :: ABCD -> ABCD -> ABCD +ABCD (a1, b1, c1, d1) `add` ABCD (a2, b2, c2, d2) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2) -- ===================== EXPORTED FUNCTIONS ======================== @@ -128,7 +129,7 @@ md5_main padded ilen abcd m = if finished m && padded then abcd - else md5_main padded' (ilen + 512) (abcd + abcd') m'' + else md5_main padded' (ilen + 512) (abcd `add` abcd') m'' where (m16, l, m') = get_next m len' = ilen + fromIntegral l ((m16', _, m''), padded') = if not padded && l < 512 diff -Nru haskell-http-30010004/Network/HTTP.hs haskell-http-30010105/Network/HTTP.hs --- haskell-http-30010004/Network/HTTP.hs 2007-12-13 06:51:16.000000000 -0600 +++ haskell-http-30010105/Network/HTTP.hs 2008-11-30 04:59:49.000000000 -0600 @@ -102,12 +102,15 @@ -- ** HTTP Request(..), + RequestData, Response(..), RequestMethod(..), ResponseCode, simpleHTTP, simpleHTTP_, sendHTTP, receiveHTTP, + processRequest, + getRequestHead, respondHTTP, -- ** Header Functions @@ -120,6 +123,7 @@ -- ** URI authority parsing URIAuthority(..), + getAuth, parseURIAuthority ) where @@ -132,6 +136,7 @@ ( URI(URI, uriScheme, uriAuthority, uriPath) , URIAuth(uriUserInfo, uriRegName, uriPort) , parseURIReference + , unEscapeString, escapeURIString, isUnescapedInURI ) import Network.HTTP.Headers import Network.Stream @@ -141,14 +146,14 @@ import Control.Exception as Exception (catch, throw) import Data.Bits ((.&.)) import Data.Char (isSpace, intToDigit, digitToInt, ord, chr, toLower) -import Data.List (partition) +import Data.List (partition, intersperse) import Data.Maybe (listToMaybe, fromMaybe) import Control.Monad (when, guard) import Numeric (readHex) import Text.Read.Lex (readDecP) import Text.ParserCombinators.ReadP ( ReadP, readP_to_S, char, (<++), look, munch ) - +import Data.Typeable -- Turn on to enable HTTP traffic logging debug :: Bool @@ -184,7 +189,7 @@ -- | Parse the authority part of a URL. -- --- > RFC 1732, section 3.1: +-- > RFC 1738, section 3.1: -- > -- > //<user>:<password>@<host>:<port>/<url-path> -- > Some or all of the parts "<user>:<password>@", ":<password>", @@ -227,7 +232,7 @@ -- | The HTTP request method, to be used in the 'Request' object. -- We are missing a few of the stranger methods, but these are -- not really necessary until we add full TLS. -data RequestMethod = HEAD | PUT | GET | POST | DELETE | OPTIONS | TRACE +data RequestMethod = HEAD | PUT | GET | POST | DELETE | OPTIONS | TRACE | Custom String deriving(Show,Eq) rqMethodMap :: [(String, RequestMethod)] @@ -251,7 +256,7 @@ , rqMethod :: RequestMethod , rqHeaders :: [Header] , rqBody :: String - } + } deriving (Typeable) @@ -286,7 +291,7 @@ , rspReason :: String , rspHeaders :: [Header] , rspBody :: String - } + } deriving (Typeable) -- This is an invalid representation of a received response, -- since we have made the assumption that all responses are HTTP/1.1 @@ -415,9 +420,10 @@ -- Then we make the request-URI an abs_path and make sure that there -- is a Host header. fixReq :: URIAuthority -> Request -> Request - fixReq URIAuthority{host=h} r = + fixReq URIAuthority{host=h,port=p} r = + let h' = h ++ maybe "" ((':':) . show) p in replaceHeader HdrConnection "close" $ - insertHeaderIfMissing HdrHost h $ + insertHeaderIfMissing HdrHost h' $ r { rqURI = (rqURI r){ uriScheme = "", uriAuthority = Nothing } } @@ -524,7 +530,7 @@ do { rslt <- case tc of Nothing -> case cl of - Just x -> linearTransfer conn (read x :: Int) + Just x -> linearTransferStrLen conn x Nothing -> hopefulTransfer conn "" Just x -> case map toLower (trim x) of @@ -556,35 +562,38 @@ uriRegName ua ++ uriPort ua --- | 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) -receiveHTTP conn = do rq <- getRequestHead - processRequest rq - where - -- reads and parses headers - getRequestHead :: IO (Result RequestData) - getRequestHead = - do { lor <- readTillEmpty1 conn - ; return $ lor `bindE` parseRequestHead - } - - processRequest (Left e) = return $ Left e - processRequest (Right (rm,uri,hdrs)) = - do -- FIXME : Also handle 100-continue. - let tc = lookupHeader HdrTransferEncoding hdrs - cl = lookupHeader HdrContentLength hdrs - rslt <- case tc of - Nothing -> - case cl of - Just x -> linearTransfer conn (read x :: Int) - Nothing -> return (Right ([], "")) -- hopefulTransfer "" - Just x -> - case map toLower (trim x) of - "chunked" -> chunkedTransfer conn - _ -> uglyDeathTransfer conn - - return $ rslt `bindE` \(ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy) +receiveHTTP conn = do rq <- getRequestHead conn + case rq of + Left e -> return (Left e) + Right r -> processRequest conn r + +-- | Reads and parses request headers. +getRequestHead :: Stream s => s -> IO (Result RequestData) +getRequestHead conn = + do { lor <- readTillEmpty1 conn + ; return $ lor `bindE` parseRequestHead + } + +-- | Process request body (called after successful getRequestHead) +processRequest :: Stream s => s -> RequestData -> IO (Result Request) +processRequest conn (rm,uri,hdrs) = + do -- FIXME : Also handle 100-continue. + let tc = lookupHeader HdrTransferEncoding hdrs + cl = lookupHeader HdrContentLength hdrs + rslt <- case tc of + Nothing -> + case cl of + Just x -> linearTransferStrLen conn x + Nothing -> return (Right ([], "")) -- hopefulTransfer "" + Just x -> + case map toLower (trim x) of + "chunked" -> chunkedTransfer conn + _ -> uglyDeathTransfer conn + + return $ rslt `bindE` \(ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy) -- | Very simple function, send a HTTP response over the given stream. This @@ -598,6 +607,12 @@ -- The following functions were in the where clause of sendHTTP, they have -- been moved to global scope so other functions can access them. +linearTransferStrLen :: Stream s => s -> String -> IO (Result ([Header],String)) +linearTransferStrLen conn ns = + case reads ns of + [(n,"")] -> linearTransfer conn n + _ -> return $ Left $ ErrorParse $ "Content-Length header contains not a number: " ++ show ns + -- | Used when we know exactly how many bytes to expect. linearTransfer :: Stream s => s -> Int -> IO (Result ([Header],String)) linearTransfer conn n @@ -692,65 +707,26 @@ ------------------ A little friendly funtionality --------------- ----------------------------------------------------------------- - -{- - I had a quick look around but couldn't find any RFC about - the encoding of data on the query string. I did find an - IETF memo, however, so this is how I justify the urlEncode - and urlDecode methods. - - Doc name: draft-tiwari-appl-wxxx-forms-01.txt (look on www.ietf.org) - - Reserved chars: ";", "/", "?", ":", "@", "&", "=", "+", ",", and "$" are reserved. - Unwise: "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`" - URI delims: "<" | ">" | "#" | "%" | <"> - Unallowed ASCII: <US-ASCII coded characters 00-1F and 7F hexadecimal> - <US-ASCII coded character 20 hexadecimal> - Also unallowed: any non-us-ascii character - - Escape method: char -> '%' a b where a, b :: Hex digits --} - -urlEncode, urlDecode :: String -> String - -urlDecode ('%':a:b:rest) = chr (16 * digitToInt a + digitToInt b) - : urlDecode rest -urlDecode (h:t) = h : urlDecode t -urlDecode [] = [] - -urlEncode (h:t) = - let str = if reserved (ord h) then escape h else [h] - in str ++ urlEncode t - where - reserved x - | x >= ord 'a' && x <= ord 'z' = False - | x >= ord 'A' && x <= ord 'Z' = False - | x >= ord '0' && x <= ord '9' = False - | x <= 0x20 || x >= 0x7F = True - | otherwise = x `elem` map ord [';','/','?',':','@','&' - ,'=','+',',','$','{','}' - ,'|','\\','^','[',']','`' - ,'<','>','#','%','"'] - -- wouldn't it be nice if the compiler - -- optimised the above for us? - - escape x = - let y = ord x - in [ '%', intToDigit ((y `div` 16) .&. 0xf), intToDigit (y .&. 0xf) ] - -urlEncode [] = [] - - - --- Encode form variables, useable in either the --- query part of a URI, or the body of a POST request. --- I have no source for this information except experience, --- this sort of encoding worked fine in CGI programming. +-- | Formats name-value pairs as application\/x-www-form-urlencoded. urlEncodeVars :: [(String,String)] -> String -urlEncodeVars ((n,v):t) = - let (same,diff) = partition ((==n) . fst) t - in urlEncode n ++ '=' : foldl (\x y -> x ++ ',' : urlEncode y) (urlEncode $ v) (map snd same) - ++ urlEncodeRest diff - where urlEncodeRest [] = [] - urlEncodeRest diff = '&' : urlEncodeVars diff -urlEncodeVars [] = [] +urlEncodeVars xs = + concat $ intersperse "&" [urlEncode n ++ "=" ++ urlEncode v | (n,v) <- xs] + +-- | Converts a single value to the application\/x-www-form-urlencoded encoding. +urlEncode :: String -> String +urlEncode = replace ' ' '+' . escapeURIString okChar + where okChar c = c == ' ' || + (isUnescapedInURI c && c `notElem` "&=+") + +-- | Converts a single value from the +-- application\/x-www-form-urlencoded encoding. +urlDecode :: String -> String +urlDecode = unEscapeString . replace '+' ' ' + +-- | Replaces all instances of a value in a list by another value. +replace :: Eq a => + a -- ^ Value to look for + -> a -- ^ Value to replace it with + -> [a] -- ^ Input list + -> [a] -- ^ Output list +replace x y = map (\z -> if z == x then y else z) diff -Nru haskell-http-30010004/Network/StreamSocket.hs haskell-http-30010105/Network/StreamSocket.hs --- haskell-http-30010004/Network/StreamSocket.hs 2007-12-13 06:51:16.000000000 -0600 +++ haskell-http-30010105/Network/StreamSocket.hs 2008-11-30 04:59:49.000000000 -0600 @@ -77,6 +77,7 @@ close sk = shutdown sk ShutdownBoth >> sClose sk myrecv :: Socket -> Int -> IO String +myrecv _ 0 = return "" myrecv sock len = let handler e = if isEOFError e then return [] else ioError e in System.IO.Error.catch (recv sock len) handler diff -Nru haskell-http-30010004/Network/TCP.hs haskell-http-30010105/Network/TCP.hs --- haskell-http-30010004/Network/TCP.hs 2007-12-13 06:51:16.000000000 -0600 +++ haskell-http-30010105/Network/TCP.hs 2008-11-30 04:59:49.000000000 -0600 @@ -41,7 +41,7 @@ ) import Network.StreamSocket (myrecv, handleSocketError) -import Control.Exception as Exception (catch, throw) +import Control.Exception as Exception (catch, catchJust, finally, ioErrors, throw) import Data.List (elemIndex) import Data.Char (toLower) import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) @@ -158,23 +158,23 @@ -- (I think the behaviour here is TCP specific) close ref = do { c <- readIORef (getRef ref) - ; closeConn c `Exception.catch` (\_ -> return ()) + ; Exception.catchJust Exception.ioErrors (closeConn c) (\_ -> return ()) ; writeIORef (getRef ref) ConnClosed } where - -- Be kind to peer & close gracefully. - closeConn (ConnClosed) = return () - closeConn (MkConn sk addr [] _) = - do { shutdown sk ShutdownSend - ; suck ref - ; shutdown sk ShutdownReceive - ; sClose sk - } - - suck :: Connection -> IO () - suck cn = readLine cn >>= - either (\_ -> return ()) -- catch errors & ignore - (\x -> if null x then return () else suck cn) + -- Be kind to peer & close gracefully. + closeConn (ConnClosed) = return () + closeConn (MkConn sk addr [] _) = + (`Exception.finally` sClose sk) $ + do { shutdown sk ShutdownSend + ; suck ref + ; shutdown sk ShutdownReceive + } + + suck :: Connection -> IO () + suck cn = readLine cn >>= + either (\_ -> return ()) -- catch errors & ignore + (\x -> if null x then return () else suck cn) -- | Checks both that the underlying Socket is connected -- and that the connection peer matches the given diff -Nru haskell-http-30010004/debian/changelog haskell-http-30010105/debian/changelog --- haskell-http-30010004/debian/changelog 2009-04-06 11:40:02.000000000 -0500 +++ haskell-http-30010105/debian/changelog 2009-04-06 11:40:02.000000000 -0500 @@ -1,3 +1,10 @@ +haskell-http (30010105-0.1) unstable; urgency=low + + * New upstream release that is compatible with GHC 6.10. + * Rebuild with GHC 6.10. Closes: #522766, #519704. + + -- John Goerzen <jgoer...@complete.org> Mon, 06 Apr 2009 11:22:12 -0500 + haskell-http (30010004-3) unstable; urgency=low * debian/control: diff -Nru haskell-http-30010004/debian/control haskell-http-30010105/debian/control --- haskell-http-30010004/debian/control 2009-04-06 11:40:02.000000000 -0500 +++ haskell-http-30010105/debian/control 2009-04-06 11:40:02.000000000 -0500 @@ -3,12 +3,12 @@ Section: net Maintainer: Arjan Oosting <ar...@debian.org> Build-Depends: dctrl-tools, dpkg-dev (>= 1.13.19), debhelper (>= 5.0.0), dpatch, - haskell-devscripts (>= 0.6.0), ghc6 (>= 6.8.2), ghc6-prof, libghc6-network-dev, + haskell-devscripts (>= 0.6.0), ghc6 (>= 6.10), ghc6-prof, libghc6-network-dev, libghc6-network-prof, libghc6-parsec-dev, libghc6-parsec-prof Build-Depends-Indep: haddock, hugs, libhugs-network | hugs (<< 98.200609.21), libhugs-parsec | hugs (<< 98.200609.21), - libghc6-base-doc, libghc6-network-doc, libghc6-parsec-doc + ghc6-doc, libghc6-network-doc, libghc6-parsec-doc Standards-Version: 3.7.3 Homepage: http://www.haskell.org/http/ Vcs-Svn: svn://svn.debian.org/svn/pkg-haskell/packages/haskell-http/trunk