{- |
Module:        Network.Monad.HTTP
Copyright:     (c) 2009 Henning Thielemann
License:       BSD

Stability:     experimental
Portability:   non-portable (not tested)
-}
module Network.Monad.HTTP (
   send,
   receive,
   respond,
   ) where

import Network.URI
   ( URI(URI, uriAuthority)
   , URIAuth(uriUserInfo, uriRegName, uriPort)
   , parseURIReference
   )
import qualified Network.Monad.HTTP.Header as Header
import qualified Network.Monad.Reader as StreamMonad
import qualified Network.Monad.Body   as Body

import Network.Stream (ConnError(ErrorParse,ErrorClosed), )
import Network.HTTP.Base
   (Request(..),  RequestData,  RequestMethod(..),
    Response(..), ResponseData, ResponseCode, )

import Network.Monad.Reader (readLine, readBlock, writeBlock, )
import Control.Monad.Trans (lift, )

import qualified Control.Monad.Exception.Asynchronous as Async
import qualified Control.Monad.Exception.Synchronous  as Sync
import qualified Network.Monad.Exception as Exc

import qualified Data.Map as Map

import Data.String.HT (trim, )
import Data.Maybe.HT (toMaybe, )
import Data.Char (isDigit, intToDigit, digitToInt, toLower, )
import Data.Monoid (Monoid, mappend, mempty, )
import Control.Monad (liftM, liftM2, mplus, )
import Numeric (readHex, )


type SynchronousExceptional body m a =
   Sync.ExceptionalT ConnError (StreamMonad.T body m) a

type AsynchronousExceptional body m a =
   (StreamMonad.T body m) (Async.Exceptional ConnError a)



-- * Parsing

-- we could use Read class, but I consider this a hack
requestMethodDict :: Map.Map String RequestMethod
requestMethodDict =
   Map.fromList $
   ("HEAD",    HEAD)    :
   ("PUT",     PUT)     :
   ("GET",     GET)     :
   ("POST",    POST)    :
   ("DELETE",  DELETE)  :
   ("OPTIONS", OPTIONS) :
   ("TRACE",   TRACE)   :
   []


-- Parsing a request
parseRequestHead :: [String] -> Sync.Exceptional ConnError RequestData
parseRequestHead [] = Sync.throw ErrorClosed
parseRequestHead (com:hdrs) =
   requestCommand com >>= \(_version,rqm,uri) ->
   return (rqm, uri, Header.parseManyStraight hdrs)
   where
      requestCommand line =
	 case words line of
            (rqm:uri:version) ->
               liftM2
                  (\r u -> (version,r,u))
                  (Sync.fromMaybe
                      (ErrorParse $ "Unknown HTTP method: " ++ rqm)
                      (Map.lookup rqm requestMethodDict))
                  (Sync.fromMaybe
                      (ErrorParse $ "Malformed URI: " ++ uri)
                      (parseURIReference uri))
	    _ -> Sync.throw $
              if null line
		then ErrorClosed
		else ErrorParse $ "Request command line parse failure: " ++ line

-- Parsing a response
parseResponseHead :: [String] -> Sync.Exceptional ConnError ResponseData
parseResponseHead [] = Sync.throw ErrorClosed
parseResponseHead (sts:hdrs) =
   responseStatus sts >>= \(_version,code,reason) ->
   return (code, reason, Header.parseManyStraight hdrs)
   where
      responseStatus line =
         case words line of
            (version:code:reason) ->
               do digits <- mapM getDigit code
                  case digits of
                     [a,b,c] ->
                        return (version, (a,b,c), concatMap (++" ") reason)
                     _ -> Sync.throw $ ErrorParse $ "Response Code must consist of three digits: " ++ show code
            _ -> Sync.throw $
              if null line
                then ErrorClosed  -- an assumption
                else ErrorParse $ "Response status line parse failure: " ++ line

      getDigit d =
         if isDigit d
           then return $ digitToInt d
           else Sync.throw $ ErrorParse $ "Non-digit "++d:" in Response Code"





-- * HTTP Send / Recv

data Behaviour = Continue
               | Retry
               | Done
               | ExpectEntity
               | DieHorribly String

