[Pkg-haskell-commits] r1273 - in /packages/haskell-http/branches/upstream/30010103: HTTP.cabal Network/Browser.hs Network/HTTP.hs Network/HTTP/Headers.hs Network/HTTP/MD5Aux.hs Network/StreamSocket.hs Network/TCP.hs
arjan at users.alioth.debian.org
arjan at users.alioth.debian.org
Sat Jan 17 14:49:03 UTC 2009
Author: arjan
Date: Sat Jan 17 14:49:02 2009
New Revision: 1273
URL: http://svn.debian.org/wsvn/pkg-haskell/?sc=1&rev=1273
Log: (empty)
Modified:
packages/haskell-http/branches/upstream/30010103/HTTP.cabal
packages/haskell-http/branches/upstream/30010103/Network/Browser.hs
packages/haskell-http/branches/upstream/30010103/Network/HTTP.hs
packages/haskell-http/branches/upstream/30010103/Network/HTTP/Headers.hs
packages/haskell-http/branches/upstream/30010103/Network/HTTP/MD5Aux.hs
packages/haskell-http/branches/upstream/30010103/Network/StreamSocket.hs
packages/haskell-http/branches/upstream/30010103/Network/TCP.hs
Modified: packages/haskell-http/branches/upstream/30010103/HTTP.cabal
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-http/branches/upstream/30010103/HTTP.cabal?rev=1273&op=diff
==============================================================================
--- packages/haskell-http/branches/upstream/30010103/HTTP.cabal (original)
+++ packages/haskell-http/branches/upstream/30010103/HTTP.cabal Sat Jan 17 14:49:02 2009
@@ -1,11 +1,10 @@
Name: HTTP
-Version: 3001.1.3
+Version: 3001.0.4
Cabal-Version: >= 1.2
Build-type: Simple
License: BSD3
License-file: LICENSE
-Category: Network
-Copyright:
+Copyright:
Copyright (c) 2002, Warrick Gray
Copyright (c) 2002-2005, Ian Lynagh
Copyright (c) 2003-2006, Bjorn Bringert
@@ -17,7 +16,6 @@
Maintainer: Bjorn Bringert <bjorn at 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
@@ -42,4 +40,4 @@
if flag(old-base)
Build-depends: base < 3
else
- Build-depends: base >= 3 && < 4, array
+ Build-depends: base >= 3, array
Modified: packages/haskell-http/branches/upstream/30010103/Network/Browser.hs
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-http/branches/upstream/30010103/Network/Browser.hs?rev=1273&op=diff
==============================================================================
--- packages/haskell-http/branches/upstream/30010103/Network/Browser.hs (original)
+++ packages/haskell-http/branches/upstream/30010103/Network/Browser.hs Sat Jan 17 14:49:02 2009
@@ -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 <|> many (satisfy $ not . (==';'))
+ cvalue = quotedstring <|> many1 (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 do nothing
- which means to not retry with a new username/password combination)
+ "bsAuthorityGen" function (the default behaviour is to ask
+ the user)
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,9 +653,8 @@
-- | Apply a browser action to a state.
browse :: BrowserAction a -> IO a
-browse act = do (bs, x) <- lift act defaultBrowserState
- closePooledConnections bs
- return x
+browse act = do x <- lift act defaultBrowserState
+ return (snd x)
where
defaultBrowserState :: BrowserState
defaultBrowserState =
@@ -663,7 +662,7 @@
, bsOut = putStrLn
, bsCookies = []
, bsCookieFilter = defaultCookieFilter
- , bsAuthorityGen = \_ _ -> return Nothing
+ , bsAuthorityGen = (error "bsAuthGen wanted")
, bsAuthorities = []
, bsAllowRedirects = True
, bsAllowBasicAuth = False
@@ -671,14 +670,6 @@
, 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 ()
Modified: packages/haskell-http/branches/upstream/30010103/Network/HTTP.hs
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-http/branches/upstream/30010103/Network/HTTP.hs?rev=1273&op=diff
==============================================================================
--- packages/haskell-http/branches/upstream/30010103/Network/HTTP.hs (original)
+++ packages/haskell-http/branches/upstream/30010103/Network/HTTP.hs Sat Jan 17 14:49:02 2009
@@ -102,15 +102,12 @@
-- ** HTTP
Request(..),
- RequestData,
Response(..),
RequestMethod(..),
ResponseCode,
simpleHTTP, simpleHTTP_,
sendHTTP,
receiveHTTP,
- processRequest,
- getRequestHead,
respondHTTP,
-- ** Header Functions
@@ -123,7 +120,6 @@
-- ** URI authority parsing
URIAuthority(..),
- getAuth,
parseURIAuthority
) where
@@ -136,7 +132,6 @@
( URI(URI, uriScheme, uriAuthority, uriPath)
, URIAuth(uriUserInfo, uriRegName, uriPort)
, parseURIReference
- , unEscapeString, escapeURIString, isUnescapedInURI
)
import Network.HTTP.Headers
import Network.Stream
@@ -146,7 +141,7 @@
import Control.Exception as Exception (catch, throw)
import Data.Bits ((.&.))
import Data.Char (isSpace, intToDigit, digitToInt, ord, chr, toLower)
-import Data.List (partition, intersperse)
+import Data.List (partition)
import Data.Maybe (listToMaybe, fromMaybe)
import Control.Monad (when, guard)
import Numeric (readHex)
@@ -189,7 +184,7 @@
-- | Parse the authority part of a URL.
--
--- > RFC 1738, section 3.1:
+-- > RFC 1732, section 3.1:
-- >
-- > //<user>:<password>@<host>:<port>/<url-path>
-- > Some or all of the parts "<user>:<password>@", ":<password>",
@@ -232,7 +227,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 | Custom String
+data RequestMethod = HEAD | PUT | GET | POST | DELETE | OPTIONS | TRACE
deriving(Show,Eq)
rqMethodMap :: [(String, RequestMethod)]
@@ -420,10 +415,9 @@
-- 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,port=p} r =
- let h' = h ++ maybe "" ((':':) . show) p in
+ fixReq URIAuthority{host=h} r =
replaceHeader HdrConnection "close" $
- insertHeaderIfMissing HdrHost h' $
+ insertHeaderIfMissing HdrHost h $
r { rqURI = (rqURI r){ uriScheme = "",
uriAuthority = Nothing } }
@@ -562,38 +556,35 @@
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 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)
+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)
-- | Very simple function, send a HTTP response over the given stream. This
@@ -701,26 +692,65 @@
------------------ A little friendly funtionality ---------------
-----------------------------------------------------------------
--- | Formats name-value pairs as application\/x-www-form-urlencoded.
+
+{-
+ 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.
urlEncodeVars :: [(String,String)] -> String
-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)
+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 [] = []
Modified: packages/haskell-http/branches/upstream/30010103/Network/HTTP/Headers.hs
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-http/branches/upstream/30010103/Network/HTTP/Headers.hs?rev=1273&op=diff
==============================================================================
--- packages/haskell-http/branches/upstream/30010103/Network/HTTP/Headers.hs (original)
+++ packages/haskell-http/branches/upstream/30010103/Network/HTTP/Headers.hs Sat Jan 17 14:49:02 2009
@@ -55,8 +55,6 @@
, findHeader
, lookupHeader
, parseHeaders
- , parseHeader
- , headerMap
) where
import Data.Char (isSpace, toLower)
Modified: packages/haskell-http/branches/upstream/30010103/Network/HTTP/MD5Aux.hs
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-http/branches/upstream/30010103/Network/HTTP/MD5Aux.hs?rev=1273&op=diff
==============================================================================
--- packages/haskell-http/branches/upstream/30010103/Network/HTTP/MD5Aux.hs (original)
+++ packages/haskell-http/branches/upstream/30010103/Network/HTTP/MD5Aux.hs Sat Jan 17 14:49:02 2009
@@ -4,10 +4,9 @@
Zord64, Str(..), BoolList(..), WordList(..)) where
import Data.Char (ord, chr)
-import Data.Bits (Bits, rotateL, shiftL, shiftR, (.&.), (.|.), xor, complement)
+import Data.Bits (rotateL, shiftL, shiftR, (.&.), (.|.), xor, complement)
import Data.Word (Word32, Word64)
-rotL :: Bits a => a -> Int -> a
rotL x = rotateL x
type Zord64 = Word64
@@ -87,8 +86,8 @@
finished (WordList (_, z)) = z == 0
-add :: ABCD -> ABCD -> ABCD
-ABCD (a1, b1, c1, d1) `add` ABCD (a2, b2, c2, d2) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2)
+instance Num ABCD where
+ ABCD (a1, b1, c1, d1) + ABCD (a2, b2, c2, d2) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2)
-- ===================== EXPORTED FUNCTIONS ========================
@@ -129,7 +128,7 @@
md5_main padded ilen abcd m
= if finished m && padded
then abcd
- else md5_main padded' (ilen + 512) (abcd `add` abcd') m''
+ else md5_main padded' (ilen + 512) (abcd + abcd') m''
where (m16, l, m') = get_next m
len' = ilen + fromIntegral l
((m16', _, m''), padded') = if not padded && l < 512
Modified: packages/haskell-http/branches/upstream/30010103/Network/StreamSocket.hs
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-http/branches/upstream/30010103/Network/StreamSocket.hs?rev=1273&op=diff
==============================================================================
--- packages/haskell-http/branches/upstream/30010103/Network/StreamSocket.hs (original)
+++ packages/haskell-http/branches/upstream/30010103/Network/StreamSocket.hs Sat Jan 17 14:49:02 2009
@@ -77,7 +77,6 @@
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
Modified: packages/haskell-http/branches/upstream/30010103/Network/TCP.hs
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-http/branches/upstream/30010103/Network/TCP.hs?rev=1273&op=diff
==============================================================================
--- packages/haskell-http/branches/upstream/30010103/Network/TCP.hs (original)
+++ packages/haskell-http/branches/upstream/30010103/Network/TCP.hs Sat Jan 17 14:49:02 2009
@@ -41,7 +41,7 @@
)
import Network.StreamSocket (myrecv, handleSocketError)
-import Control.Exception as Exception (catch, catchJust, finally, ioErrors, throw)
+import Control.Exception as Exception (catch, 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)
- ; Exception.catchJust Exception.ioErrors (closeConn c) (\_ -> return ())
+ ; closeConn c `Exception.catch` (\_ -> return ())
; writeIORef (getRef ref) ConnClosed
}
where
- -- 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)
+ -- 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)
-- | Checks both that the underlying Socket is connected
-- and that the connection peer matches the given
More information about the Pkg-haskell-commits
mailing list