-----------------------------------------------------------------------------
-- |
-- 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 :: Bool
debug = Bool
False

-- File that HTTP traffic logs go to
httpLogFile :: String
httpLogFile :: String
httpLogFile = String
"http-debug.log"

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


-- | Simple way to transmit a resource across a non-persistent connection.
simpleHTTP :: Request_String -> IO (Result Response_String)
simpleHTTP :: Request_String -> IO (Result Response_String)
simpleHTTP Request_String
r = do 
   URIAuthority
auth <- Request_String -> IO URIAuthority
forall (m :: * -> *) ty.
MonadFail m =>
Request ty -> m URIAuthority
getAuth Request_String
r
   Connection
c    <- String -> Int -> IO Connection
openTCPPort (URIAuthority -> String
host URIAuthority
auth) (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
80 (URIAuthority -> Maybe Int
port URIAuthority
auth))
   Connection -> Request_String -> IO (Result Response_String)
forall s.
Stream s =>
s -> Request_String -> IO (Result Response_String)
simpleHTTP_ Connection
c Request_String
r

-- | Like 'simpleHTTP', but acting on an already opened stream.
simpleHTTP_ :: Stream s => s -> Request_String -> IO (Result Response_String)
simpleHTTP_ :: s -> Request_String -> IO (Result Response_String)
simpleHTTP_ s
s Request_String
r
 | Bool -> Bool
not Bool
debug    = s -> Request_String -> IO (Result Response_String)
forall s.
Stream s =>
s -> Request_String -> IO (Result Response_String)
sendHTTP s
s Request_String
r
 | Bool
otherwise    = do
      StreamDebugger s
s' <- String -> s -> IO (StreamDebugger s)
forall a. Stream a => String -> a -> IO (StreamDebugger a)
debugStream String
httpLogFile s
s
      StreamDebugger s -> Request_String -> IO (Result Response_String)
forall s.
Stream s =>
s -> Request_String -> IO (Result Response_String)
sendHTTP StreamDebugger s
s' Request_String
r

sendHTTP :: Stream s => s -> Request_String -> IO (Result Response_String)
sendHTTP :: s -> Request_String -> IO (Result Response_String)
sendHTTP s
conn Request_String
rq = s -> Request_String -> IO () -> IO (Result Response_String)
forall s.
Stream s =>
s -> Request_String -> IO () -> IO (Result Response_String)
sendHTTP_notify s
conn Request_String
rq (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

sendHTTP_notify :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String)
sendHTTP_notify :: s -> Request_String -> IO () -> IO (Result Response_String)
sendHTTP_notify s
conn Request_String
rq IO ()
onSendComplete = do
   Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
providedClose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (s -> Bool -> IO ()
forall x. Stream x => x -> Bool -> IO ()
closeOnEnd s
conn Bool
True)
   IO (Result Response_String) -> IO () -> IO (Result Response_String)
forall a b. IO a -> IO b -> IO a
onException (s -> Request_String -> IO () -> IO (Result Response_String)
forall s.
Stream s =>
s -> Request_String -> IO () -> IO (Result Response_String)
sendMain s
conn Request_String
rq IO ()
onSendComplete)
               (s -> IO ()
forall x. Stream x => x -> IO ()
close s
conn)
 where
  providedClose :: Bool
providedClose = [Header] -> Bool
findConnClose (Request_String -> [Header]
forall a. Request a -> [Header]
rqHeaders Request_String
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 :: s -> Request_String -> IO () -> IO (Result Response_String)
sendMain s
conn Request_String
rqst IO ()
onSendComplete =  do 
    --let str = if null (rqBody rqst)
    --              then show rqst
    --              else show (insertHeader HdrExpect "100-continue" rqst)
    -- TODO review throwing away of result
   Result ()
_ <- s -> String -> IO (Result ())
forall x. Stream x => x -> String -> IO (Result ())
writeBlock s
conn (Request_String -> String
forall a. Show a => a -> String
show Request_String
rqst)
    -- write body immediately, don't wait for 100 CONTINUE
   -- TODO review throwing away of result
   Result ()
_ <- s -> String -> IO (Result ())
forall x. Stream x => x -> String -> IO (Result ())
writeBlock s
conn (Request_String -> String
forall a. Request a -> a
rqBody Request_String
rqst)
   IO ()
onSendComplete
   Result ResponseData
rsp <- s -> IO (Result ResponseData)
forall s. Stream s => s -> IO (Result ResponseData)
getResponseHead s
conn
   s
-> Bool
-> Bool
-> Result ResponseData
-> Request_String
-> IO (Result Response_String)
forall s.
Stream s =>
s
-> Bool
-> Bool
-> Result ResponseData
-> Request_String
-> IO (Result Response_String)
switchResponse s
conn Bool
True Bool
False Result ResponseData
rsp Request_String
rqst
        
-- reads and parses headers
getResponseHead :: Stream s => s -> IO (Result ResponseData)
getResponseHead :: s -> IO (Result ResponseData)
getResponseHead s
conn = do
   Result [String]
lor <- BufferOp String -> IO (Result String) -> IO (Result [String])
forall a. BufferOp a -> IO (Result a) -> IO (Result [a])
readTillEmpty1 BufferOp String
stringBufferOp (s -> IO (Result String)
forall x. Stream x => x -> IO (Result String)
readLine s
conn)
   Result ResponseData -> IO (Result ResponseData)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result ResponseData -> IO (Result ResponseData))