matchResponse :: RequestMethod -> ResponseCode -> Behaviour
matchResponse rqst rsp =
    let ans = if rqst == HEAD then Done else ExpectEntity
    in  case rsp of
            (1,0,0) -> Continue
            (1,0,1) -> Done        -- upgrade to TLS
            (1,_,_) -> Continue    -- default
            (2,0,4) -> Done
            (2,0,5) -> Done
            (2,_,_) -> ans
            (3,0,4) -> Done
            (3,0,5) -> Done
            (3,_,_) -> ans
            (4,1,7) -> Retry       -- Expectation failed
            (4,_,_) -> ans
            (5,_,_) -> ans
            (a,b,c) -> DieHorribly ("Response code " ++ map intToDigit [a,b,c] ++ " not recognised")


send :: (Monad m, Body.C body) => Request body -> SynchronousExceptional body m (Async.Exceptional ConnError (Bool, Response body))
send rq =
   liftM
      (fmap (\rsp -> (findConnClose (rqHeaders rq ++ rspHeaders rsp), rsp))) $
      sendMain $
      fixHostHeader 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 :: (Monad m, Body.C body) => Request body -> SynchronousExceptional body m (Async.Exceptional ConnError (Response body))
sendMain rqst =
    do
       --let str = if null (rqBody rqst)
       --              then show rqst
       --              else show (insertHeader Header.HdrExpect "100-continue" rqst)
       writeBlock (Body.fromString $ show rqst)
       -- write body immediately, don't wait for 100 CONTINUE
       writeBlock (rqBody rqst)
       withResponseHead $ switchResponse True False rqst

-- reads and parses headers
getResponseHead :: (Monad m, Body.C body) => SynchronousExceptional body m (Async.Exceptional ConnError ResponseData)
getResponseHead =
   Sync.ExceptionalT $
   liftM (Async.sequence . fmap (parseResponseHead . map Body.toString)) readTillEmpty1

withResponseHead :: (Monad m, Body.C body) => (ResponseData -> SynchronousExceptional body m (Async.Exceptional ConnError (Response body))) -> SynchronousExceptional body m (Async.Exceptional ConnError (Response body))
withResponseHead =
   Exc.switchM getResponseHead (\(cd,rn,hdrs) -> return $ Response cd rn hdrs mempty)

-- Hmmm, this could go bad if we keep getting "100 Continue"
-- responses...  Except this should never happen according
-- to the RFC.
switchResponse :: (Monad m, Body.C body) =>
      Bool {- allow retry? -}
   -> Bool {- is body sent? -}
   -> Request body
   -> ResponseData
   -> SynchronousExceptional body m (Async.Exceptional ConnError (Response body))

