Network/HTTP/Stream.hs

-----------------------------------------------------------------------------
-- |
-- Module : Network.HTTP.Stream
-- Copyright : See LICENSE file
-- License : BSD
-- 
-- Maintainer : Ganesh Sittampalam <http@projects.haskell.org>
-- Stability : experimental
-- Portability : non-portable (not tested)
--
-- Transmitting HTTP requests and responses holding @String@ in their payload bodies.
-- This is one of the implementation modules for the "Network.HTTP" interface, representing
-- request and response content as @String@s and transmitting them in non-packed form
-- (cf. "Network.HTTP.HandleStream" and its use of @ByteString@s.) over 'Stream' handles.
-- It is mostly here for backwards compatibility, representing how requests and responses
-- were transmitted up until the 4.x releases of the HTTP package.
--
-- For more detailed information about what the individual exports do, please consult
-- the documentation for "Network.HTTP". /Notice/ however that the functions here do
-- not perform any kind of normalization prior to transmission (or receipt); you are
-- responsible for doing any such yourself, or, if you prefer, just switch to using
-- "Network.HTTP" function instead.
-- 
-----------------------------------------------------------------------------
module Network.HTTP.Stream 
 ( module Network.Stream

 , simpleHTTP -- :: Request_String -> IO (Result Response_String)
 , simpleHTTP_ -- :: Stream s => s -> Request_String -> IO (Result Response_String)
 , sendHTTP -- :: Stream s => s -> Request_String -> IO (Result Response_String)
 , sendHTTP_notify -- :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String)
 , receiveHTTP -- :: Stream s => s -> IO (Result Request_String)
 , respondHTTP -- :: Stream s => s -> Response_String -> IO ()
 
 ) where

-----------------------------------------------------------------
------------------ Imports --------------------------------------
-----------------------------------------------------------------

import Network.Stream
import Network.StreamDebugger (debugStream)
import Network.TCP (openTCPPort)
import Network.BufferType ( stringBufferOp )

import Network.HTTP.Base
import Network.HTTP.Headers
import Network.HTTP.Utils ( trim )

import Data.Char (toLower)
import Data.Maybe (fromMaybe)
import Control.Exception (onException)
import Control.Monad (when)


-- Turn on to enable HTTP traffic logging
debug :: Bool
debug = False

-- File that HTTP traffic logs go to
httpLogFile :: String
httpLogFile = "http-debug.log"

-----------------------------------------------------------------
------------------ Misc -----------------------------------------
-----------------------------------------------------------------


-- | Simple way to transmit a resource across a non-persistent connection.
simpleHTTP :: Request_String -> IO (Result Response_String)
simpleHTTP r = do 
 auth <- getAuth r
 c <- openTCPPort (host auth) (fromMaybe 80 (port auth))
 simpleHTTP_ c r

-- | Like 'simpleHTTP', but acting on an already opened stream.
simpleHTTP_ :: Stream s => s -> Request_String -> IO (Result Response_String)
simpleHTTP_ s r
 | not debug = sendHTTP s r
 | otherwise = do
 s' <- debugStream httpLogFile s
 sendHTTP s' r

sendHTTP :: Stream s => s -> Request_String -> IO (Result Response_String)
sendHTTP conn rq = sendHTTP_notify conn rq (return ())

sendHTTP_notify :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String)
sendHTTP_notify conn rq onSendComplete = do
 when providedClose $ (closeOnEnd conn True)
 onException (sendMain conn rq onSendComplete)
 (close conn)
 where
 providedClose = findConnClose (rqHeaders rq)

-- From RFC 2616, section 8.2.3:
-- 'Because of the presence of older implementations, the protocol allows
-- ambiguous situations in which a client may send "Expect: 100-
-- continue" without receiving either a 417 (Expectation Failed) status
-- or a 100 (Continue) status. Therefore, when a client sends this
-- header field to an origin server (possibly via a proxy) from which it
-- has never seen a 100 (Continue) status, the client SHOULD NOT wait
-- for an indefinite period before sending the request body.'
--
-- Since we would wait forever, I have disabled use of 100-continue for now.
sendMain :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String)
sendMain conn rqst onSendComplete = do 
 --let str = if null (rqBody rqst)
 -- then show rqst
 -- else show (insertHeader HdrExpect "100-continue" rqst)
 -- TODO review throwing away of result
 _ <- writeBlock conn (show rqst)
 -- write body immediately, don't wait for 100 CONTINUE
 -- TODO review throwing away of result
 _ <- writeBlock conn (rqBody rqst)
 onSendComplete
 rsp <- getResponseHead conn
 switchResponse conn True False rsp rqst
 
