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 ()