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

-- |

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