HTTP 3001.0.3 → 3001.0.4

raw patch · 11 files changed

+572/−522 lines, 11 filesdep ~networkPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: network

API changes (from Hackage documentation)

Files

• HTTP.cabal +5/−1
• Network/Browser.hs +24/−6
• Network/HTTP.hs +24/−322
• Network/HTTP/Base64.hs +11/−16
• Network/HTTP/Headers.hs +310/−0
• Network/HTTP/MD5.hs +12/−13
• Network/HTTP/MD5Aux.hs +3/−3
• Network/Stream.hs +15/−133
• Network/StreamDebugger.hs +59/−0
• Network/StreamSocket.hs +83/−0
• Network/TCP.hs +26/−28

@@ -1,5 +1,5 @@ Name: HTTP-Version: 3001.0.3+Version: 3001.0.4 Cabal-Version: >= 1.2 Build-type: Simple License: BSD3@@ -11,6 +11,7 @@   Copyright (c) 2004, Andre Furtado   Copyright (c) 2004, Ganesh Sittampalam   Copyright (c) 2004-2005, Dominic Steinitz+  Copyright 2007 Robin Bate Boerop Author: Warrick Gray <warrick.gray@hotmail.com> Maintainer: Bjorn Bringert <bjorn@bringert.net> Homepage: http://www.haskell.org/http/@@ -23,8 +24,11 @@ Library   Exposed-modules:                   Network.Stream,+                 Network.StreamDebugger,+                 Network.StreamSocket,                  Network.TCP,                                  Network.HTTP,+                 Network.HTTP.Headers,                  Network.Browser   Other-modules:                  Network.HTTP.Base64,

@@ -12,6 +12,10 @@ -----------------------------------------------------------------------------   {-+  Changes by Robin Bate Boerop <robin@bateboerop.name>:+   - Made dependencies explicit in import statements.+   - Added type signatures.+   - Imported new StreamDebugger module.    Change Log:    - altered 'closeTCP' to 'close', for consistency with altered HTTP@@ -70,20 +74,32 @@     uriTrimHost ) where +import Network.URI+   ( URI(uriAuthority, uriScheme, uriPath, uriQuery)+   , URIAuth(URIAuth, uriUserInfo, uriPort, uriRegName)+   , parseURI, parseURIReference, relativeTo+   )+import Network.StreamDebugger (debugStream)+import Network.TCP (Connection, isConnectedTo) import Network.HTTP+import qualified Network.HTTP.MD5 as MD5 (hash)+import qualified Network.HTTP.Base64 as Base64 (encode)  import Data.Char (toLower,isAlphaNum,isSpace) import Data.List (isPrefixOf,isSuffixOf,elemIndex,elemIndices)-import Data.Maybe-import Control.Monad (foldM,filterM,liftM,when)+import Data.Maybe (fromMaybe, listToMaybe, catMaybes, fromJust, isJust)+import Control.Monad (foldM, filterM, liftM, when) import Text.ParserCombinators.Parsec-import Network.URI-+   ( Parser, char, many, many1, satisfy, parse, option, try+   , (<|>), spaces, sepBy1+   ) import qualified System.IO+   ( hSetBuffering, hPutStr, stdout, stdin, hGetChar+   , BufferMode(NoBuffering, LineBuffering)+   ) import Data.Word (Word8)-import qualified Network.HTTP.MD5 as MD5-import qualified Network.HTTP.Base64 as Base64 + type Octet = Word8  ------------------------------------------------------------------@@ -932,6 +948,7 @@    +uriAuth :: URI -> URIAuth uriAuth x = case uriAuthority x of               Just ua -> ua               _       -> error ("No uri authority for: "++show x)@@ -956,6 +973,7 @@ ------------------------------------------------------------------  +libUA :: String libUA = "haskell-libwww/0.1"  defaultGETRequest :: URI -> Request

