-----------------------------------------------------------------------------
-- |
-- Module      :  Network.HTTP.HandleStream
-- Copyright   :  See LICENSE file
-- License     :  BSD
-- 
-- Maintainer  :  Ganesh Sittampalam <ganesh@earth.li>
-- Stability   :  experimental
-- Portability :  non-portable (not tested)
--
-- A 'HandleStream'-based version of "Network.HTTP" interface.
--
-- 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.HandleStream 
       ( simpleHTTP      -- :: Request ty -> IO (Result (Response ty))
       , simpleHTTP_     -- :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty))
       , sendHTTP        -- :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty))
       , sendHTTP_notify -- :: HStream ty => HandleStream ty -> Request ty -> IO () -> IO (Result (Response ty))
       , receiveHTTP     -- :: HStream ty => HandleStream ty -> IO (Result (Request ty))
       , respondHTTP     -- :: HStream ty => HandleStream ty -> Response ty -> IO ()
       
       , simpleHTTP_debug -- :: FilePath -> Request DebugString -> IO (Response DebugString)
       ) where

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

import Network.BufferType
import Network.Stream ( fmapE, Result )
import Network.StreamDebugger ( debugByteStream )
import Network.TCP (HStream(..), HandleStream )

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

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

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

-- | @simpleHTTP@ transmits a resource across a non-persistent connection.
simpleHTTP :: HStream ty => Request ty -> IO (Result (Response ty))
simpleHTTP r = do 
  auth <- getAuth r
  failHTTPS (rqURI r)
  c <- openStream (host auth) (fromMaybe 80 (port auth))
  simpleHTTP_ c r

-- | @simpleHTTP_debug debugFile req@ behaves like 'simpleHTTP', but logs
-- the HTTP operation via the debug file @debugFile@.
simpleHTTP_debug :: HStream ty => FilePath -> Request ty -> IO (Result (Response ty))
simpleHTTP_debug httpLogFile r = do 
  auth <- getAuth r
  failHTTPS (rqURI r)
  c0   <- openStream (host auth) (fromMaybe 80 (port auth))
  c    <- debugByteStream httpLogFile c0
  simpleHTTP_ c r

-- | Like 'simpleHTTP', but acting on an already opened stream.
simpleHTTP_ :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty))
simpleHTTP_ s r = sendHTTP s r

-- | @sendHTTP hStream httpRequest@ transmits @httpRequest@ over
-- @hStream@, but does not alter the status of the connection, nor request it to be
-- closed upon receiving the response.
sendHTTP :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty))
sendHTTP conn rq = sendHTTP_notify conn rq (return ())

-- | @sendHTTP_notify hStream httpRequest action@ behaves like 'sendHTTP', but
-- lets you supply an IO @action@ to execute once the request has been successfully
-- transmitted over the connection. Useful when you want to set up tracing of
-- request transmission and its performance.
sendHTTP_notify :: HStream ty
                => HandleStream ty
                -> Request ty
                -> IO ()
                -> IO (Result (Response ty))
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 :: HStream ty
         => HandleStream ty
         -> Request ty
         -> (IO ())
         -> IO (Result (Response ty))
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 (buf_fromStr bufferOps $ 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

   -- Hmmm, this could go bad if we keep getting "100 Continue"
   -- responses...  Except this should never happen according
   -- to the RFC.

switchResponse :: HStream ty
               => HandleStream ty
               -> Bool {- allow retry? -}
               -> Bool {- is body sent? -}
               -> Result ResponseData
               -> Request ty
               -> IO (Result (Response ty))
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 -> do {- Time to send the body -}
        writeBlock conn (rqBody rqst) >>= either (return . Left)
           (\ _ -> do
              rsp <- getResponseHead conn
              switchResponse conn allow_retry True rsp rqst)
      | otherwise    -> do {- keep waiting -}
        rsp <- getResponseHead conn
        switchResponse conn allow_retry bdy_sent rsp rqst

     Retry -> do {- Request with "Expect" header failed.
                    Trouble is the request contains Expects
                    other than "100-Continue" -}
        -- TODO review throwing away of result
        _ <- writeBlock conn ((buf_append bufferOps)
                                     (buf_fromStr bufferOps (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 (buf_empty bufferOps))

     DieHorribly str -> do
       close conn
       return (responseParseError "Invalid response:" str)
     ExpectEntity -> do
       r <- fmapE (\ (ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy)) $
             maybe (maybe (hopefulTransfer bo (readLine conn) [])
                       (\ x ->
                          readsOne (linearTransfer (readBlock conn))
                                   (return$responseParseError "unrecognized content-length value" x)
                                   x)
                        cl)
                   (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn))
                              (uglyDeathTransfer "sendHTTP"))
                   tc
       case r of
         Left{} -> do
           close conn
           return r
         Right (Response _ _ hs _) -> do
           when (findConnClose hs)
                (closeOnEnd conn True)
           return r

      where
       tc = lookupHeader HdrTransferEncoding hdrs
       cl = lookupHeader HdrContentLength hdrs
       bo = bufferOps
                    
-- reads and parses headers
getResponseHead :: HStream ty => HandleStream ty -> IO (Result ResponseData)
getResponseHead conn = 
   fmapE (\es -> parseResponseHead (map (buf_toStr bufferOps) es))
         (readTillEmpty1 bufferOps (readLine conn))

-- | @receiveHTTP hStream@ reads a 'Request' from the 'HandleStream' @hStream@
receiveHTTP :: HStream bufTy => HandleStream bufTy -> IO (Result (Request bufTy))
receiveHTTP conn = getRequestHead >>= either (return . Left) processRequest
  where
    -- reads and parses headers
   getRequestHead :: IO (Result RequestData)
   getRequestHead = do
      fmapE (\es -> parseRequestHead (map (buf_toStr bufferOps) es))
            (readTillEmpty1 bufferOps (readLine conn))

   processRequest (rm,uri,hdrs) =
      fmapE (\ (ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy)) $
             maybe
              (maybe (return (Right ([], buf_empty bo))) -- hopefulTransfer ""
                     (\ x -> readsOne (linearTransfer (readBlock conn))
                                      (return$responseParseError "unrecognized Content-Length value" x)
                                      x)

                     cl)
              (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn))
                         (uglyDeathTransfer "receiveHTTP"))
              tc
    where
     -- FIXME : Also handle 100-continue.
     tc = lookupHeader HdrTransferEncoding hdrs
     cl = lookupHeader HdrContentLength hdrs
     bo = bufferOps

-- | @respondHTTP hStream httpResponse@ transmits an HTTP 'Response' over
-- the 'HandleStream' @hStream@. It could be used to implement simple web
-- server interactions, performing the dual role to 'sendHTTP'.
respondHTTP :: HStream ty => HandleStream ty -> Response ty -> IO ()
respondHTTP conn rsp = do 
  -- TODO: review throwing away of result
  _ <- writeBlock conn (buf_fromStr bufferOps $ show rsp)
   -- write body immediately, don't wait for 100 CONTINUE
  -- TODO: review throwing away of result
  _ <- writeBlock conn (rspBody rsp)
  return ()

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

headerName :: String -> String
headerName x = map toLower (trim x)

ifChunked :: a -> a -> String -> a
ifChunked a b s = 
  case headerName s of
    "chunked" -> a
    _ -> b