-- switchResponse _ _ (Sync.Exception e) _ = return (Sync.Exception 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 allow_retry bdy_sent rqst (cd,rn,hdrs) =
   case matchResponse (rqMethod rqst) cd of
      Continue ->
         if not bdy_sent
           then {- Time to send the body -}
             writeBlock (rqBody rqst) >>
             (withResponseHead $ switchResponse allow_retry True rqst)
           else {- keep waiting -}
             withResponseHead $
                switchResponse allow_retry bdy_sent rqst

      Retry -> {- Request with "Expect" header failed.
                      Trouble is the request contains Expects
                      other than "100-Continue" -}
         writeBlock (Body.fromString (show rqst) `mappend` rqBody rqst) >>
         (withResponseHead $
             switchResponse False bdy_sent rqst)

      Done ->
         return $ Async.pure $ Response cd rn hdrs mempty

      DieHorribly str ->
         Sync.throwT $ ErrorParse ("Invalid response: " ++ str)

      ExpectEntity ->
         let tc = Header.lookup Header.HdrTransferEncoding hdrs
             cl = Header.lookup Header.HdrContentLength hdrs
         in  lift $ assembleHeaderBody (Response cd rn) hdrs $
             case tc of
                Nothing ->
                   case cl of
                      Just x  -> linearTransferStrLen x
                      Nothing -> hopefulTransfer
                Just x  ->
                   case map toLower (trim x) of
                      "chunked" -> chunkedTransfer False
                      _         -> uglyDeathTransfer


-- Adds a Host header if one is NOT ALREADY PRESENT
fixHostHeader :: Request body -> Request body
fixHostHeader rq =
    let uri = rqURI rq
        host_ = uriToAuthorityString uri
    in  Header.insertIfMissing Header.HdrHost host_ rq

-- Looks for a "Connection" header with the value "close".
-- Returns True when this is found.
findConnClose :: [Header.T] -> Bool
findConnClose hdrs =
    case Header.lookup Header.HdrConnection hdrs of
        Nothing -> False
        Just x  -> map toLower (trim x) == "close"

-- This function duplicates old Network.URI.authority behaviour.
uriToAuthorityString :: URI -> String
uriToAuthorityString URI{uriAuthority=Nothing} = ""
uriToAuthorityString URI{uriAuthority=Just ua} = uriUserInfo ua ++
                                                 uriRegName ua ++
                                                 uriPort ua

{- |
Receive and parse a HTTP request from the given Stream.
Should be used for server side interactions.
-}
receive :: (Monad m, Body.C body) => SynchronousExceptional body m (Async.Exceptional ConnError (Request body))
receive =
   Exc.switchM getRequestHead
      (\(rm,uri,hdrs) -> return $ Request uri rm hdrs mempty)
      (lift . processRequest)

-- | Reads and parses request headers.
getRequestHead :: (Monad m, Body.C body) => SynchronousExceptional body m (Async.Exceptional ConnError RequestData)
getRequestHead =
   Sync.ExceptionalT $
   liftM (Async.sequence . fmap (parseRequestHead . map Body.toString)) readTillEmpty1

-- | Process request body (called after successful getRequestHead)
processRequest :: (Monad m, Body.C body) => RequestData -> AsynchronousExceptional body m (Request body)
processRequest (rm,uri,hdrs) =
   -- FIXME : Also handle 100-continue.
   let tc = Header.lookup Header.HdrTransferEncoding hdrs
       cl = Header.lookup Header.HdrContentLength hdrs
   in  assembleHeaderBody (Request uri rm) hdrs $
       case tc of
          Nothing ->
             case cl of
                Just x  -> linearTransferStrLen x
                Nothing -> return $ Async.pure ([], mempty)
                -- hopefulTransfer
          Just x  ->
             case map toLower (trim x) of
                "chunked" -> chunkedTransfer False
                _         -> uglyDeathTransfer


{-
Currently it omits the footers in order to prevent infinite loops
when processing the headers of a Request or Response with infinite body.
-}
assembleHeaderBody :: (Monad m) => ([Header.T] -> body -> a) -> [Header.T] -> AsynchronousExceptional body m ([Header.T], body) -> AsynchronousExceptional body m a
assembleHeaderBody make hdrs =
   liftM (fmap (\(_ftrs,bdy) -> make hdrs bdy))
--   liftM (fmap (\(ftrs,bdy) -> make (hdrs++ftrs) bdy))

{- |
Very simple function, send a HTTP response over the given stream.
This could be improved on to use different transfer types.
-}
respond :: (Monad m, Body.C body) => Response body -> SynchronousExceptional body m ()
respond rsp =
   do writeBlock (Body.fromString $ show rsp)
      -- write body immediately, don't wait for 100 CONTINUE
      writeBlock (rspBody rsp)


-- * transfer functions

-- The following functions were in the where clause of sendHTTP, they have
-- been moved to global scope so other functions can access them.

linearTransferStrLen :: (Monad m, Monoid body) => String -> AsynchronousExceptional body m ([Header.T],body)
linearTransferStrLen ns =
   case reads ns of
      [(n,"")] -> linearTransfer n
      _ -> return $ Async.throwMonoid $ ErrorParse $ "Content-Length header contains not a number: " ++ show ns

-- | Used when we know exactly how many bytes to expect.
linearTransfer :: Monad m => Int -> AsynchronousExceptional body m ([Header.T],body)
linearTransfer n =
   liftM (fmap ((,) [])) $ readBlock n

-- | Used when nothing about data is known,
--   Unfortunately waiting for a socket closure
--   causes bad behaviour.  Here we just
--   take data once and give up the rest.
hopefulTransfer :: (Monad m, Body.C body) => AsynchronousExceptional body m ([Header.T],body)
hopefulTransfer =
   let go =
         readLineSwitch $ \line ->
            if Body.isEmpty line
              then return $ Async.pure mempty
              else liftM (fmap (mappend line)) go
   in  liftM (fmap ((,) [])) go


-- | in contrast to built-in @(,,)@, its mappend implementation is lazy
data ChunkedResponse body =
   ChunkedResponse [Header.T] [Int] body
      deriving Show

instance Monoid body => Monoid (ChunkedResponse body) where
   mempty = ChunkedResponse mempty mempty mempty
   mappend (ChunkedResponse hx lx sx) (ChunkedResponse hy ly sy) =
       ChunkedResponse (mappend hx hy) (mappend lx ly) (mappend sx sy)

forceCR :: ChunkedResponse body -> ChunkedResponse body
forceCR ~(ChunkedResponse h l s) = (ChunkedResponse h l s)

{- |
A necessary feature of HTTP\/1.1
Also the only transfer variety likely to return any footers.
Also the only transfer method for infinite data
and the prefered one for generated data.
-}
chunkedTransfer :: (Monad m, Body.C body) => Bool -> AsynchronousExceptional body m ([Header.T],body)
chunkedTransfer attachLength =
   liftM (fmap (\(ChunkedResponse ftrs sizes info) ->
      ((if attachLength
          then (Header.Header Header.HdrContentLength (show $ sum sizes) :)
          else id) ftrs,
       info))) $
   chunkedTransferLoop

{- we do not sum up the chunk size here
   since this would result in an inefficient summation from right to left -}
chunkedTransferLoop :: (Monad m, Body.C body) => AsynchronousExceptional body m (ChunkedResponse body)
chunkedTransferLoop =
   readLineSwitch $ \line ->
      case readHex $ Body.toString line of
         [(size,_)] ->
            if size == 0
              then
                 liftM
                    (fmap (\strs -> ChunkedResponse (Header.parseManyStraight $ map Body.toString strs) [0] mempty))
                    readTillEmpty2
              else
                 liftM (fmap (\block -> ChunkedResponse [] [0] block)) (readBlock size)
                 `Async.appendM`
                 (liftM
                    (\newLineE ->
                        mplus
                          (Async.exception newLineE)
                          (toMaybe
                             (not $ Body.isLineTerm $ Async.result newLineE)
                             (ErrorParse $ "no CR+LF after chunk"))) $
                  readBlock 2)
{-
less efficient since it reads an entire line
                 (liftM (\newLineE ->
                           mplus
                             (Async.exception newLineE)
                             (let newLine = Async.result newLineE
                              in  toMaybe (not $ Body.isLineTerm newLine)
--                                     (ErrorParse $ "junk after chunk: " ++ show newLine)
                                     (ErrorParse $ "no CR+LF after chunk")
                                     ))
                  readLine)
-}
                 `Async.continueM`
                 liftM (fmap forceCR) chunkedTransferLoop
         _ ->
            {- old implementation continued reading anyway in this case
               as if the Chunk length was 0 -}
            return $ Async.throwMonoid
               (ErrorParse $ "Chunk-Length is not a number: " ++ show (Body.toString line))


-- | Maybe in the future we will have a sensible thing
--   to do here, at that time we might want to change
--   the name.
uglyDeathTransfer :: (Monad m, Monoid body) => AsynchronousExceptional body m ([Header.T],body)
uglyDeathTransfer =
   return $
   Async.throwMonoid $
   ErrorParse "Unknown Transfer-Encoding"



-- * helpers for parsing header

-- | Remove leading crlfs then call readTillEmpty2 (not required by RFC)
readTillEmpty1 :: (Monad m, Body.C body) => AsynchronousExceptional body m [body]
readTillEmpty1 =
   readLineSwitch $ \s ->
      if Body.isLineTerm s
        then readTillEmpty1
        else liftM (fmap (s:)) readTillEmpty2

-- | Read lines until an empty line (CRLF),
--   also accepts a connection close as end of
--   input, which is not an HTTP\/1.1 compliant
--   thing to do - so probably indicates an
--   error condition.
readTillEmpty2 :: (Monad m, Body.C body) => AsynchronousExceptional body m [body]
readTillEmpty2 =
   readLineSwitch $ \s ->
      if Body.isLineTerm s || Body.isEmpty s
        then return $ Async.pure []
        else liftM (fmap (s:)) readTillEmpty2


{- |
Read the next line and feed it to an action.
If the read line ends with an exception,
the subsequent action is not executed.
Thus readLine is handled strictly.
-}
readLineSwitch :: (Monad m, Monoid a) => (body -> AsynchronousExceptional body m a) -> AsynchronousExceptional body m a
readLineSwitch next =
   Exc.bind (Sync.ExceptionalT $ liftM Async.toSynchronous readLine) next
{- strict variant
   do lineE <- readLine
      maybe
         (next (Async.result lineE))
         (return . Async.throwMonoid)
         (Async.exception lineE)
-}
{- lazy variant
   do lineE <- readLine
      cont  <- next (Async.result lineE)
      return (Async.continue (Async.exception lineE) cont)
-}