@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Network.HTTP--- Copyright   :  (c) Warrick Gray 2002, Bjorn Bringert 2003-2005+-- Copyright   :  (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop -- License     :  BSD --  -- Maintainer  :  bjorn@bringert.net@@ -10,6 +10,12 @@ -- -- An easy HTTP interface enjoy. --+-- * Changes by Robin Bate Boerop <robin@bateboerop.name>:+--      - Made dependencies explicit in import statements.+--      - Removed false dependencies in import statements.+--      - Added missing type signatures.+--      - Moved Header-related code to Network.HTTP.Headers module.+-- -- * Changes by Simon Foster: --      - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules --      - Created functions receiveHTTP and responseHTTP to allow server side interactions@@ -105,15 +111,7 @@     respondHTTP,      -- ** Header Functions-    HasHeaders,-    Header(..),-    HeaderName(..),-    insertHeader,-    insertHeaderIfMissing,-    insertHeaders,-    retrieveHeaders,-    replaceHeader,-    findHeader,+    module Network.HTTP.Headers,      -- ** URL Encoding     urlEncode,@@ -126,40 +124,30 @@ ) where  - ----------------------------------------------------------------- ------------------ Imports -------------------------------------- ----------------------------------------------------------------- -import Control.Exception as Exception---- Networking-import Network (withSocketsDo)-import Network.BSD import Network.URI-import Network.Socket+   ( URI(URI, uriScheme, uriAuthority, uriPath)+   , URIAuth(uriUserInfo, uriRegName, uriPort)+   , parseURIReference+   )+import Network.HTTP.Headers import Network.Stream-import Network.TCP-+import Network.StreamDebugger (debugStream)+import Network.TCP (openTCPPort) --- Util+import Control.Exception as Exception (catch, throw) import Data.Bits ((.&.))-import Data.Char-import Data.List (isPrefixOf,partition,elemIndex)-import Data.Maybe-import Data.Array.MArray-import Data.IORef-import Control.Concurrent-import Control.Monad (when,liftM,guard)-import Control.Monad.ST (ST,stToIO)+import Data.Char (isSpace, intToDigit, digitToInt, ord, chr, toLower)+import Data.List (partition)+import Data.Maybe (listToMaybe, fromMaybe)+import Control.Monad (when, guard) import Numeric (readHex)+import Text.Read.Lex (readDecP) import Text.ParserCombinators.ReadP-import Text.Read.Lex -import System.IO-import System.IO.Error (isEOFError)-import qualified System.IO.Error--import Foreign.C.Error+   ( ReadP, readP_to_S, char, (<++), look, munch )   -- Turn on to enable HTTP traffic logging@@ -180,16 +168,7 @@        reverse . dropspace . reverse . dropspace  --- Split a list into two parts, the delimiter occurs--- at the head of the second list.  Nothing is returned--- when no occurance of the delimiter is found.-split :: Eq a => a -> [a] -> Maybe ([a],[a])-split delim list = case delim `elemIndex` list of-    Nothing -> Nothing-    Just x  -> Just $ splitAt x list-    --+crlf, sp :: String crlf = "\r\n" sp   = " " @@ -236,229 +215,6 @@ orNothing p = fmap Just p <++ return Nothing  ------------------------------------------------------------------------------------ Header Data --------------------------------------------------------------------------------------------------------- | The Header data type pairs header names & values.-data Header = Header HeaderName String---instance Show Header where-    show (Header key value) = show key ++ ": " ++ value ++ crlf----- | HTTP Header Name type:---  Why include this at all?  I have some reasons---   1) prevent spelling errors of header names,---   2) remind everyone of what headers are available,---   3) might speed up searches for specific headers.------  Arguments against:---   1) makes customising header names laborious---   2) increases code volume.----data HeaderName = -                 -- Generic Headers ---                  HdrCacheControl-                | HdrConnection-                | HdrDate-                | HdrPragma-                | HdrTransferEncoding        -                | HdrUpgrade                -                | HdrVia--                -- Request Headers ---                | HdrAccept-                | HdrAcceptCharset-                | HdrAcceptEncoding-                | HdrAcceptLanguage-                | HdrAuthorization-                | HdrCookie-                | HdrExpect-                | HdrFrom-                | HdrHost-                | HdrIfModifiedSince-                | HdrIfMatch-                | HdrIfNoneMatch-                | HdrIfRange-                | HdrIfUnmodifiedSince-                | HdrMaxForwards-                | HdrProxyAuthorization-                | HdrRange-                | HdrReferer-                | HdrUserAgent--                -- Response Headers-                | HdrAge-                | HdrLocation-                | HdrProxyAuthenticate-                | HdrPublic-                | HdrRetryAfter-                | HdrServer-                | HdrSetCookie-                | HdrVary-                | HdrWarning-                | HdrWWWAuthenticate--                -- Entity Headers-                | HdrAllow-                | HdrContentBase-                | HdrContentEncoding-                | HdrContentLanguage-                | HdrContentLength-                | HdrContentLocation-                | HdrContentMD5-                | HdrContentRange-                | HdrContentType-                | HdrETag-                | HdrExpires-                | HdrLastModified--                -- Mime entity headers (for sub-parts)-                | HdrContentTransferEncoding--                -- | Allows for unrecognised or experimental headers.-                | HdrCustom String -- not in header map below.-    deriving(Eq)----- Translation between header names and values,--- good candidate for improvement.-headerMap :: [ (String,HeaderName) ]-headerMap - = [  ("Cache-Control"        ,HdrCacheControl      )-	, ("Connection"           ,HdrConnection        )-	, ("Date"                 ,HdrDate              )    -	, ("Pragma"               ,HdrPragma            )-	, ("Transfer-Encoding"    ,HdrTransferEncoding  )        -	, ("Upgrade"              ,HdrUpgrade           )                -	, ("Via"                  ,HdrVia               )-	, ("Accept"               ,HdrAccept            )-	, ("Accept-Charset"       ,HdrAcceptCharset     )-	, ("Accept-Encoding"      ,HdrAcceptEncoding    )-	, ("Accept-Language"      ,HdrAcceptLanguage    )-	, ("Authorization"        ,HdrAuthorization     )-	, ("From"                 ,HdrFrom              )-	, ("Host"                 ,HdrHost              )-	, ("If-Modified-Since"    ,HdrIfModifiedSince   )-	, ("If-Match"             ,HdrIfMatch           )-	, ("If-None-Match"        ,HdrIfNoneMatch       )-	, ("If-Range"             ,HdrIfRange           ) -	, ("If-Unmodified-Since"  ,HdrIfUnmodifiedSince )-	, ("Max-Forwards"         ,HdrMaxForwards       )-	, ("Proxy-Authorization"  ,HdrProxyAuthorization)-	, ("Range"                ,HdrRange             )   -	, ("Referer"              ,HdrReferer           )-	, ("User-Agent"           ,HdrUserAgent         )-	, ("Age"                  ,HdrAge               )-	, ("Location"             ,HdrLocation          )-	, ("Proxy-Authenticate"   ,HdrProxyAuthenticate )-	, ("Public"               ,HdrPublic            )-	, ("Retry-After"          ,HdrRetryAfter        )-	, ("Server"               ,HdrServer            )-	, ("Vary"                 ,HdrVary              )-	, ("Warning"              ,HdrWarning           )-	, ("WWW-Authenticate"     ,HdrWWWAuthenticate   )-	, ("Allow"                ,HdrAllow             )-	, ("Content-Base"         ,HdrContentBase       )-	, ("Content-Encoding"     ,HdrContentEncoding   )-	, ("Content-Language"     ,HdrContentLanguage   )-	, ("Content-Length"       ,HdrContentLength     )-	, ("Content-Location"     ,HdrContentLocation   )-	, ("Content-MD5"          ,HdrContentMD5        )-	, ("Content-Range"        ,HdrContentRange      )-	, ("Content-Type"         ,HdrContentType       )-	, ("ETag"                 ,HdrETag              )-	, ("Expires"              ,HdrExpires           )-	, ("Last-Modified"        ,HdrLastModified      )-   	, ("Set-Cookie"           ,HdrSetCookie         )-	, ("Cookie"               ,HdrCookie            )-    , ("Expect"               ,HdrExpect            ) ]---instance Show HeaderName where-    show (HdrCustom s) = s-    show x = case filter ((==x).snd) headerMap of-                [] -> error "headerMap incomplete"-                (h:_) -> fst h-------- | This class allows us to write generic header manipulation functions--- for both 'Request' and 'Response' data types.-class HasHeaders x where-    getHeaders :: x -> [Header]-    setHeaders :: x -> [Header] -> x------ Header manipulation functions-insertHeader, replaceHeader, insertHeaderIfMissing-    :: HasHeaders a => HeaderName -> String -> a -> a----- | Inserts a header with the given name and value.--- Allows duplicate header names.-insertHeader name value x = setHeaders x newHeaders-    where-        newHeaders = (Header name value) : getHeaders x----- | Adds the new header only if no previous header shares--- the same name.-insertHeaderIfMissing name value x = setHeaders x (newHeaders $ getHeaders x)-    where-        newHeaders list@(h@(Header n _): rest)-            | n == name  = list-            | otherwise  = h : newHeaders rest-        newHeaders [] = [Header name value]--            ---- | Removes old headers with duplicate name.-replaceHeader name value x = setHeaders x newHeaders-    where-        newHeaders = Header name value : [ x | x@(Header n v) <- getHeaders x, name /= n ]-          ---- | Inserts multiple headers.-insertHeaders :: HasHeaders a => [Header] -> a -> a-insertHeaders hdrs x = setHeaders x (getHeaders x ++ hdrs)----- | Gets a list of headers with a particular 'HeaderName'.-retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header]-retrieveHeaders name x = filter matchname (getHeaders x)-    where-        matchname (Header n _)  |  n == name  =  True-        matchname _ = False----- | Lookup presence of specific HeaderName in a list of Headers--- Returns the value from the first matching header.-findHeader :: HasHeaders a => HeaderName -> a -> Maybe String-findHeader n x = lookupHeader n (getHeaders x)---- An anomally really:-lookupHeader :: HeaderName -> [Header] -> Maybe String-lookupHeader v (Header n s:t)  |  v == n   =  Just s-                               | otherwise =  lookupHeader v t-lookupHeader _ _  =  Nothing-----{--instance HasHeaders [Header]-...requires -fglasgow-exts, and is not really necessary anyway...--}--------------------------------------------------------------------- ------------------ HTTP Messages -------------------------------- ----------------------------------------------------------------- @@ -474,6 +230,7 @@ data RequestMethod = HEAD | PUT | GET | POST | DELETE | OPTIONS | TRACE     deriving(Show,Eq) +rqMethodMap :: [(String, RequestMethod)] rqMethodMap = [("HEAD",    HEAD), 	       ("PUT",     PUT), 	       ("GET",     GET),@@ -498,7 +255,6 @@   - -- Notice that request body is not included, -- this show function is used to serialise -- a request for the transport link, we send@@ -512,16 +268,10 @@                         then u { uriPath = '/' : uriPath u }                          else u - instance HasHeaders Request where     getHeaders = rqHeaders     setHeaders rq hdrs = rq { rqHeaders=hdrs } ----- type ResponseCode  = (Int,Int,Int) type ResponseData  = (ResponseCode,String,[Header]) type RequestData   = (RequestMethod,URI,[Header])@@ -538,8 +288,6 @@              , rspBody     :: String              }                    -- -- This is an invalid representation of a received response,  -- since we have made the assumption that all responses are HTTP/1.1 instance Show Response where@@ -547,8 +295,6 @@         httpVersion ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf         ++ foldr (++) [] (map show headers) ++ crlf -- instance HasHeaders Response where     getHeaders = rspHeaders     setHeaders rsp hdrs = rsp { rspHeaders=hdrs }@@ -557,46 +303,6 @@ ------------------ Parsing -------------------------------------- ----------------------------------------------------------------- -parseHeader :: String -> Result Header-parseHeader str =-    case split ':' str of-        Nothing -> Left (ErrorParse $ "Unable to parse header: " ++ str)-        Just (k,v) -> Right $ Header (fn k) (trim $ drop 1 v)-    where-        fn k = case map snd $ filter (match k . fst) headerMap of-                 [] -> (HdrCustom k)-                 (h:_) -> h--        match :: String -> String -> Bool-        match s1 s2 = map toLower s1 == map toLower s2-    --parseHeaders :: [String] -> Result [Header]-parseHeaders = catRslts [] . map (parseHeader . clean) . joinExtended ""-    where-        -- Joins consecutive lines where the second line-        -- begins with ' ' or '\t'.-        joinExtended old (h : t)-            | not (null h) && (head h == ' ' || head h == '\t')-                = joinExtended (old ++ ' ' : tail h) t-            | otherwise = old : joinExtended h t-        joinExtended old [] = [old]--        clean [] = []-        clean (h:t) | h `elem` "\t\r\n" = ' ' : clean t-                    | otherwise = h : clean t--        -- tollerant of errors?  should parse-        -- errors here be reported or ignored?-        -- currently ignored.-        catRslts :: [a] -> [Result a] -> Result [a]-        catRslts list (h:t) = -            case h of-                Left _ -> catRslts list t-                Right v -> catRslts (v:list) t-        catRslts list [] = Right $ reverse list            -        - -- Parsing a request parseRequestHead :: [String] -> Result RequestData parseRequestHead [] = Left ErrorClosed@@ -648,10 +354,6 @@                | Done                | ExpectEntity                | DieHorribly String----  matchResponse :: RequestMethod -> ResponseCode -> Behaviour matchResponse rqst rsp =

