diff --git a/HTTP.cabal b/HTTP.cabal --- a/HTTP.cabal +++ b/HTTP.cabal @@ -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 Maintainer: Bjorn Bringert 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, diff --git a/Network/Browser.hs b/Network/Browser.hs --- a/Network/Browser.hs +++ b/Network/Browser.hs @@ -12,6 +12,10 @@ ----------------------------------------------------------------------------- {- + Changes by Robin Bate Boerop : + - 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 diff --git a/Network/HTTP.hs b/Network/HTTP.hs --- a/Network/HTTP.hs +++ b/Network/HTTP.hs @@ -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 : +-- - 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 = diff --git a/Network/HTTP/Base64.hs b/Network/HTTP/Base64.hs --- a/Network/HTTP/Base64.hs +++ b/Network/HTTP/Base64.hs @@ -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 diff --git a/Network/HTTP/Headers.hs b/Network/HTTP/Headers.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Headers.hs @@ -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 : +-- - 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 diff --git a/Network/HTTP/MD5.hs b/Network/HTTP/MD5.hs --- a/Network/HTTP/MD5.hs +++ b/Network/HTTP/MD5.hs @@ -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:[]) diff --git a/Network/HTTP/MD5Aux.hs b/Network/HTTP/MD5Aux.hs --- a/Network/HTTP/MD5Aux.hs +++ b/Network/HTTP/MD5Aux.hs @@ -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 diff --git a/Network/Stream.hs b/Network/Stream.hs --- a/Network/Stream.hs +++ b/Network/Stream.hs @@ -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 : +-- - 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) - } diff --git a/Network/StreamDebugger.hs b/Network/StreamDebugger.hs new file mode 100644 --- /dev/null +++ b/Network/StreamDebugger.hs @@ -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 : +-- - 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) + diff --git a/Network/StreamSocket.hs b/Network/StreamSocket.hs new file mode 100644 --- /dev/null +++ b/Network/StreamSocket.hs @@ -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 : +-- - 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 + diff --git a/Network/TCP.hs b/Network/TCP.hs --- a/Network/TCP.hs +++ b/Network/TCP.hs @@ -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 : +-- - 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