module Network.HTTP.HandleStream
( simpleHTTP
, simpleHTTP_
, sendHTTP
, receiveHTTP
, respondHTTP
, simpleHTTP_debug
) where
import Network.BufferType
import Network.Stream ( ConnError(..), bindE, Result )
import Network.StreamDebugger ( debugByteStream )
import Network.TCP (HStream(..), HandleStream )
import Network.HTTP.Base
import Network.HTTP.Headers
import Network.HTTP.Utils ( trim )
import Data.Char (toLower)
import Data.Maybe (fromMaybe)
import Control.Monad (when)
simpleHTTP :: HStream ty => HTTPRequest ty -> IO (Result (HTTPResponse ty))
simpleHTTP r = do
auth <- getAuth r
c <- openStream (host auth) (fromMaybe 80 (port auth))
simpleHTTP_ c r
simpleHTTP_debug :: HStream ty => FilePath -> HTTPRequest ty -> IO (Result (HTTPResponse ty))
simpleHTTP_debug httpLogFile r = do
auth <- getAuth r
c0 <- openStream (host auth) (fromMaybe 80 (port auth))
c <- debugByteStream httpLogFile c0
simpleHTTP_ c r
simpleHTTP_ :: HStream ty => HandleStream ty -> HTTPRequest ty -> IO (Result (HTTPResponse ty))
simpleHTTP_ s r = do
auth <- getAuth r
let r' = normalizeRequestURI auth r
rsp <- sendHTTP s r'
return rsp
sendHTTP :: HStream ty => HandleStream ty -> HTTPRequest ty -> IO (Result (HTTPResponse ty))
sendHTTP conn rq = do
let a_rq = normalizeHostHeader rq
rsp <- catchIO (sendMain conn a_rq)
(\e -> do { close conn; ioError e })
let fn list = when (or $ map findConnClose list)
(close conn)
either (\_ -> fn [rqHeaders rq])
(\r -> fn [rqHeaders rq,rspHeaders r])
rsp
return rsp
sendMain :: HStream ty => HandleStream ty -> HTTPRequest ty -> IO (Result (HTTPResponse ty))
sendMain conn rqst = do
writeBlock conn (buf_fromStr bufferOps $ show rqst)
writeBlock conn (rqBody rqst)
rsp <- getResponseHead conn
switchResponse conn True False rsp rqst
switchResponse :: HStream ty
=> HandleStream ty
-> Bool
-> Bool
-> Result ResponseData
-> HTTPRequest ty
-> IO (Result (HTTPResponse ty))
switchResponse _ _ _ (Left e) _ = return (Left e)
switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst =
case matchResponse (rqMethod rqst) cd of
Continue
| not bdy_sent -> do
writeBlock conn (rqBody rqst) >>= either (return . Left)
(\ _ -> do
rsp <- getResponseHead conn
switchResponse conn allow_retry True rsp rqst)
| otherwise -> do
rsp <- getResponseHead conn
switchResponse conn allow_retry bdy_sent rsp rqst
Retry -> do
writeBlock conn ((buf_append bufferOps)
(buf_fromStr bufferOps (show rqst))
(rqBody rqst))
rsp <- getResponseHead conn
switchResponse conn False bdy_sent rsp rqst
Done -> return (Right $ Response cd rn hdrs (buf_empty bufferOps))
DieHorribly str -> return $ Left $ ErrorParse ("Invalid response: " ++ str)
ExpectEntity -> do
rslt <-
case tc of
Nothing ->
case cl of
Nothing -> hopefulTransfer bo (readLine conn) []
Just x ->
case reads x of
((v,_):_) -> linearTransfer (readBlock conn) v
_ -> return (Left (ErrorParse ("unrecognized content-length value " ++ x)))
Just x ->
case map toLower (trim x) of
"chunked" -> chunkedTransfer bo (readLine conn) (readBlock conn)
_ -> uglyDeathTransfer
return $ rslt `bindE` \(ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy)
where
tc = lookupHeader HdrTransferEncoding hdrs
cl = lookupHeader HdrContentLength hdrs
bo = bufferOps
getResponseHead :: HStream ty => HandleStream ty -> IO (Result ResponseData)
getResponseHead conn = do
lor <- readTillEmpty1 bufferOps (readLine conn)
return $ lor `bindE` \es -> parseResponseHead (map (buf_toStr bufferOps) es)
receiveHTTP :: HStream bufTy => HandleStream bufTy -> IO (Result (HTTPRequest bufTy))
receiveHTTP conn = getRequestHead >>= either (return . Left) processRequest
where
getRequestHead :: IO (Result RequestData)
getRequestHead =
do { lor <- readTillEmpty1 bufferOps (readLine conn)
; return $ lor `bindE` \es -> parseRequestHead (map (buf_toStr bufferOps) es)
}
processRequest (rm,uri,hdrs) = do
rslt <-
case tc of
Nothing ->
case cl of
Nothing -> return (Right ([], buf_empty bo))
Just x ->
case reads x of
((v,_):_) -> linearTransfer (readBlock conn) v
_ -> return (Left (ErrorParse ("unrecognized content-length value " ++ x)))
Just x ->
case map toLower (trim x) of
"chunked" -> chunkedTransfer bo (readLine conn) (readBlock conn)
_ -> uglyDeathTransfer
return $ rslt `bindE` \(ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy)
where
tc = lookupHeader HdrTransferEncoding hdrs
cl = lookupHeader HdrContentLength hdrs
bo = bufferOps
respondHTTP :: HStream ty => HandleStream ty -> HTTPResponse ty -> IO ()
respondHTTP conn rsp = do
writeBlock conn (buf_fromStr bufferOps $ show rsp)
writeBlock conn (rspBody rsp)
return ()