-> Result ResponseData -> IO (Result ResponseData)
forall a b. (a -> b) -> a -> b
$ Result [String]
lor Result [String]
-> ([String] -> Result ResponseData) -> Result ResponseData
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [String] -> Result ResponseData
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 :: s
-> Bool
-> Bool
-> Result ResponseData
-> Request_String
-> IO (Result Response_String)
switchResponse s
_ Bool
_ Bool
_ (Left ConnError
e) Request_String
_ = Result Response_String -> IO (Result Response_String)
forall (m :: * -> *) a. Monad m => a -> m a
return (ConnError -> Result Response_String
forall a b. a -> Either a b
Left ConnError
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 s
conn Bool
allow_retry Bool
bdy_sent (Right (ResponseCode
cd,String
rn,[Header]
hdrs)) Request_String
rqst =
            case RequestMethod -> ResponseCode -> ResponseNextStep
matchResponse (Request_String -> RequestMethod
forall a. Request a -> RequestMethod
rqMethod Request_String
rqst) ResponseCode
cd of
                ResponseNextStep
Continue
                    | Bool -> Bool
not Bool
bdy_sent -> {- Time to send the body -}
                        do { Result ()
val <- s -> String -> IO (Result ())
forall x. Stream x => x -> String -> IO (Result ())
writeBlock s
conn (Request_String -> String
forall a. Request a -> a
rqBody Request_String
rqst)
                           ; case Result ()
val of
                                Left ConnError
e -> Result Response_String -> IO (Result Response_String)
forall (m :: * -> *) a. Monad m => a -> m a
return (ConnError -> Result Response_String
forall a b. a -> Either a b
Left ConnError
e)
                                Right ()
_ ->
                                    do { Result ResponseData
rsp <- s -> IO (Result ResponseData)
forall s. Stream s => s -> IO (Result ResponseData)
getResponseHead s
conn
                                       ; s
-> Bool
-> Bool
-> Result ResponseData
-> Request_String
-> IO (Result Response_String)
forall s.
Stream s =>
s
-> Bool
-> Bool
-> Result ResponseData
-> Request_String
-> IO (Result Response_String)
switchResponse s
conn Bool
allow_retry Bool
True Result ResponseData
rsp Request_String
rqst
                                       }
                           }
                    | Bool
otherwise -> {- keep waiting -}
                        do { Result ResponseData
rsp <- s -> IO (Result ResponseData)
forall s. Stream s => s -> IO (Result ResponseData)
getResponseHead s
conn
                           ; s
-> Bool
-> Bool
-> Result ResponseData
-> Request_String
-> IO (Result Response_String)
forall s.
Stream s =>
s
-> Bool
-> Bool
-> Result ResponseData
-> Request_String
-> IO (Result Response_String)
switchResponse s
conn Bool
allow_retry Bool
bdy_sent Result ResponseData
rsp Request_String
rqst                           
                           }

                ResponseNextStep
Retry -> {- Request with "Expect" header failed.
                                Trouble is the request contains Expects
                                other than "100-Continue" -}
                    do { -- TODO review throwing away of result
                         Result ()
_ <- s -> String -> IO (Result ())
forall x. Stream x => x -> String -> IO (Result ())
writeBlock s
conn (Request_String -> String
forall a. Show a => a -> String
show Request_String
rqst String -> String -> String
forall a. [a] -> [a] -> [a]
++ Request_String -> String
forall a. Request a -> a
rqBody Request_String
rqst)
                       ; Result ResponseData
rsp <- s -> IO (Result ResponseData)
forall s. Stream s => s -> IO (Result ResponseData)
getResponseHead s
conn
                       ; s
-> Bool
-> Bool
-> Result ResponseData
-> Request_String
-> IO (Result Response_String)
forall s.
Stream s =>
s
-> Bool
-> Bool
-> Result ResponseData
-> Request_String
-> IO (Result Response_String)
switchResponse s
conn Bool
False Bool
bdy_sent Result ResponseData
rsp Request_String
rqst
                       }   
                     
                ResponseNextStep
Done -> do
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Header] -> Bool
findConnClose [Header]
hdrs)
                         (s -> Bool -> IO ()
forall x. Stream x => x -> Bool -> IO ()
closeOnEnd s
conn Bool
True)
                    Result Response_String -> IO (Result Response_String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Response_String -> Result Response_String
forall a b. b -> Either a b
Right (Response_String -> Result Response_String)
-> Response_String -> Result Response_String
forall a b. (a -> b) -> a -> b
$ ResponseCode -> String -> [Header] -> String -> Response_String
forall a. ResponseCode -> String -> [Header] -> a -> Response a
Response ResponseCode
cd String
rn [Header]
hdrs String
"")

                DieHorribly String
