-----------------------------------------------------------------------------

-- |

-- Module      :  Network.HTTP.Stream

-- Copyright   :  See LICENSE file

-- License     :  BSD

-- 

-- Maintainer  :  Ganesh Sittampalam <ganesh@earth.li>

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