@@ -14,13 +14,12 @@ -- ----------------------------------------------------------------------------- -module Network.HTTP.Base64 (-    encode,-    decode,-    chop72-) where--+module Network.HTTP.Base64+   ( encode+   , decode+   , chop72+   , Octet+   ) where  {------------------------------------------------------------------------ This is what RFC2045 had to say:@@ -135,10 +134,8 @@    delimiters within base64-encoded bodies within multipart entities    because no hyphen characters are used in the base64 encoding. - ----------------------------------------------------------------------------} - {-  The following properties should hold:@@ -151,18 +148,14 @@ MIME applications might be undesireable.  - But: The Haskell98 Char type is at least 16bits (and often 32), these implementations assume only       8 significant bits, which is more than enough for US-ASCII.   -}  ---import Data.Array-import Data.Bits-import Data.Int-import Data.Char (chr,ord)+import Data.Array (Array, array, (!))+import Data.Bits (shiftL, shiftR, (.&.), (.|.))+import Data.Char (chr, ord) import Data.Word (Word8)  type Octet = Word8@@ -245,6 +238,7 @@  -- Pads a base64 code to a multiple of 4 characters, using the special -- '=' character.+quadruplets :: [Char] -> [Char] quadruplets (a:b:c:d:t) = a:b:c:d:quadruplets t quadruplets [a,b,c]     = [a,b,c,'=']      -- 16bit tail unit quadruplets [a,b]       = [a,b,'=','=']    -- 8bit tail unit@@ -255,6 +249,7 @@ enc = quadruplets . map enc1  +dcd :: String -> [Int] dcd [] = [] dcd (h:t)     | h <= 'Z' && h >= 'A'  =  ord h - ord 'A'      : dcd t