-- reads and parses headers
getResponseHead :: Stream s => s -> IO (Result ResponseData)
getResponseHead conn = do
 lor <- readTillEmpty1 stringBufferOp (readLine conn)
 return $ lor >>= parseResponseHead

-- Hmmm, this could go bad if we keep getting "100 Continue"
-- responses... Except this should never happen according
-- to the RFC.
switchResponse :: Stream s
 => s
	 -> Bool {- allow retry? -}
 -> Bool {- is body sent? -}
 -> Result ResponseData
 -> Request_String
 -> IO (Result Response_String)
switchResponse _ _ _ (Left e) _ = return (Left e)
 -- retry on connreset?
 -- if we attempt to use the same socket then there is an excellent
 -- chance that the socket is not in a completely closed state.
switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst =
 case matchResponse (rqMethod rqst) cd of
 Continue
 | not bdy_sent -> {- Time to send the body -}
 do { val <- writeBlock conn (rqBody rqst)
 ; case val of
 Left e -> return (Left e)
 Right _ ->
 do { rsp <- getResponseHead conn
 ; switchResponse conn allow_retry True rsp rqst
 }
 }
 | otherwise -> {- keep waiting -}
 do { rsp <- getResponseHead conn
 ; switchResponse conn allow_retry bdy_sent rsp rqst 
 }

 Retry -> {- Request with "Expect" header failed.
 Trouble is the request contains Expects
 other than "100-Continue" -}
 do { -- TODO review throwing away of result
 _ <- writeBlock conn (show rqst ++ rqBody rqst)
 ; rsp <- getResponseHead conn
 ; switchResponse conn False bdy_sent rsp rqst
 } 
 
 Done -> do
		 when (findConnClose hdrs)
 	 	 (closeOnEnd conn True)
 return (Right $ Response cd rn hdrs "")

 DieHorribly str -> do
		 close conn
 return $ responseParseError "sendHTTP" ("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 (readBlock conn) (read x :: Int)
 Nothing -> hopefulTransfer stringBufferOp {-null (++) []-} (readLine conn) []
 Just x -> 
 case map toLower (trim x) of
 "chunked" -> chunkedTransfer stringBufferOp
				 (readLine conn) (readBlock conn)
 _ -> uglyDeathTransfer "sendHTTP"
 ; case rslt of
		 Left e -> close conn >> return (Left e)
			 Right (ftrs,bdy) -> do
			 when (findConnClose (hdrs++ftrs))
			 	 (closeOnEnd conn True)
			 return (Right (Response cd rn (hdrs++ftrs) bdy))
 }

-- | Receive and parse a HTTP request from the given Stream. Should be used 
-- for server side interactions.
receiveHTTP :: Stream s => s -> IO (Result Request_String)
receiveHTTP conn = getRequestHead >>= processRequest
 where
 -- reads and parses headers
 getRequestHead :: IO (Result RequestData)
 getRequestHead =
 do { lor <- readTillEmpty1 stringBufferOp (readLine conn)
 ; return $ lor >>= parseRequestHead
 }
	
 processRequest (Left e) = return $ Left e
	processRequest (Right (rm,uri,hdrs)) = 
	 do -- FIXME : Also handle 100-continue.
 let tc = lookupHeader HdrTransferEncoding hdrs
 cl = lookupHeader HdrContentLength hdrs
	 rslt <- case tc of
 Nothing ->
 case cl of
 Just x -> linearTransfer (readBlock conn) (read x :: Int)
 Nothing -> return (Right ([], "")) -- hopefulTransfer ""
 Just x ->
 case map toLower (trim x) of
 "chunked" -> chunkedTransfer stringBufferOp
				 (readLine conn) (readBlock conn)
 _ -> uglyDeathTransfer "receiveHTTP"
 
 return $ do
	 (ftrs,bdy) <- rslt
		 return (Request uri rm (hdrs++ftrs) bdy)

-- | Very simple function, send a HTTP response over the given stream. This 
-- could be improved on to use different transfer types.
respondHTTP :: Stream s => s -> Response_String -> IO ()
respondHTTP conn rsp = do -- TODO review throwing away of result
 _ <- writeBlock conn (show rsp)
 -- write body immediately, don't wait for 100 CONTINUE
 -- TODO review throwing away of result
 _ <- writeBlock conn (rspBody rsp)
			 return ()