str -> do
                    s -> IO ()
forall x. Stream x => x -> IO ()
close s
conn
                    Result Response_String -> IO (Result Response_String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result Response_String -> IO (Result Response_String))
-> Result Response_String -> IO (Result Response_String)
forall a b. (a -> b) -> a -> b
$ String -> String -> Result Response_String
forall a. String -> String -> Result a
responseParseError String
"sendHTTP" (String
"Invalid response: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str)

                ResponseNextStep
ExpectEntity ->
                    let tc :: Maybe String
tc = HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
HdrTransferEncoding [Header]
hdrs
                        cl :: Maybe String
cl = HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
HdrContentLength [Header]
hdrs
                    in
                    do { Result ([Header], String)
rslt <- case Maybe String
tc of
                          Maybe String
Nothing -> 
                              case Maybe String
cl of
                                  Just String
x  -> (Int -> IO (Result String))
-> Int -> IO (Result ([Header], String))
forall a.
(Int -> IO (Result a)) -> Int -> IO (Result ([Header], a))
linearTransfer (s -> Int -> IO (Result String)
forall x. Stream x => x -> Int -> IO (Result String)
readBlock s
conn) (String -> Int
forall a. Read a => String -> a
read String
x :: Int)
                                  Maybe String
Nothing -> BufferOp String
-> IO (Result String) -> [String] -> IO (Result ([Header], String))
forall a.
BufferOp a -> IO (Result a) -> [a] -> IO (Result ([Header], a))
hopefulTransfer BufferOp String
stringBufferOp {-null (++) []-} (s -> IO (Result String)
forall x. Stream x => x -> IO (Result String)
readLine s
conn) []
                          Just String
x  -> 
                              case (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String
trim String
x) of
                                  String
"chunked" -> BufferOp String
-> IO (Result String)
-> (Int -> IO (Result String))
-> IO (Result ([Header], String))
forall a.
BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> IO (Result ([Header], a))
chunkedTransfer BufferOp String
stringBufferOp
                                                               (s -> IO (Result String)
forall x. Stream x => x -> IO (Result String)
readLine s
conn) (s -> Int -> IO (Result String)
forall x. Stream x => x -> Int -> IO (Result String)
readBlock s
conn)
                                  String
_         -> String -> IO (Result ([Header], String))
forall a. String -> IO (Result ([Header], a))
uglyDeathTransfer String
"sendHTTP"
                       ; case Result ([Header], String)
rslt of
                           Left ConnError
e -> s -> IO ()
forall x. Stream x => x -> IO ()
close s
conn IO () -> IO (Result Response_String) -> IO (Result Response_String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Result Response_String -> IO (Result Response_String)
forall (m :: * -> *) a. Monad m => a -> m a
return (ConnError -> Result Response_String
forall a b. a -> Either a b
Left ConnError
e)
                           Right ([Header]
ftrs,String
bdy) -> do
                            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Header] -> Bool
findConnClose ([Header]
hdrs[Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++[Header]
ftrs))
                                 (s -> Bool -> IO ()
forall x. Stream x => x -> Bool -> IO ()
closeOnEnd s
conn Bool
True)
                            Result Response_String -> IO (Result Response_String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Response_String -> Result Response_String
forall a b. b -> Either a b
Right (ResponseCode -> String -> [Header] -> String -> Response_String
forall a. ResponseCode -> String -> [Header] -> a -> Response a
Response ResponseCode
cd String
rn ([Header]
hdrs[Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++[Header]
ftrs) String
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 :: s -> IO (Result Request_String)
receiveHTTP s
conn = IO (Result RequestData)
getRequestHead IO (Result RequestData)
-> (Result RequestData -> IO (Result Request_String))
-> IO (Result Request_String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Result RequestData -> IO (Result Request_String)
processRequest
    where
        -- reads and parses headers
        getRequestHead :: IO (Result RequestData)
        getRequestHead :: IO (Result RequestData)
getRequestHead =
            do { Result [String]
lor <- BufferOp String -> IO (Result String) -> IO (Result [String])
forall a. BufferOp a -> IO (Result a) -> IO (Result [a])
readTillEmpty1 BufferOp String
stringBufferOp (s -> IO (Result String)
forall x. Stream x => x -> IO (Result String)
readLine s
conn)
               ; Result RequestData -> IO (Result RequestData)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result RequestData -> IO (Result RequestData))
-> Result RequestData -> IO (Result RequestData)
forall a b. (a -> b) -> a -> b
$ Result [String]
lor Result [String]
-> ([String] -> Result RequestData) -> Result RequestData
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [String] -> Result RequestData
parseRequestHead
               }

        processRequest :: Result RequestData -> IO (Result Request_String)
processRequest (Left ConnError
e) = Result Request_String -> IO (Result Request_String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result Request_String -> IO (Result Request_String))
-> Result Request_String -> IO (Result Request_String)
forall a b. (a -> b) -> a -> b
$ ConnError -> Result Request_String
forall a b. a -> Either a b
Left ConnError
e
        processRequest (Right (RequestMethod
rm,URI
uri,[Header]
hdrs)) =
            do -- FIXME : Also handle 100-continue.
               let tc :: Maybe String
tc = HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
HdrTransferEncoding [Header]
hdrs
                   cl :: Maybe String
cl = HeaderName -> [Header] -> Maybe String
lookupHeader HeaderName
HdrContentLength [Header]
hdrs
               Result ([Header], String)
rslt <- case Maybe String
tc of
                          Maybe String
Nothing ->
                              case Maybe String
cl of
                                  Just String
x  -> (Int -> IO (Result String))
-> Int -> IO (Result ([Header], String))
forall a.
(Int -> IO (Result a)) -> Int -> IO (Result ([Header], a))
linearTransfer (s -> Int -> IO (Result String)
forall x. Stream x => x -> Int -> IO (Result String)
readBlock s
conn) (String -> Int
forall a. Read a => String -> a
read String
x :: Int)
                                  Maybe String
Nothing -> Result ([Header], String) -> IO (Result ([Header], String))
forall (m :: * -> *) a. Monad m => a -> m a
return (([Header], String) -> Result ([Header], String)
forall a b. b -> Either a b
Right ([], String
"")) -- hopefulTransfer ""
                          Just String
x  ->
                              case (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String
trim String
x) of
                                  String
"chunked" -> BufferOp String
-> IO (Result String)
-> (Int -> IO (Result String))
-> IO (Result ([Header], String))
forall a.
BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> IO (Result ([Header], a))
chunkedTransfer BufferOp String
stringBufferOp
                                                               (s -> IO (Result String)
forall x. Stream x => x -> IO (Result String)
readLine s
conn) (s -> Int -> IO (Result String)
forall x. Stream x => x -> Int -> IO (Result String)
readBlock s
conn)
                                  String
_         -> String -> IO (Result ([Header], String))
forall a. String -> IO (Result ([Header], a))
uglyDeathTransfer String
"receiveHTTP"
               
               Result Request_String -> IO (Result Request_String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result Request_String -> IO (Result Request_String))
-> Result Request_String -> IO (Result Request_String)
forall a b. (a -> b) -> a -> b
$ do
                  ([Header]
ftrs,String
bdy) <- Result ([Header], String)
rslt
                  Request_String -> Result Request_String
forall (m :: * -> *) a. Monad m => a -> m a
return (URI -> RequestMethod -> [Header] -> String -> Request_String
forall a. URI -> RequestMethod -> [Header] -> a -> Request a
Request URI
uri RequestMethod
rm ([Header]
hdrs[Header] -> [Header] -> [Header]
forall a. [a] -> [a] -> [a]
++[Header]
ftrs) String
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 :: s -> Response_String -> IO ()
respondHTTP s
conn Response_String
rsp = do -- TODO review throwing away of result
                          Result ()
_ <- s -> String -> IO (Result ())
forall x. Stream x => x -> String -> IO (Result ())
writeBlock s
conn (Response_String -> String
forall a. Show a => a -> String
show Response_String
rsp)
                          -- write body immediately, don't wait for 100 CONTINUE
                          -- TODO review throwing away of result
                          Result ()
_ <- s -> String -> IO (Result ())
forall x. Stream x => x -> String -> IO (Result ())
writeBlock s
conn (Response_String -> String
forall a. Response a -> a
rspBody Response_String
rsp)
                          () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()