@@ -0,0 +1,310 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.HTTP.Headers+-- Copyright   :  (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop+-- License     :  BSD+-- +-- Maintainer  :  bjorn@bringert.net+-- Stability   :  experimental+-- Portability :  non-portable (not tested)+--+-- * Changes by Robin Bate Boerop <robin@bateboerop.name>:+--      - Made dependencies explicit in import statements.+--      - Removed false dependencies in import statements.+--      - Added missing type signatures.+--      - Created Network.HTTP.Headers from Network.HTTP modules.+--+-- See changes history and TODO list in Network.HTTP module.+--+-- * Header notes:+--+--     [@Host@]+--                  Required by HTTP\/1.1, if not supplied as part+--                  of a request a default Host value is extracted+--                  from the request-uri.+-- +--     [@Connection@] +--                  If this header is present in any request or+--                  response, and it's value is "close", then+--                  the current request\/response is the last +--                  to be allowed on that connection.+-- +--     [@Expect@]+--                  Should a request contain a body, an Expect+--                  header will be added to the request.  The added+--                  header has the value \"100-continue\".  After+--                  a 417 \"Expectation Failed\" response the request+--                  is attempted again without this added Expect+--                  header.+--                  +--     [@TransferEncoding,ContentLength,...@]+--                  if request is inconsistent with any of these+--                  header values then you may not receive any response+--                  or will generate an error response (probably 4xx).+--+-----------------------------------------------------------------------------+module Network.HTTP.Headers+   ( HasHeaders(..)+   , Header(..)+   , HeaderName(..)+   , insertHeader+   , insertHeaderIfMissing+   , insertHeaders+   , retrieveHeaders+   , replaceHeader+   , findHeader+   , lookupHeader+   , parseHeaders+   ) where++import Data.Char (isSpace, toLower)+import Data.List (elemIndex)+import Network.Stream (Result, ConnError(ErrorParse))++-- remove leading and trailing whitespace.+trim :: String -> String+trim = let dropspace = dropWhile isSpace in+       reverse . dropspace . reverse . dropspace++-- Split a list into two parts, the delimiter occurs+-- at the head of the second list.  Nothing is returned+-- when no occurance of the delimiter is found.+split :: Eq a => a -> [a] -> Maybe ([a],[a])+split delim list = case delim `elemIndex` list of+    Nothing -> Nothing+    Just x  -> Just $ splitAt x list++crlf :: String+crlf = "\r\n"++-- | The Header data type pairs header names & values.+data Header = Header HeaderName String++instance Show Header where+    show (Header key value) = show key ++ ": " ++ value ++ crlf++-- | HTTP Header Name type:+--  Why include this at all?  I have some reasons+--   1) prevent spelling errors of header names,+--   2) remind everyone of what headers are available,+--   3) might speed up searches for specific headers.+--+--  Arguments against:+--   1) makes customising header names laborious+--   2) increases code volume.+--+data HeaderName = +                 -- Generic Headers --+                  HdrCacheControl+                | HdrConnection+                | HdrDate+                | HdrPragma+                | HdrTransferEncoding        +                | HdrUpgrade                +                | HdrVia++                -- Request Headers --+                | HdrAccept+                | HdrAcceptCharset+                | HdrAcceptEncoding+                | HdrAcceptLanguage+                | HdrAuthorization+                | HdrCookie+                | HdrExpect+                | HdrFrom+                | HdrHost+                | HdrIfModifiedSince+                | HdrIfMatch+                | HdrIfNoneMatch+                | HdrIfRange+                | HdrIfUnmodifiedSince+                | HdrMaxForwards+                | HdrProxyAuthorization+                | HdrRange+                | HdrReferer+                | HdrUserAgent++                -- Response Headers+                | HdrAge+                | HdrLocation+                | HdrProxyAuthenticate+                | HdrPublic+                | HdrRetryAfter+                | HdrServer+                | HdrSetCookie+                | HdrVary+                | HdrWarning+                | HdrWWWAuthenticate++                -- Entity Headers+                | HdrAllow+                | HdrContentBase+                | HdrContentEncoding+                | HdrContentLanguage+                | HdrContentLength+                | HdrContentLocation+                | HdrContentMD5+                | HdrContentRange+                | HdrContentType+                | HdrETag+                | HdrExpires+                | HdrLastModified++                -- Mime entity headers (for sub-parts)+                | HdrContentTransferEncoding++                -- | Allows for unrecognised or experimental headers.+                | HdrCustom String -- not in header map below.+    deriving(Eq)++-- Translation between header names and values,+-- good candidate for improvement.+headerMap :: [ (String,HeaderName) ]+headerMap + = [  ("Cache-Control"        ,HdrCacheControl      )+	, ("Connection"           ,HdrConnection        )+	, ("Date"                 ,HdrDate              )    +	, ("Pragma"               ,HdrPragma            )+	, ("Transfer-Encoding"    ,HdrTransferEncoding  )        +	, ("Upgrade"              ,HdrUpgrade           )                +	, ("Via"                  ,HdrVia               )+	, ("Accept"               ,HdrAccept            )+	, ("Accept-Charset"       ,HdrAcceptCharset     )+	, ("Accept-Encoding"      ,HdrAcceptEncoding    )+	, ("Accept-Language"      ,HdrAcceptLanguage    )+	, ("Authorization"        ,HdrAuthorization     )+	, ("From"                 ,HdrFrom              )+	, ("Host"                 ,HdrHost              )+	, ("If-Modified-Since"    ,HdrIfModifiedSince   )+	, ("If-Match"             ,HdrIfMatch           )+	, ("If-None-Match"        ,HdrIfNoneMatch       )+	, ("If-Range"             ,HdrIfRange           ) +	, ("If-Unmodified-Since"  ,HdrIfUnmodifiedSince )+	, ("Max-Forwards"         ,HdrMaxForwards       )+	, ("Proxy-Authorization"  ,HdrProxyAuthorization)+	, ("Range"                ,HdrRange             )   +	, ("Referer"              ,HdrReferer           )+	, ("User-Agent"           ,HdrUserAgent         )+	, ("Age"                  ,HdrAge               )+	, ("Location"             ,HdrLocation          )+	, ("Proxy-Authenticate"   ,HdrProxyAuthenticate )+	, ("Public"               ,HdrPublic            )+	, ("Retry-After"          ,HdrRetryAfter        )+	, ("Server"               ,HdrServer            )+	, ("Vary"                 ,HdrVary              )+	, ("Warning"              ,HdrWarning           )+	, ("WWW-Authenticate"     ,HdrWWWAuthenticate   )+	, ("Allow"                ,HdrAllow             )+	, ("Content-Base"         ,HdrContentBase       )+	, ("Content-Encoding"     ,HdrContentEncoding   )+	, ("Content-Language"     ,HdrContentLanguage   )+	, ("Content-Length"       ,HdrContentLength     )+	, ("Content-Location"     ,HdrContentLocation   )+	, ("Content-MD5"          ,HdrContentMD5        )+	, ("Content-Range"        ,HdrContentRange      )+	, ("Content-Type"         ,HdrContentType       )+	, ("ETag"                 ,HdrETag              )+	, ("Expires"              ,HdrExpires           )+	, ("Last-Modified"        ,HdrLastModified      )+   	, ("Set-Cookie"           ,HdrSetCookie         )+	, ("Cookie"               ,HdrCookie            )+    , ("Expect"               ,HdrExpect            ) ]+++instance Show HeaderName where+    show (HdrCustom s) = s+    show x = case filter ((==x).snd) headerMap of+                [] -> error "headerMap incomplete"+                (h:_) -> fst h++-- | This class allows us to write generic header manipulation functions+-- for both 'Request' and 'Response' data types.+class HasHeaders x where+    getHeaders :: x -> [Header]+    setHeaders :: x -> [Header] -> x++-- Header manipulation functions+insertHeader, replaceHeader, insertHeaderIfMissing+    :: HasHeaders a => HeaderName -> String -> a -> a+++-- | Inserts a header with the given name and value.+-- Allows duplicate header names.+insertHeader name value x = setHeaders x newHeaders+    where+        newHeaders = (Header name value) : getHeaders x++-- | Adds the new header only if no previous header shares+-- the same name.+insertHeaderIfMissing name value x = setHeaders x (newHeaders $ getHeaders x)+    where+        newHeaders list@(h@(Header n _): rest)+            | n == name  = list+            | otherwise  = h : newHeaders rest+        newHeaders [] = [Header name value]++-- | Removes old headers with duplicate name.+replaceHeader name value x = setHeaders x newHeaders+    where+        newHeaders = Header name value : [ x | x@(Header n v) <- getHeaders x, name /= n ]+          +-- | Inserts multiple headers.+insertHeaders :: HasHeaders a => [Header] -> a -> a+insertHeaders hdrs x = setHeaders x (getHeaders x ++ hdrs)++-- | Gets a list of headers with a particular 'HeaderName'.+retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header]+retrieveHeaders name x = filter matchname (getHeaders x)+    where+        matchname (Header n _)  |  n == name  =  True+        matchname _ = False++-- | Lookup presence of specific HeaderName in a list of Headers+-- Returns the value from the first matching header.+findHeader :: HasHeaders a => HeaderName -> a -> Maybe String+findHeader n x = lookupHeader n (getHeaders x)++-- An anomally really:+lookupHeader :: HeaderName -> [Header] -> Maybe String+lookupHeader v (Header n s:t)  |  v == n   =  Just s+                               | otherwise =  lookupHeader v t+lookupHeader _ _  =  Nothing++parseHeader :: String -> Result Header+parseHeader str =+    case split ':' str of+        Nothing -> Left (ErrorParse $ "Unable to parse header: " ++ str)+        Just (k,v) -> Right $ Header (fn k) (trim $ drop 1 v)+    where+        fn k = case map snd $ filter (match k . fst) headerMap of+                 [] -> (HdrCustom k)+                 (h:_) -> h++        match :: String -> String -> Bool+        match s1 s2 = map toLower s1 == map toLower s2+    +parseHeaders :: [String] -> Result [Header]+parseHeaders =+   catRslts [] . map (parseHeader . clean) . joinExtended ""+   where+        -- Joins consecutive lines where the second line+        -- begins with ' ' or '\t'.+        joinExtended old (h : t)+            | not (null h) && (head h == ' ' || head h == '\t')+                = joinExtended (old ++ ' ' : tail h) t+            | otherwise = old : joinExtended h t+        joinExtended old [] = [old]++        clean [] = []+        clean (h:t) | h `elem` "\t\r\n" = ' ' : clean t+                    | otherwise = h : clean t++        -- tollerant of errors?  should parse+        -- errors here be reported or ignored?+        -- currently ignored.+        catRslts :: [a] -> [Result a] -> Result [a]+        catRslts list (h:t) = +            case h of+                Left _ -> catRslts list t+                Right v -> catRslts (v:list) t+        catRslts list [] = Right $ reverse list            

@@ -16,17 +16,18 @@ -- ----------------------------------------------------------------------------- -module Network.HTTP.MD5 (-   -- * Function Types-   hash) where--import Data.Char(chr)-import Data.List(unfoldr)-import Numeric(readHex)+module Network.HTTP.MD5+   ( hash+   , Octet+   ) where -import Network.HTTP.MD5Aux+import Data.Char (chr)+import Data.List (unfoldr) import Data.Word (Word8)+import Numeric (readHex) +import Network.HTTP.MD5Aux (md5s, Str(Str))+ type Octet = Word8  -- | Take [Octet] and return [Octet] according to the standard.@@ -37,8 +38,6 @@ hash xs =     unfoldr f $ md5s $ Str $ map (chr . fromIntegral) xs       where f :: String -> Maybe (Octet,String)-            f [] = -               Nothing-            f (x:y:zs) = -               Just (fromIntegral a,zs)-	       where [(a,_)] = readHex (x:y:[])+            f []       = Nothing+            f (x:y:zs) = Just (fromIntegral a,zs)+                         where [(a,_)] = readHex (x:y:[])

@@ -3,9 +3,9 @@     MD5(..), ABCD(..),      Zord64, Str(..), BoolList(..), WordList(..)) where -import Data.Char-import Data.Bits-import Data.Word+import Data.Char (ord, chr)+import Data.Bits (rotateL, shiftL, shiftR, (.&.), (.|.), xor, complement)+import Data.Word (Word32, Word64)  rotL x = rotateL x type Zord64 = Word64

