[Pkg-haskell-commits] r1261 - in /packages/haskell-http/branches/upstream/current: HTTP.cabal Makefile Network/Browser.hs Network/HTTP.hs Network/HTTP/Headers.hs Network/HTTP/MD5Aux.hs Network/StreamSocket.hs Network/TCP.hs README test/ test/Makefile test/get.hs
arjan at users.alioth.debian.org
arjan at users.alioth.debian.org
Mon Oct 13 04:32:55 UTC 2008
Author: arjan
Date: Mon Oct 13 04:32:53 2008
New Revision: 1261
URL: http://svn.debian.org/wsvn/pkg-haskell/?sc=1&rev=1261
Log:
[svn-upgrade] Integrating new upstream version, haskell-http (30010103)
Added:
packages/haskell-http/branches/upstream/current/Makefile
packages/haskell-http/branches/upstream/current/README
packages/haskell-http/branches/upstream/current/test/
packages/haskell-http/branches/upstream/current/test/Makefile
packages/haskell-http/branches/upstream/current/test/get.hs
Modified:
packages/haskell-http/branches/upstream/current/HTTP.cabal
packages/haskell-http/branches/upstream/current/Network/Browser.hs
packages/haskell-http/branches/upstream/current/Network/HTTP.hs
packages/haskell-http/branches/upstream/current/Network/HTTP/Headers.hs
packages/haskell-http/branches/upstream/current/Network/HTTP/MD5Aux.hs
packages/haskell-http/branches/upstream/current/Network/StreamSocket.hs
packages/haskell-http/branches/upstream/current/Network/TCP.hs
Modified: packages/haskell-http/branches/upstream/current/HTTP.cabal
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-http/branches/upstream/current/HTTP.cabal?rev=1261&op=diff
==============================================================================
--- packages/haskell-http/branches/upstream/current/HTTP.cabal (original)
+++ packages/haskell-http/branches/upstream/current/HTTP.cabal Mon Oct 13 04:32:53 2008
@@ -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 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
@@ -40,4 +42,4 @@
if flag(old-base)
Build-depends: base < 3
else
- Build-depends: base >= 3, array
+ Build-depends: base >= 3 && < 4, array
Added: packages/haskell-http/branches/upstream/current/Makefile
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-http/branches/upstream/current/Makefile?rev=1261&op=file
==============================================================================
--- packages/haskell-http/branches/upstream/current/Makefile (added)
+++ packages/haskell-http/branches/upstream/current/Makefile Mon Oct 13 04:32:53 2008
@@ -1,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
Modified: packages/haskell-http/branches/upstream/current/Network/Browser.hs
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-http/branches/upstream/current/Network/Browser.hs?rev=1261&op=diff
==============================================================================
--- packages/haskell-http/branches/upstream/current/Network/Browser.hs (original)
+++ packages/haskell-http/branches/upstream/current/Network/Browser.hs Mon Oct 13 04:32:53 2008
@@ -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 ()
Modified: packages/haskell-http/branches/upstream/current/Network/HTTP.hs
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-http/branches/upstream/current/Network/HTTP.hs?rev=1261&op=diff
==============================================================================
--- packages/haskell-http/branches/upstream/current/Network/HTTP.hs (original)
+++ packages/haskell-http/branches/upstream/current/Network/HTTP.hs Mon Oct 13 04:32:53 2008
@@ -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,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 -> 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
@@ -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) ]
-
-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)
Modified: packages/haskell-http/branches/upstream/current/Network/HTTP/Headers.hs
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-http/branches/upstream/current/Network/HTTP/Headers.hs?rev=1261&op=diff
==============================================================================
--- packages/haskell-http/branches/upstream/current/Network/HTTP/Headers.hs (original)
+++ packages/haskell-http/branches/upstream/current/Network/HTTP/Headers.hs Mon Oct 13 04:32:53 2008
@@ -55,6 +55,8 @@
, findHeader
, lookupHeader
, parseHeaders
+ , parseHeader
+ , headerMap
) where
import Data.Char (isSpace, toLower)
Modified: packages/haskell-http/branches/upstream/current/Network/HTTP/MD5Aux.hs
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-http/branches/upstream/current/Network/HTTP/MD5Aux.hs?rev=1261&op=diff
==============================================================================
--- packages/haskell-http/branches/upstream/current/Network/HTTP/MD5Aux.hs (original)
+++ packages/haskell-http/branches/upstream/current/Network/HTTP/MD5Aux.hs Mon Oct 13 04:32:53 2008
@@ -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
Modified: packages/haskell-http/branches/upstream/current/Network/StreamSocket.hs
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-http/branches/upstream/current/Network/StreamSocket.hs?rev=1261&op=diff
==============================================================================
--- packages/haskell-http/branches/upstream/current/Network/StreamSocket.hs (original)
+++ packages/haskell-http/branches/upstream/current/Network/StreamSocket.hs Mon Oct 13 04:32:53 2008
@@ -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
Modified: packages/haskell-http/branches/upstream/current/Network/TCP.hs
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-http/branches/upstream/current/Network/TCP.hs?rev=1261&op=diff
==============================================================================
--- packages/haskell-http/branches/upstream/current/Network/TCP.hs (original)
+++ packages/haskell-http/branches/upstream/current/Network/TCP.hs Mon Oct 13 04:32:53 2008
@@ -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
Added: packages/haskell-http/branches/upstream/current/README
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-http/branches/upstream/current/README?rev=1261&op=file
==============================================================================
--- packages/haskell-http/branches/upstream/current/README (added)
+++ packages/haskell-http/branches/upstream/current/README Mon Oct 13 04:32:53 2008
@@ -1,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
Added: packages/haskell-http/branches/upstream/current/test/Makefile
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-http/branches/upstream/current/test/Makefile?rev=1261&op=file
==============================================================================
--- packages/haskell-http/branches/upstream/current/test/Makefile (added)
+++ packages/haskell-http/branches/upstream/current/test/Makefile Mon Oct 13 04:32:53 2008
@@ -1,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)
Added: packages/haskell-http/branches/upstream/current/test/get.hs
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-http/branches/upstream/current/test/get.hs?rev=1261&op=file
==============================================================================
--- packages/haskell-http/branches/upstream/current/test/get.hs (added)
+++ packages/haskell-http/branches/upstream/current/test/get.hs Mon Oct 13 04:32:53 2008
@@ -1,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
More information about the Pkg-haskell-commits
mailing list