module Network.HTTP (
module Network.Stream,
module Network.TCP,
httpVersion,
Request(..),
Response(..),
RequestMethod(..),
ResponseCode,
simpleHTTP, simpleHTTP_,
sendHTTP,
receiveHTTP,
respondHTTP,
HasHeaders,
Header(..),
HeaderName(..),
insertHeader,
insertHeaderIfMissing,
insertHeaders,
retrieveHeaders,
replaceHeader,
findHeader,
urlEncode,
urlDecode,
urlEncodeVars,
URIAuthority(..),
parseURIAuthority
) where
import Control.Exception as Exception
import Network (withSocketsDo)
import Network.BSD
import Network.URI
import Network.Socket
import Network.Stream
import Network.TCP
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 Numeric (readHex)
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
debug :: Bool
debug = False
httpLogFile :: String
httpLogFile = "http-debug.log"
trim :: String -> String
trim = let dropspace = dropWhile isSpace in
reverse . dropspace . reverse . dropspace
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 = "\r\n"
sp = " "
data URIAuthority = URIAuthority { user :: Maybe String,
password :: Maybe String,
host :: String,
port :: Maybe Int
} deriving (Eq,Show)
parseURIAuthority :: String -> Maybe URIAuthority
parseURIAuthority s = listToMaybe (map fst (readP_to_S pURIAuthority s))
pURIAuthority :: ReadP URIAuthority
pURIAuthority = do
(u,pw) <- (pUserInfo `before` char '@')
<++ return (Nothing, Nothing)
h <- munch (/=':')
p <- orNothing (char ':' >> readDecP)
look >>= guard . null
return URIAuthority{ user=u, password=pw, host=h, port=p }
pUserInfo :: ReadP (Maybe String, Maybe String)
pUserInfo = do
u <- orNothing (munch (`notElem` ":@"))
p <- orNothing (char ':' >> munch (/='@'))
return (u,p)
before :: Monad m => m a -> m b -> m a
before a b = a >>= \x -> b >> return x
orNothing :: ReadP a -> ReadP (Maybe a)
orNothing p = fmap Just p <++ return Nothing
data Header = Header HeaderName String
instance Show Header where
show (Header key value) = show key ++ ": " ++ value ++ crlf
data HeaderName =
HdrCacheControl
| HdrConnection
| HdrDate
| HdrPragma
| HdrTransferEncoding
| HdrUpgrade
| HdrVia
| HdrAccept
| HdrAcceptCharset
| HdrAcceptEncoding
| HdrAcceptLanguage
| HdrAuthorization
| HdrCookie
| HdrExpect
| HdrFrom
| HdrHost
| HdrIfModifiedSince
| HdrIfMatch
| HdrIfNoneMatch
| HdrIfRange
| HdrIfUnmodifiedSince
| HdrMaxForwards
| HdrProxyAuthorization
| HdrRange
| HdrReferer
| HdrUserAgent
| HdrAge
| HdrLocation
| HdrProxyAuthenticate
| HdrPublic
| HdrRetryAfter
| HdrServer
| HdrSetCookie
| HdrVary
| HdrWarning
| HdrWWWAuthenticate
| HdrAllow
| HdrContentBase
| HdrContentEncoding
| HdrContentLanguage
| HdrContentLength
| HdrContentLocation
| HdrContentMD5
| HdrContentRange
| HdrContentType
| HdrETag
| HdrExpires
| HdrLastModified
| HdrContentTransferEncoding
| HdrCustom String
deriving(Eq)
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
class HasHeaders x where
getHeaders :: x -> [Header]
setHeaders :: x -> [Header] -> x
insertHeader, replaceHeader, insertHeaderIfMissing
:: HasHeaders a => HeaderName -> String -> a -> a
insertHeader name value x = setHeaders x newHeaders
where
newHeaders = (Header name value) : getHeaders x
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]
replaceHeader name value x = setHeaders x newHeaders
where
newHeaders = Header name value : [ x | x@(Header n v) <- getHeaders x, name /= n ]
insertHeaders :: HasHeaders a => [Header] -> a -> a
insertHeaders hdrs x = setHeaders x (getHeaders x ++ hdrs)
retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header]
retrieveHeaders name x = filter matchname (getHeaders x)
where
matchname (Header n _) | n == name = True
matchname _ = False
findHeader :: HasHeaders a => HeaderName -> a -> Maybe String
findHeader n x = lookupHeader n (getHeaders x)
lookupHeader :: HeaderName -> [Header] -> Maybe String
lookupHeader v (Header n s:t) | v == n = Just s
| otherwise = lookupHeader v t
lookupHeader _ _ = Nothing
httpVersion :: String
httpVersion = "HTTP/1.1"
data RequestMethod = HEAD | PUT | GET | POST | DELETE | OPTIONS | TRACE
deriving(Show,Eq)
rqMethodMap = [("HEAD", HEAD),
("PUT", PUT),
("GET", GET),
("POST", POST),
("DELETE", DELETE),
("OPTIONS", OPTIONS),
("TRACE", TRACE)]
data Request =
Request { rqURI :: URI
, rqMethod :: RequestMethod
, rqHeaders :: [Header]
, rqBody :: String
}
instance Show Request where
show (Request u m h _) =
show m ++ sp ++ alt_uri ++ sp ++ httpVersion ++ crlf
++ foldr (++) [] (map show h) ++ crlf
where
alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/'
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])
data Response =
Response { rspCode :: ResponseCode
, rspReason :: String
, rspHeaders :: [Header]
, rspBody :: String
}
instance Show Response where
show (Response (a,b,c) reason headers _) =
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 }
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
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
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
parseRequestHead :: [String] -> Result RequestData
parseRequestHead [] = Left ErrorClosed
parseRequestHead (com:hdrs) =
requestCommand com `bindE` \(version,rqm,uri) ->
parseHeaders hdrs `bindE` \hdrs' ->
Right (rqm,uri,hdrs')
where
requestCommand line
= case words line of
yes@(rqm:uri:version) -> case (parseURIReference uri, lookup rqm rqMethodMap) of
(Just u, Just r) -> Right (version,r,u)
_ -> Left (ErrorParse $ "Request command line parse failure: " ++ line)
no -> if null line
then Left ErrorClosed
else Left (ErrorParse $ "Request command line parse failure: " ++ line)
parseResponseHead :: [String] -> Result ResponseData
parseResponseHead [] = Left ErrorClosed
parseResponseHead (sts:hdrs) =
responseStatus sts `bindE` \(version,code,reason) ->
parseHeaders hdrs `bindE` \hdrs' ->
Right (code,reason,hdrs')
where
responseStatus line
= case words line of
yes@(version:code:reason) -> Right (version,match code,concatMap (++" ") reason)
no -> if null line
then Left ErrorClosed
else Left (ErrorParse $ "Response status line parse failure: " ++ line)
match [a,b,c] = (digitToInt a,
digitToInt b,
digitToInt c)
match _ = (1,1,1)
data Behaviour = Continue
| Retry
| Done
| ExpectEntity
| DieHorribly String
matchResponse :: RequestMethod -> ResponseCode -> Behaviour
matchResponse rqst rsp =
case rsp of
(1,0,0) -> Continue
(1,0,1) -> Done
(1,_,_) -> Continue
(2,0,4) -> Done
(2,0,5) -> Done
(2,_,_) -> ans
(3,0,4) -> Done
(3,0,5) -> Done
(3,_,_) -> ans
(4,1,7) -> Retry
(4,_,_) -> ans
(5,_,_) -> ans
(a,b,c) -> DieHorribly ("Response code " ++ map intToDigit [a,b,c] ++ " not recognised")
where
ans | rqst == HEAD = Done
| otherwise = ExpectEntity
simpleHTTP :: Request -> IO (Result Response)
simpleHTTP r =
do
auth <- getAuth r
c <- openTCPPort (host auth) (fromMaybe 80 (port auth))
simpleHTTP_ c r
simpleHTTP_ :: Stream s => s -> Request -> IO (Result Response)
simpleHTTP_ s r =
do
auth <- getAuth r
let r' = fixReq auth r
rsp <- if debug then do
s' <- debugStream httpLogFile s
sendHTTP s' r'
else
sendHTTP s r'
return rsp
where
fixReq :: URIAuthority -> Request -> Request
fixReq URIAuthority{host=h} r =
replaceHeader HdrConnection "close" $
insertHeaderIfMissing HdrHost h $
r { rqURI = (rqURI r){ uriScheme = "",
uriAuthority = Nothing } }
getAuth :: Monad m => Request -> m URIAuthority
getAuth r = case parseURIAuthority auth of
Just x -> return x
Nothing -> fail $ "Error parsing URI authority '"
++ auth ++ "'"
where auth = case findHeader HdrHost r of
Just h -> h
Nothing -> uriToAuthorityString (rqURI r)
sendHTTP :: Stream s => s -> Request -> IO (Result Response)
sendHTTP conn rq =
do { let a_rq = fixHostHeader rq
; rsp <- Exception.catch (main a_rq)
(\e -> do { close conn; throw e })
; let fn list = when (or $ map findConnClose list)
(close conn)
; either (\_ -> fn [rqHeaders rq])
(\r -> fn [rqHeaders rq,rspHeaders r])
rsp
; return rsp
}
where
main :: Request -> IO (Result Response)
main rqst =
do
writeBlock conn (show rqst)
writeBlock conn (rqBody rqst)
rsp <- getResponseHead
switchResponse True False rsp rqst
getResponseHead :: IO (Result ResponseData)
getResponseHead =
do { lor <- readTillEmpty1 conn
; return $ lor `bindE` parseResponseHead
}
switchResponse :: Bool
-> Bool
-> Result ResponseData
-> Request
-> IO (Result Response)
switchResponse _ _ (Left e) _ = return (Left e)
switchResponse allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst =
case matchResponse (rqMethod rqst) cd of
Continue
| not bdy_sent ->
do { val <- writeBlock conn (rqBody rqst)
; case val of
Left e -> return (Left e)
Right _ ->
do { rsp <- getResponseHead
; switchResponse allow_retry True rsp rqst
}
}
| otherwise ->
do { rsp <- getResponseHead
; switchResponse allow_retry bdy_sent rsp rqst
}
Retry ->
do { writeBlock conn (show rqst ++ rqBody rqst)
; rsp <- getResponseHead
; switchResponse False bdy_sent rsp rqst
}
Done ->
return (Right $ Response cd rn hdrs "")
DieHorribly str ->
return $ Left $ ErrorParse ("Invalid response: " ++ str)
ExpectEntity ->
let tc = lookupHeader HdrTransferEncoding hdrs
cl = lookupHeader HdrContentLength hdrs
in
do { rslt <- case tc of
Nothing ->
case cl of
Just x -> linearTransfer conn (read x :: Int)
Nothing -> hopefulTransfer conn ""
Just x ->
case map toLower (trim x) of
"chunked" -> chunkedTransfer conn
_ -> uglyDeathTransfer conn
; return $ rslt `bindE` \(ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy)
}
fixHostHeader :: Request -> Request
fixHostHeader rq =
let uri = rqURI rq
host = uriToAuthorityString uri
in insertHeaderIfMissing HdrHost host rq
findConnClose :: [Header] -> Bool
findConnClose hdrs =
case lookupHeader HdrConnection hdrs of
Nothing -> False
Just x -> map toLower (trim x) == "close"
uriToAuthorityString :: URI -> String
uriToAuthorityString URI{uriAuthority=Nothing} = ""
uriToAuthorityString URI{uriAuthority=Just ua} = uriUserInfo ua ++
uriRegName ua ++
uriPort ua
receiveHTTP :: Stream s => s -> IO (Result Request)
receiveHTTP conn = do rq <- getRequestHead
processRequest rq
where
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
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 ([], ""))
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)
respondHTTP :: Stream s => s -> Response -> IO ()
respondHTTP conn rsp = do writeBlock conn (show rsp)
writeBlock conn (rspBody rsp)
return ()
linearTransfer :: Stream s => s -> Int -> IO (Result ([Header],String))
linearTransfer conn n
= do info <- readBlock conn n
return $ info `bindE` \str -> Right ([],str)
hopefulTransfer :: Stream s => s -> String -> IO (Result ([Header],String))
hopefulTransfer conn str
= readLine conn >>=
either (\v -> return $ Left v)
(\more -> if null more
then return (Right ([],str))
else hopefulTransfer conn (str++more))
chunkedTransfer :: Stream s => s -> IO (Result ([Header],String))
chunkedTransfer conn
= chunkedTransferC conn 0 >>= \v ->
return $ v `bindE` \(ftrs,count,info) ->
let myftrs = Header HdrContentLength (show count) : ftrs
in Right (myftrs,info)
chunkedTransferC :: Stream s => s -> Int -> IO (Result ([Header],Int,String))
chunkedTransferC conn n
= readLine conn >>= \v -> case v of
Left e -> return (Left e)
Right line ->
let size = ( if null line || (head line) == '0'
then 0
else case readHex line of
(n,_):_ -> n
_ -> 0
)
in if size == 0
then do { rs <- readTillEmpty2 conn []
; return $
rs `bindE` \strs ->
parseHeaders strs `bindE` \ftrs ->
Right (ftrs,n,"")
}
else do { some <- readBlock conn size
; readLine conn
; more <- chunkedTransferC conn (n+size)
; return $
some `bindE` \cdata ->
more `bindE` \(ftrs,m,mdata) ->
Right (ftrs,m,cdata++mdata)
}
uglyDeathTransfer :: Stream s => s -> IO (Result ([Header],String))
uglyDeathTransfer conn
= return $ Left $ ErrorParse "Unknown Transfer-Encoding"
readTillEmpty1 :: Stream s => s -> IO (Result [String])
readTillEmpty1 conn =
do { line <- readLine conn
; case line of
Left e -> return $ Left e
Right s ->
if s == crlf
then readTillEmpty1 conn
else readTillEmpty2 conn [s]
}
readTillEmpty2 :: Stream s => s -> [String] -> IO (Result [String])
readTillEmpty2 conn list =
do { line <- readLine conn
; case line of
Left e -> return $ Left e
Right s ->
if s == crlf || null s
then return (Right $ reverse (s:list))
else readTillEmpty2 conn (s:list)
}
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 [';','/','?',':','@','&'
,'=','+',',','$','{','}'
,'|','\\','^','[',']','`'
,'<','>','#','%','"']
escape x =
let y = ord x
in [ '%', intToDigit ((y `div` 16) .&. 0xf), intToDigit (y .&. 0xf) ]
urlEncode [] = []
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 [] = []