@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Network.Stream--- Copyright   :  (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004+-- Copyright   :  (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004, 2007 Robin Bate Boerop -- License     :  BSD -- -- Maintainer  :  bjorn@bringert.net@@ -11,36 +11,21 @@ -- An library for creating abstract streams. Originally part of Gray's\/Bringert's -- HTTP module. --+-- * Changes by Robin Bate Boerop <robin@bateboerop.name>:+--      - Removed unnecessary import statements.+--      - Moved Debug code to StreamDebugger.hs+--      - Moved Socket-related code to StreamSocket.hs.+-- -- * Changes by Simon Foster:---      - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules---      +--      - Split Network.HTTPmodule up into to separate+--        Network.[Stream,TCP,HTTP] modules ------------------------------------------------------------------------------module Network.Stream (-    -- ** Streams-    Debug,-    Stream(..),-    debugStream,-    -    -- ** Errors-    ConnError(..),-    Result,-    handleSocketError,-    bindE,-    myrecv--) where--import Control.Exception as Exception-import System.IO.Error---- Networking-import Network (withSocketsDo)-import Network.BSD-import Network.URI-import Network.Socket--import Control.Monad (when,liftM,guard)-import System.IO+module Network.Stream+   ( Stream(..)+   , ConnError(..)+   , Result+   , bindE+   ) where  data ConnError = ErrorReset                 | ErrorClosed@@ -48,10 +33,7 @@                | ErrorMisc String     deriving(Show,Eq) --- error propagating:--- we could've used a monad, but that would lead us--- into using the "-fglasgow-exts" compile flag.-bindE :: Either ConnError a -> (a -> Either ConnError b) -> Either ConnError b+bindE :: Result a -> (a -> Result b) -> Result b bindE (Left e)  _ = Left e bindE (Right v) f = f v @@ -59,10 +41,6 @@ type Result a = Either ConnError   {- error  -}                        a           {- result -} ------------------------------------------------------------------------------------- Gentle Art of Socket Sucking ------------------------------------------------------------------------------------ -- | Streams should make layering of TLS protocol easier in future, -- they allow reading/writing to files etc for debugging, -- they allow use of protocols other than TCP/IP@@ -78,99 +56,3 @@     writeBlock :: x -> String -> IO (Result ())     close      :: x -> IO () ------- Exception handler for socket operations-handleSocketError :: Socket -> Exception -> IO (Result a)-handleSocketError sk e =-    do { se <- getSocketOption sk SoError-       ; if se == 0-            then throw e-            else return $ if se == 10054       -- reset-                then Left ErrorReset-                else Left $ ErrorMisc $ show se-       }-----instance Stream Socket where-    readBlock sk n = (liftM Right $ fn n) `Exception.catch` (handleSocketError sk)-        where-            fn x = do { str <- myrecv sk x-                      ; let len = length str-                      ; if len < x-                          then ( fn (x-len) >>= \more -> return (str++more) )                        -                          else return str-                      }--    -- Use of the following function is discouraged.-    -- The function reads in one character at a time, -    -- which causes many calls to the kernel recv()-    -- hence causes many context switches.-    readLine sk = (liftM Right $ fn "") `Exception.catch` (handleSocketError sk)-            where-                fn str =-                    do { c <- myrecv sk 1 -- like eating through a straw.-                       ; if null c || c == "\n"-                           then return (reverse str++c)-                           else fn (head c:str)-                       }-    -    writeBlock sk str = (liftM Right $ fn str) `Exception.catch` (handleSocketError sk)-        where-            fn [] = return ()-            fn x  = send sk x >>= \i -> fn (drop i x)--    -- This slams closed the connection (which is considered rude for TCP\/IP)-    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---- | Allows stream logging.--- Refer to 'debugStream' below.-data Debug x = Dbg Handle x---instance (Stream x) => Stream (Debug x) where-    readBlock (Dbg h c) n =-        do { val <- readBlock c n-           ; hPutStrLn h ("readBlock " ++ show n ++ ' ' : show val)-           ; return val-           }--    readLine (Dbg h c) =-        do { val <- readLine c-           ; hPutStrLn h ("readLine " ++ show val)-           ; return val-           }--    writeBlock (Dbg h c) str =-        do { val <- writeBlock c str-           ; hPutStrLn h ("writeBlock " ++ show val ++ ' ' : show str)-           ; return val-           }--    close (Dbg h c) =-        do { hPutStrLn h "closing..."-           ; hFlush h-           ; close c-           ; hPutStrLn h "...closed"-           ; hClose h-           }----- | Wraps a stream with logging I\/O, the first--- argument is a filename which is opened in AppendMode.-debugStream :: (Stream a) => String -> a -> IO (Debug a)-debugStream file stm = -    do { h <- openFile file AppendMode-       ; hPutStrLn h "File opened for appending."-       ; return (Dbg h stm)-       }

@@ -0,0 +1,59 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.StreamDebugger+-- Copyright   :  (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004, 2007 Robin Bate Boerop+-- License     :  BSD+--+-- Maintainer  :  bjorn@bringert.net+-- Stability   :  experimental+-- Portability :  non-portable (not tested)+--+-- Implements debugging of @Stream@s.  Originally part of Gray's\/Bringert's+-- HTTP module.+--+-- * Changes by Robin Bate Boerop <robin@bateboerop.name>:+--      - Created.  Made minor formatting changes.+--      +-----------------------------------------------------------------------------+module Network.StreamDebugger+   ( StreamDebugger+   , debugStream+   ) where++import Network.Stream (Stream(..))+import System.IO+   ( Handle, hFlush, hPutStrLn, IOMode(AppendMode), hClose, openFile+   )++-- | Allows stream logging.  Refer to 'debugStream' below.+data StreamDebugger x+   = Dbg Handle x++instance (Stream x) => Stream (StreamDebugger x) where+    readBlock (Dbg h x) n =+        do val <- readBlock x n+           hPutStrLn h ("readBlock " ++ show n ++ ' ' : show val)+           return val+    readLine (Dbg h x) =+        do val <- readLine x+           hPutStrLn h ("readLine " ++ show val)+           return val+    writeBlock (Dbg h x) str =+        do val <- writeBlock x str+           hPutStrLn h ("writeBlock " ++ show val ++ ' ' : show str)+           return val+    close (Dbg h x) =+        do hPutStrLn h "closing..."+           hFlush h+           close x+           hPutStrLn h "...closed"+           hClose h++-- | Wraps a stream with logging I\/O.+--   The first argument is a filename which is opened in @AppendMode@.+debugStream :: (Stream a) => FilePath -> a -> IO (StreamDebugger a)+debugStream file stream = +    do h <- openFile file AppendMode+       hPutStrLn h ("File \"" ++ file ++ "\" opened for appending.")+       return (Dbg h stream)+

@@ -0,0 +1,83 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Network.StreamSocket+-- Copyright   :  (c) Warrick Gray 2002, Bjorn Bringert 2003-2004, Simon Foster 2004, 2007 Robin Bate Boerop.+-- License     :  BSD+--+-- Maintainer  :  bjorn@bringert.net+-- Stability   :  experimental+-- Portability :  non-portable (not tested)+--+-- Socket Stream instance. Originally part of Gray's\/Bringert's HTTP module.+--+-- * Changes by Robin Bate Boerop <robin@bateboerop.name>:+--      - Made dependencies explicit in import statements.+--      - Removed false dependencies in import statements.+--      - Created separate module for instance Stream Socket.+--+-- * Changes by Simon Foster:+--      - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules+--      +-----------------------------------------------------------------------------+module Network.StreamSocket+   ( handleSocketError+   , myrecv+   ) where++import Network.Stream+   ( Stream(..), ConnError(ErrorReset, ErrorMisc), Result+   )+import Network.Socket+   ( Socket, getSocketOption, shutdown, send, recv, sClose+   , ShutdownCmd(ShutdownBoth), SocketOption(SoError)+   )++import Control.Monad (liftM)+import Control.Exception as Exception (Exception, catch, throw)+import System.IO.Error (catch, isEOFError)++-- | Exception handler for socket operations.+handleSocketError :: Socket -> Exception -> IO (Result a)+handleSocketError sk e =+    do se <- getSocketOption sk SoError+       case se of+          0     -> throw e+          10054 -> return $ Left ErrorReset  -- reset+          _     -> return $ Left $ ErrorMisc $ show se++instance Stream Socket where+    readBlock sk n = (liftM Right $ fn n) `Exception.catch` (handleSocketError sk)+        where+            fn x = do { str <- myrecv sk x+                      ; let len = length str+                      ; if len < x+                          then ( fn (x-len) >>= \more -> return (str++more) )                        +                          else return str+                      }++    -- Use of the following function is discouraged.+    -- The function reads in one character at a time, +    -- which causes many calls to the kernel recv()+    -- hence causes many context switches.+    readLine sk = (liftM Right $ fn "") `Exception.catch` (handleSocketError sk)+            where+                fn str =+                    do { c <- myrecv sk 1 -- like eating through a straw.+                       ; if null c || c == "\n"+                           then return (reverse str++c)+                           else fn (head c:str)+                       }+    +    writeBlock sk str = (liftM Right $ fn str) `Exception.catch` (handleSocketError sk)+        where+            fn [] = return ()+            fn x  = send sk x >>= \i -> fn (drop i x)++    -- This slams closed the connection (which is considered rude for TCP\/IP)+    close sk = shutdown sk ShutdownBoth >> sClose sk++myrecv :: Socket -> Int -> IO String+myrecv sock len =+    let handler e = if isEOFError e then return [] else ioError e+        in System.IO.Error.catch (recv sock len) handler+

@@ -11,33 +11,40 @@ -- An easy access TCP library. Makes the use of TCP in Haskell much easier. -- This was originally part of Gray's\/Bringert's HTTP module. --+-- * Changes by Robin Bate Boerop <robin@bateboerop.name>:+--      - Made dependencies explicit in import statements.+--      - Removed false dependencies from import statements.+--      - Removed unused exported functions.+-- -- * Changes by Simon Foster: --      - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules --       ------------------------------------------------------------------------------module Network.TCP (-    -- ** Connections-    Conn(..),-    Connection(..),-    openTCP,-    openTCPPort,-    isConnectedTo-) where--import Control.Exception as Exception+module Network.TCP+   ( Connection+   , openTCPPort+   , isConnectedTo+   ) where --- Networking-import Network (withSocketsDo)-import Network.BSD-import Network.URI+import Network.BSD (getHostByName, hostAddresses) import Network.Socket+   ( Socket, SockAddr(SockAddrInet), SocketOption(KeepAlive, SoError)+   , SocketType(Stream), inet_addr, connect, sendTo+   , shutdown, ShutdownCmd(ShutdownSend, ShutdownReceive)+   , sClose, sIsConnected, setSocketOption, getSocketOption+   , socket, Family(AF_INET)+   ) import Network.Stream+   ( Stream(readBlock, readLine, writeBlock, close)+   , ConnError(ErrorMisc, ErrorReset, ErrorClosed)+   , bindE+   )+import Network.StreamSocket (myrecv, handleSocketError) -import Data.List (isPrefixOf,partition,elemIndex)-import Data.Char-import Data.IORef-import Control.Monad (when,liftM,guard)-import System.IO+import Control.Exception as Exception (catch, throw)+import Data.List (elemIndex)+import Data.Char (toLower)+import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)  ----------------------------------------------------------------- ------------------ TCP Connections ------------------------------@@ -50,9 +57,6 @@ -- implementation of the 'Stream Connection' instance. newtype Connection = ConnRef {getRef :: IORef Conn} ---- | The 'Conn' object allows input buffering, and maintenance of --- some admin-type data. data Conn = MkConn { connSock :: ! Socket                    , connAddr :: ! SockAddr                     , connBffr :: ! String @@ -60,12 +64,6 @@                    }           | ConnClosed     deriving(Eq)----- | Open a connection to port 80 on a remote host.-openTCP :: String -> IO Connection-openTCP host = openTCPPort host 80-  -- | This function establishes a connection to a remote -- host, it uses "getHostByName" which interrogates the