HTTP 3001.0.4 → 3001.1.3

raw patch · 11 files changed

+230/−120 lines, 11 filesdep ~basenew-uploaderPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• HTTP.cabal +5/−3
• Makefile +35/−0
• Network/Browser.hs +16/−7
• Network/HTTP.hs +61/−91
• Network/HTTP/Headers.hs +2/−0
• Network/HTTP/MD5Aux.hs +5/−4
• Network/StreamSocket.hs +1/−0
• Network/TCP.hs +15/−15
• README +25/−0
• test/Makefile +16/−0
• test/get.hs +49/−0

@@ -1,10 +1,11 @@ Name: HTTP-Version: 3001.0.4+Version: 3001.1.3 Cabal-Version: >= 1.2 Build-type: Simple License: BSD3 License-file: LICENSE-Copyright: +Category:       Network+Copyright:   Copyright (c) 2002, Warrick Gray   Copyright (c) 2002-2005, Ian Lynagh   Copyright (c) 2003-2006, Bjorn Bringert@@ -16,6 +17,7 @@ Maintainer: Bjorn Bringert <bjorn@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@@ -40,4 +42,4 @@   if flag(old-base)     Build-depends: base < 3   else-    Build-depends: base >= 3, array+    Build-depends: base >= 3 && < 4, array

@@ -0,0 +1,35 @@+HADDOCK = haddock++TODAY = $(shell date +%Y%m%d)+DIST_NAME = http-$(TODAY)++HADDOCK_FILES = Network/HTTP.hs Network/Browser.hs ++.PHONY: all configure build install dist haddock clean++default all: configure build++configure:+	./Setup.lhs configure++build:+	./Setup.lhs build++install:+	./Setup.lhs install++dist:+	darcs dist --dist-name=$(DIST_NAME)++haddock: $(HADDOCK_FILES)+	mkdir -p haddock+	$(HADDOCK) -o haddock -h $^++clean:+	-./Setup.lhs clean+	-rm -rf haddock+	-rm -rf dist+	$(MAKE) -C test clean++setup: Setup.lhs+	ghc --make -package Cabal -o setup Setup.lhs

@@ -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@@ -670,6 +671,14 @@                , bsProxy            = NoProxy                , 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 ()

@@ -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,7 +146,7 @@ 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)@@ -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)]@@ -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 } }	        @@ -556,37 +562,40 @@                                                  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  -> 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)++ -- | 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 -> IO ()@@ -692,65 +701,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) ]+-- | Formats name-value pairs as application\/x-www-form-urlencoded.+urlEncodeVars :: [(String,String)] -> String+urlEncodeVars xs = +    concat $ intersperse "&" [urlEncode n ++ "=" ++ urlEncode v | (n,v) <- xs] -urlEncode [] = []-            +-- | 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 '+' ' ' --- 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.-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 [] = []+-- | 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)

@@ -55,6 +55,8 @@    , findHeader    , lookupHeader    , parseHeaders+   , parseHeader+   , headerMap    ) where  import Data.Char (isSpace, toLower)

@@ -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

@@ -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

@@ -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

@@ -0,0 +1,25 @@+DESCRIPTION++This is the Haskell HTTP and Browser module package. It was originally+written by Warrick Gray and the original version is still available+from: http://homepages.paradise.net.nz/warrickg/haskell/http/++REQUIREMENTS++* A Haskell implementation such as GHC (http://www.haskell.org/ghc/)+or Hugs (http://www.haskell.org/hugs/) with support for Cabal.++INSTALLATION+++* Configure:++$ runhaskell Setup.lhs configure++* Compile:++$ runhaskell Setup.lhs build++* Install (as root):++# runhaskell Setup.lhs install

@@ -0,0 +1,16 @@+GHC = ghc+GHCFLAGS = -O2 -package HTTP++TEST_PROGS = get++.SUFFIXES: .hs .hi .o++.PHONY: all clean++default all: $(TEST_PROGS)++%: %.hs+	$(GHC) $(GHCFLAGS) --make -o $@ $<++clean:+	-rm -f *.hi *.o $(TEST_PROGS)

@@ -0,0 +1,49 @@+-- A simple test program which takes a url on the commandline+-- and outputs the contents to stdout.++-- ghc --make -package HTTP get.hs -o get++import Data.Char (intToDigit)+import Network.HTTP+import Network.URI+import System.Environment (getArgs)+import System.Exit (exitFailure)+import System.IO (hPutStrLn, stderr)++main = +    do+    args <- getArgs+    case args of +	[addr] -> case parseURI addr of+		       Nothing -> err "Could not parse URI"+		       Just uri -> do+				   cont <- get uri+			           putStr cont+	_ -> err "Usage: get <url>"++err :: String -> IO a+err msg = do +	  hPutStrLn stderr msg+	  exitFailure++get :: URI -> IO String+get uri =+    do+    eresp <- simpleHTTP (request uri)+    resp <- handleE (err . show) eresp+    case rspCode resp of+                      (2,0,0) -> return (rspBody resp)+                      _ -> err (httpError resp)+    where+    showRspCode (a,b,c) = map intToDigit [a,b,c]+    httpError resp = showRspCode (rspCode resp) ++ " " ++ rspReason resp++request :: URI -> Request+request uri = Request{ rqURI = uri,+                       rqMethod = GET,+                       rqHeaders = [],+                       rqBody = "" }++handleE :: Monad m => (ConnError -> m a) -> Either ConnError a -> m a+handleE h (Left e) = h e+handleE _ (Right v) = return v