{- |
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.Class (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 Data.Semigroup (Semigroup, (<>), )
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 =
   Async.ExceptionalT ConnError (StreamMonad.T body m) a



-- * Parsing

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


-- Parsing a request
parseRequestHead :: [String] -> Sync.Exceptional ConnError RequestData
parseRequestHead :: [[Char]] -> Exceptional ConnError RequestData
parseRequestHead [] = forall e a. e -> Exceptional e a
Sync.throw ConnError
ErrorClosed
parseRequestHead ([Char]
com:[[Char]]
hdrs) =
   [Char] -> Exceptional ConnError ([[Char]], RequestMethod, URI)
requestCommand [Char]
com forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \([[Char]]
_version,RequestMethod
rqm,URI
uri) ->
   forall (m :: * -> *) a. Monad m => a -> m a
return (RequestMethod
rqm, URI
uri, [[Char]] -> [T]
Header.parseManyStraight [[Char]]
hdrs)
   where
      requestCommand :: [Char] -> Exceptional ConnError ([[Char]], RequestMethod, URI)
requestCommand [Char]
line =
	 case [Char] -> [[Char]]
words [Char]
line of
            ([Char]
rqm:[Char]
uri:[[Char]]
version) ->
               forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2
                  (\RequestMethod
r URI
u -> ([[Char]]
version,RequestMethod
r,URI
u))
                  (forall e a. e -> Maybe a -> Exceptional e a
Sync.fromMaybe
                      ([Char] -> ConnError
ErrorParse forall a b. (a -> b) -> a -> b
$ [Char]
"Unknown HTTP method: " forall a. [a] -> [a] -> [a]
++ [Char]
rqm)
                      (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Char]
rqm Map [Char] RequestMethod
requestMethodDict))
                  (forall e a. e -> Maybe a -> Exceptional e a
Sync.fromMaybe
                      ([Char] -> ConnError
ErrorParse forall a b. (a -> b) -> a -> b
$ [Char]
"Malformed URI: " forall a. [a] -> [a] -> [a]
++ [Char]
uri)
                      ([Char] -> Maybe URI
parseURIReference [Char]
uri))
	    [[Char]]
_ -> forall e a. e -> Exceptional e a
Sync.throw forall a b. (a -> b) -> a -> b
$
              if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
line
		then ConnError
ErrorClosed
		else [Char] -> ConnError
ErrorParse forall a b. (a -> b) -> a -> b
$ [Char]
"Request command line parse failure: " forall a. [a] -> [a] -> [a]
++ [Char]
line

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

      getDigit :: Char -> Exceptional ConnError Int
getDigit Char
d =
         if Char -> Bool
isDigit Char
d
           then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Char -> Int
digitToInt Char
d
           else forall e a. e -> Exceptional e a
Sync.throw forall a b. (a -> b) -> a -> b
$ [Char] -> ConnError
ErrorParse forall a b. (a -> b) -> a -> b
$ [Char]
"Non-digit "forall a. [a] -> [a] -> [a]
++Char
dforall a. a -> [a] -> [a]
:[Char]
" in Response Code"





-- * HTTP Send / Recv

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

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


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

-- reads and parses headers
getResponseHead :: (Monad m, Body.C body) => SynchronousExceptional body m (Async.Exceptional ConnError ResponseData)
getResponseHead :: forall (m :: * -> *) body.
(Monad m, C body) =>
SynchronousExceptional body m (Exceptional ConnError ResponseData)
getResponseHead =
   forall e (m :: * -> *) a. m (Exceptional e a) -> ExceptionalT e m a
Sync.ExceptionalT forall a b. (a -> b) -> a -> b
$
   forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall (m :: * -> *) e a.
Monad m =>
Exceptional e (m a) -> m (Exceptional e a)
Async.sequence forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([[Char]] -> Exceptional ConnError ResponseData
parseResponseHead forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall body. C body => body -> [Char]
Body.toString)) forall a b. (a -> b) -> a -> b
$
   forall e (m :: * -> *) a. ExceptionalT e m a -> m (Exceptional e a)
Async.runExceptionalT forall (m :: * -> *) body.
(Monad m, C body) =>
AsynchronousExceptional body m [body]
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 :: forall (m :: * -> *) body.
(Monad m, C body) =>
(ResponseData
 -> SynchronousExceptional
      body m (Exceptional ConnError (Response body)))
-> SynchronousExceptional
     body m (Exceptional ConnError (Response body))
withResponseHead =
   forall (m :: * -> *) e a b.
Monad m =>
m (Exceptional e a)
-> (a -> m b) -> (a -> m (Exceptional e b)) -> m (Exceptional e b)
Exc.switchM forall (m :: * -> *) body.
(Monad m, C body) =>
SynchronousExceptional body m (Exceptional ConnError ResponseData)
getResponseHead (\((Int, Int, Int)
cd,[Char]
rn,[T]
hdrs) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (Int, Int, Int) -> [Char] -> [T] -> a -> Response a
Response (Int, Int, Int)
cd [Char]
rn [T]
hdrs forall a. Monoid a => a
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 :: forall (m :: * -> *) body.
(Monad m, C body) =>
Bool
-> Bool
-> Request body
-> ResponseData
-> SynchronousExceptional
     body m (Exceptional ConnError (Response body))
switchResponse Bool
allow_retry Bool
bdy_sent Request body
rqst ((Int, Int, Int)
cd,[Char]
rn,[T]
hdrs) =
   case RequestMethod -> (Int, Int, Int) -> Behaviour
matchResponse (forall a. Request a -> RequestMethod
rqMethod Request body
rqst) (Int, Int, Int)
cd of
      Behaviour
Continue ->
         if Bool -> Bool
not Bool
bdy_sent
           then {- Time to send the body -}
             forall (m :: * -> *) body.
Monad m =>
body -> SyncExceptional body m ()
writeBlock (forall a. Request a -> a
rqBody Request body
rqst) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
             (forall (m :: * -> *) body.
(Monad m, C body) =>
(ResponseData
 -> SynchronousExceptional
      body m (Exceptional ConnError (Response body)))
-> SynchronousExceptional
     body m (Exceptional ConnError (Response body))
withResponseHead forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) body.
(Monad m, C body) =>
Bool
-> Bool
-> Request body
-> ResponseData
-> SynchronousExceptional
     body m (Exceptional ConnError (Response body))
switchResponse Bool
allow_retry Bool
True Request body
rqst)
           else {- keep waiting -}
             forall (m :: * -> *) body.
(Monad m, C body) =>
(ResponseData
 -> SynchronousExceptional
      body m (Exceptional ConnError (Response body)))
-> SynchronousExceptional
     body m (Exceptional ConnError (Response body))
withResponseHead forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *) body.
(Monad m, C body) =>
Bool
-> Bool
-> Request body
-> ResponseData
-> SynchronousExceptional
     body m (Exceptional ConnError (Response body))
switchResponse Bool
allow_retry Bool
bdy_sent Request body
rqst

      Behaviour
Retry -> {- Request with "Expect" header failed.
                      Trouble is the request contains Expects
                      other than "100-Continue" -}
         forall (m :: * -> *) body.
Monad m =>
body -> SyncExceptional body m ()
writeBlock (forall body. C body => [Char] -> body
Body.fromString (forall a. Show a => a -> [Char]
show Request body
rqst) forall a. Monoid a => a -> a -> a
`mappend` forall a. Request a -> a
rqBody Request body
rqst) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
         (forall (m :: * -> *) body.
(Monad m, C body) =>
(ResponseData
 -> SynchronousExceptional
      body m (Exceptional ConnError (Response body)))
-> SynchronousExceptional
     body m (Exceptional ConnError (Response body))
withResponseHead forall a b. (a -> b) -> a -> b
$
             forall (m :: * -> *) body.
(Monad m, C body) =>
Bool
-> Bool
-> Request body
-> ResponseData
-> SynchronousExceptional
     body m (Exceptional ConnError (Response body))
switchResponse Bool
False Bool
bdy_sent Request body
rqst)

      Behaviour
Done ->
         forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a e. a -> Exceptional e a
Async.pure forall a b. (a -> b) -> a -> b
$ forall a. (Int, Int, Int) -> [Char] -> [T] -> a -> Response a
Response (Int, Int, Int)
cd [Char]
rn [T]
hdrs forall a. Monoid a => a
mempty

      DieHorribly [Char]
str ->
         forall (m :: * -> *) e a. Monad m => e -> ExceptionalT e m a
Sync.throwT forall a b. (a -> b) -> a -> b
$ [Char] -> ConnError
ErrorParse ([Char]
"Invalid response: " forall a. [a] -> [a] -> [a]
++ [Char]
str)

      Behaviour
ExpectEntity ->
         let tc :: Maybe [Char]
tc = Name -> [T] -> Maybe [Char]
Header.lookup Name
Header.HdrTransferEncoding [T]
hdrs
             cl :: Maybe [Char]
cl = Name -> [T] -> Maybe [Char]
Header.lookup Name
Header.HdrContentLength [T]
hdrs
         in  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptionalT e m a -> m (Exceptional e a)
Async.runExceptionalT forall a b. (a -> b) -> a -> b
$
             forall (m :: * -> *) body a.
Monad m =>
([T] -> body -> a)
-> [T]
-> AsynchronousExceptional body m ([T], body)
-> AsynchronousExceptional body m a
assembleHeaderBody (forall a. (Int, Int, Int) -> [Char] -> [T] -> a -> Response a
Response (Int, Int, Int)
cd [Char]
rn) [T]
hdrs forall a b. (a -> b) -> a -> b
$
             case Maybe [Char]
tc of
                Maybe [Char]
Nothing ->
                   case Maybe [Char]
cl of
                      Just [Char]
x  -> forall (m :: * -> *) body.
(Monad m, Monoid body) =>
[Char] -> AsynchronousExceptional body m ([T], body)
linearTransferStrLen [Char]
x
                      Maybe [Char]
Nothing -> forall (m :: * -> *) body.
(Monad m, C body) =>
AsynchronousExceptional body m ([T], body)
hopefulTransfer
                Just [Char]
x  ->
                   case forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ([Char] -> [Char]
trim [Char]
x) of
                      [Char]
"chunked" -> forall (m :: * -> *) body.
(Monad m, C body) =>
Bool -> AsynchronousExceptional body m ([T], body)
chunkedTransfer Bool
False
                      [Char]
_         -> forall (m :: * -> *) body.
(Monad m, Monoid body) =>
AsynchronousExceptional body m ([T], body)
uglyDeathTransfer


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

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

-- This function duplicates old Network.URI.authority behaviour.
uriToAuthorityString :: URI -> String
uriToAuthorityString :: URI -> [Char]
uriToAuthorityString URI{uriAuthority :: URI -> Maybe URIAuth
uriAuthority=Maybe URIAuth
Nothing} = [Char]
""
uriToAuthorityString URI{uriAuthority :: URI -> Maybe URIAuth
uriAuthority=Just URIAuth
ua} = URIAuth -> [Char]
uriUserInfo URIAuth
ua forall a. [a] -> [a] -> [a]
++
                                                 URIAuth -> [Char]
uriRegName URIAuth
ua forall a. [a] -> [a] -> [a]
++
                                                 URIAuth -> [Char]
uriPort URIAuth
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 :: forall (m :: * -> *) body.
(Monad m, C body) =>
SynchronousExceptional
  body m (Exceptional ConnError (Request body))
receive =
   forall (m :: * -> *) e a b.
Monad m =>
m (Exceptional e a)
-> (a -> m b) -> (a -> m (Exceptional e b)) -> m (Exceptional e b)
Exc.switchM forall (m :: * -> *) body.
(Monad m, C body) =>
SynchronousExceptional body m (Exceptional ConnError RequestData)
getRequestHead
      (\(RequestMethod
rm,URI
uri,[T]
hdrs) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. URI -> RequestMethod -> [T] -> a -> Request a
Request URI
uri RequestMethod
rm [T]
hdrs forall a. Monoid a => a
mempty)
      (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ExceptionalT e m a -> m (Exceptional e a)
Async.runExceptionalT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) body.
(Monad m, C body) =>
RequestData -> AsynchronousExceptional body m (Request body)
processRequest)

-- | Reads and parses request headers.
getRequestHead :: (Monad m, Body.C body) => SynchronousExceptional body m (Async.Exceptional ConnError RequestData)
getRequestHead :: forall (m :: * -> *) body.
(Monad m, C body) =>
SynchronousExceptional body m (Exceptional ConnError RequestData)
getRequestHead =
   forall e (m :: * -> *) a. m (Exceptional e a) -> ExceptionalT e m a
Sync.ExceptionalT forall a b. (a -> b) -> a -> b
$
   forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall (m :: * -> *) e a.
Monad m =>
Exceptional e (m a) -> m (Exceptional e a)
Async.sequence forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([[Char]] -> Exceptional ConnError RequestData
parseRequestHead forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall body. C body => body -> [Char]
Body.toString)) forall a b. (a -> b) -> a -> b
$
   forall e (m :: * -> *) a. ExceptionalT e m a -> m (Exceptional e a)
Async.runExceptionalT forall (m :: * -> *) body.
(Monad m, C body) =>
AsynchronousExceptional body m [body]
readTillEmpty1

-- | Process request body (called after successful getRequestHead)
processRequest :: (Monad m, Body.C body) => RequestData -> AsynchronousExceptional body m (Request body)
processRequest :: forall (m :: * -> *) body.
(Monad m, C body) =>
RequestData -> AsynchronousExceptional body m (Request body)
processRequest (RequestMethod
rm,URI
uri,[T]
hdrs) =
   -- FIXME : Also handle 100-continue.
   let tc :: Maybe [Char]
tc = Name -> [T] -> Maybe [Char]
Header.lookup Name
Header.HdrTransferEncoding [T]
hdrs
       cl :: Maybe [Char]
cl = Name -> [T] -> Maybe [Char]
Header.lookup Name
Header.HdrContentLength [T]
hdrs
   in  forall (m :: * -> *) body a.
Monad m =>
([T] -> body -> a)
-> [T]
-> AsynchronousExceptional body m ([T], body)
-> AsynchronousExceptional body m a
assembleHeaderBody (forall a. URI -> RequestMethod -> [T] -> a -> Request a
Request URI
uri RequestMethod
rm) [T]
hdrs forall a b. (a -> b) -> a -> b
$
       case Maybe [Char]
tc of
          Maybe [Char]
Nothing ->
             case Maybe [Char]
cl of
                Just [Char]
x  -> forall (m :: * -> *) body.
(Monad m, Monoid body) =>
[Char] -> AsynchronousExceptional body m ([T], body)
linearTransferStrLen [Char]
x
                Maybe [Char]
Nothing -> forall a. Monoid a => a
mempty
                -- hopefulTransfer
          Just [Char]
x  ->
             case forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ([Char] -> [Char]
trim [Char]
x) of
                [Char]
"chunked" -> forall (m :: * -> *) body.
(Monad m, C body) =>
Bool -> AsynchronousExceptional body m ([T], body)
chunkedTransfer Bool
False
                [Char]
_         -> forall (m :: * -> *) body.
(Monad m, Monoid body) =>
AsynchronousExceptional body m ([T], body)
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 :: forall (m :: * -> *) body a.
Monad m =>
([T] -> body -> a)
-> [T]
-> AsynchronousExceptional body m ([T], body)
-> AsynchronousExceptional body m a
assembleHeaderBody [T] -> body -> a
make [T]
hdrs =
   forall (m :: * -> *) a b body.
Monad m =>
(a -> b) -> ExceptionalT body m a -> ExceptionalT body m b
Exc.map (\([T]
_ftrs,body
bdy) -> [T] -> body -> a
make [T]
hdrs body
bdy)
--   Exc.map (\(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 :: forall (m :: * -> *) body.
(Monad m, C body) =>
Response body -> SynchronousExceptional body m ()
respond Response body
rsp =
   do forall (m :: * -> *) body.
Monad m =>
body -> SyncExceptional body m ()
writeBlock (forall body. C body => [Char] -> body
Body.fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Response body
rsp)
      -- write body immediately, don't wait for 100 CONTINUE
      forall (m :: * -> *) body.
Monad m =>
body -> SyncExceptional body m ()
writeBlock (forall a. Response a -> a
rspBody Response body
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 :: forall (m :: * -> *) body.
(Monad m, Monoid body) =>
[Char] -> AsynchronousExceptional body m ([T], body)
linearTransferStrLen [Char]
ns =
   case forall a. Read a => ReadS a
reads [Char]
ns of
      [(Int
n,[Char]
"")] -> forall (m :: * -> *) body.
Monad m =>
Int -> AsynchronousExceptional body m ([T], body)
linearTransfer Int
n
      [(Int, [Char])]
_ -> forall (m :: * -> *) a e.
(Monad m, Monoid a) =>
e -> ExceptionalT e m a
Async.throwMonoidT forall a b. (a -> b) -> a -> b
$ [Char] -> ConnError
ErrorParse forall a b. (a -> b) -> a -> b
$ [Char]
"Content-Length header contains not a number: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
ns

-- | Used when we know exactly how many bytes to expect.
linearTransfer :: Monad m => Int -> AsynchronousExceptional body m ([Header.T],body)
linearTransfer :: forall (m :: * -> *) body.
Monad m =>
Int -> AsynchronousExceptional body m ([T], body)
linearTransfer Int
n =
   forall (m :: * -> *) a b body.
Monad m =>
(a -> b) -> ExceptionalT body m a -> ExceptionalT body m b
Exc.map ((,) []) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) body.
Monad m =>
Int -> AsyncExceptional body m body
readBlock Int
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 :: forall (m :: * -> *) body.
(Monad m, C body) =>
AsynchronousExceptional body m ([T], body)
hopefulTransfer =
   let go :: AsynchronousExceptional body m body
go =
         forall (m :: * -> *) a body.
(Monad m, Monoid a) =>
(body -> AsynchronousExceptional body m a)
-> AsynchronousExceptional body m a
readLineSwitch forall a b. (a -> b) -> a -> b
$ \body
line ->
            if forall body. C body => body -> Bool
Body.isEmpty body
line
              then forall a. Monoid a => a
mempty
              else forall (m :: * -> *) a b body.
Monad m =>
(a -> b) -> ExceptionalT body m a -> ExceptionalT body m b
Exc.map (forall a. Monoid a => a -> a -> a
mappend body
line) AsynchronousExceptional body m body
go
   in  forall (m :: * -> *) a b body.
Monad m =>
(a -> b) -> ExceptionalT body m a -> ExceptionalT body m b
Exc.map ((,) []) AsynchronousExceptional body m body
go


-- | in contrast to built-in @(,,)@, its mappend implementation is lazy
data ChunkedResponse body =
   ChunkedResponse [Header.T] [Int] body
      deriving Int -> ChunkedResponse body -> [Char] -> [Char]
forall body.
Show body =>
Int -> ChunkedResponse body -> [Char] -> [Char]
forall body.
Show body =>
[ChunkedResponse body] -> [Char] -> [Char]
forall body. Show body => ChunkedResponse body -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [ChunkedResponse body] -> [Char] -> [Char]
$cshowList :: forall body.
Show body =>
[ChunkedResponse body] -> [Char] -> [Char]
show :: ChunkedResponse body -> [Char]
$cshow :: forall body. Show body => ChunkedResponse body -> [Char]
showsPrec :: Int -> ChunkedResponse body -> [Char] -> [Char]
$cshowsPrec :: forall body.
Show body =>
Int -> ChunkedResponse body -> [Char] -> [Char]
Show

instance Semigroup body => Semigroup (ChunkedResponse body) where
   ChunkedResponse [T]
hx [Int]
lx body
sx <> :: ChunkedResponse body
-> ChunkedResponse body -> ChunkedResponse body
<> ChunkedResponse [T]
hy [Int]
ly body
sy =
       forall body. [T] -> [Int] -> body -> ChunkedResponse body
ChunkedResponse ([T]
hx forall a. Semigroup a => a -> a -> a
<> [T]
hy) ([Int]
lx forall a. Semigroup a => a -> a -> a
<> [Int]
ly) (body
sx forall a. Semigroup a => a -> a -> a
<> body
sy)

instance Monoid body => Monoid (ChunkedResponse body) where
   mempty :: ChunkedResponse body
mempty = forall body. [T] -> [Int] -> body -> ChunkedResponse body
ChunkedResponse forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
   mappend :: ChunkedResponse body
-> ChunkedResponse body -> ChunkedResponse body
mappend (ChunkedResponse [T]
hx [Int]
lx body
sx) (ChunkedResponse [T]
hy [Int]
ly body
sy) =
       forall body. [T] -> [Int] -> body -> ChunkedResponse body
ChunkedResponse (forall a. Monoid a => a -> a -> a
mappend [T]
hx [T]
hy) (forall a. Monoid a => a -> a -> a
mappend [Int]
lx [Int]
ly) (forall a. Monoid a => a -> a -> a
mappend body
sx body
sy)

forceCR :: ChunkedResponse body -> ChunkedResponse body
forceCR :: forall body. ChunkedResponse body -> ChunkedResponse body
forceCR ~(ChunkedResponse [T]
h [Int]
l body
s) = (forall body. [T] -> [Int] -> body -> ChunkedResponse body
ChunkedResponse [T]
h [Int]
l body
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 :: forall (m :: * -> *) body.
(Monad m, C body) =>
Bool -> AsynchronousExceptional body m ([T], body)
chunkedTransfer Bool
attachLength =
   forall (m :: * -> *) a b body.
Monad m =>
(a -> b) -> ExceptionalT body m a -> ExceptionalT body m b
Exc.map (\(ChunkedResponse [T]
ftrs [Int]
sizes body
info) ->
      ((if Bool
attachLength
          then (Name -> [Char] -> T
Header.Header Name
Header.HdrContentLength (forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
sizes) forall a. a -> [a] -> [a]
:)
          else forall a. a -> a
id) [T]
ftrs,
       body
info)) forall a b. (a -> b) -> a -> b
$
   forall (m :: * -> *) body.
(Monad m, C body) =>
AsynchronousExceptional body m (ChunkedResponse body)
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 :: forall (m :: * -> *) body.
(Monad m, C body) =>
AsynchronousExceptional body m (ChunkedResponse body)
chunkedTransferLoop =
   forall (m :: * -> *) a body.
(Monad m, Monoid a) =>
(body -> AsynchronousExceptional body m a)
-> AsynchronousExceptional body m a
readLineSwitch forall a b. (a -> b) -> a -> b
$ \body
line ->
      case forall a. (Eq a, Num a) => ReadS a
readHex forall a b. (a -> b) -> a -> b
$ forall body. C body => body -> [Char]
Body.toString body
line of
         [(Int
size,[Char]
_)] ->
            if Int
size forall a. Eq a => a -> a -> Bool
== Int
0
              then
                 forall (m :: * -> *) a b body.
Monad m =>
(a -> b) -> ExceptionalT body m a -> ExceptionalT body m b
Exc.map (\[body]
strs -> forall body. [T] -> [Int] -> body -> ChunkedResponse body
ChunkedResponse ([[Char]] -> [T]
Header.parseManyStraight forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall body. C body => body -> [Char]
Body.toString [body]
strs) [Int
0] forall a. Monoid a => a
mempty)
                    forall (m :: * -> *) body.
(Monad m, C body) =>
AsynchronousExceptional body m [body]
readTillEmpty2
              else
                 forall (m :: * -> *) a b body.
Monad m =>
(a -> b) -> ExceptionalT body m a -> ExceptionalT body m b
Exc.map (\body
block -> forall body. [T] -> [Int] -> body -> ChunkedResponse body
ChunkedResponse [] [Int
0] body
block) (forall (m :: * -> *) body.
Monad m =>
Int -> AsyncExceptional body m body
readBlock Int
size)
                 forall a. Monoid a => a -> a -> a
`mappend`
                 forall e (m :: * -> *) a. m (Exceptional e a) -> ExceptionalT e m a
Async.ExceptionalT
                 ((forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
                     (\Exceptional ConnError body
newLineE ->
                         forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
                           (forall e a. Exceptional e a -> Maybe e
Async.exception Exceptional ConnError body
newLineE)
                           (forall a. Bool -> a -> Maybe a
toMaybe
                              (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall body. C body => body -> Bool
Body.isLineTerm forall a b. (a -> b) -> a -> b
$ forall e a. Exceptional e a -> a
Async.result Exceptional ConnError body
newLineE)
                              ([Char] -> ConnError
ErrorParse forall a b. (a -> b) -> a -> b
$ [Char]
"no CR+LF after chunk"))) forall a b. (a -> b) -> a -> b
$
                   forall e (m :: * -> *) a. ExceptionalT e m a -> m (Exceptional e a)
Async.runExceptionalT (forall (m :: * -> *) body.
Monad m =>
Int -> AsyncExceptional body m body
readBlock Int
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)
-}
                  forall (m :: * -> *) a e.
(Monad m, Monoid a) =>
m (Maybe e) -> m (Exceptional e a) -> m (Exceptional e a)
`Async.continueM`
                  forall e (m :: * -> *) a. ExceptionalT e m a -> m (Exceptional e a)
Async.runExceptionalT (forall (m :: * -> *) a b body.
Monad m =>
(a -> b) -> ExceptionalT body m a -> ExceptionalT body m b
Exc.map forall body. ChunkedResponse body -> ChunkedResponse body
forceCR forall (m :: * -> *) body.
(Monad m, C body) =>
AsynchronousExceptional body m (ChunkedResponse body)
chunkedTransferLoop))
         [(Int, [Char])]
_ ->
            {- old implementation continued reading anyway in this case
               as if the Chunk length was 0 -}
            forall (m :: * -> *) a e.
(Monad m, Monoid a) =>
e -> ExceptionalT e m a
Async.throwMonoidT
               ([Char] -> ConnError
ErrorParse forall a b. (a -> b) -> a -> b
$ [Char]
"Chunk-Length is not a number: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall body. C body => body -> [Char]
Body.toString body
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 :: forall (m :: * -> *) body.
(Monad m, Monoid body) =>
AsynchronousExceptional body m ([T], body)
uglyDeathTransfer =
   forall (m :: * -> *) a e.
(Monad m, Monoid a) =>
e -> ExceptionalT e m a
Async.throwMonoidT forall a b. (a -> b) -> a -> b
$
   [Char] -> ConnError
ErrorParse [Char]
"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 :: forall (m :: * -> *) body.
(Monad m, C body) =>
AsynchronousExceptional body m [body]
readTillEmpty1 =
   forall (m :: * -> *) a body.
(Monad m, Monoid a) =>
(body -> AsynchronousExceptional body m a)
-> AsynchronousExceptional body m a
readLineSwitch forall a b. (a -> b) -> a -> b
$ \body
s ->
      if forall body. C body => body -> Bool
Body.isLineTerm body
s
        then forall (m :: * -> *) body.
(Monad m, C body) =>
AsynchronousExceptional body m [body]
readTillEmpty1
        else forall (m :: * -> *) a b body.
Monad m =>
(a -> b) -> ExceptionalT body m a -> ExceptionalT body m b
Exc.map (body
sforall a. a -> [a] -> [a]
:) forall (m :: * -> *) body.
(Monad m, C body) =>
AsynchronousExceptional body m [body]
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 :: forall (m :: * -> *) body.
(Monad m, C body) =>
AsynchronousExceptional body m [body]
readTillEmpty2 =
   forall (m :: * -> *) a body.
(Monad m, Monoid a) =>
(body -> AsynchronousExceptional body m a)
-> AsynchronousExceptional body m a
readLineSwitch forall a b. (a -> b) -> a -> b
$ \body
s ->
      if forall body. C body => body -> Bool
Body.isLineTerm body
s Bool -> Bool -> Bool
|| forall body. C body => body -> Bool
Body.isEmpty body
s
        then forall a. Monoid a => a
mempty
        else forall (m :: * -> *) a b body.
Monad m =>
(a -> b) -> ExceptionalT body m a -> ExceptionalT body m b
Exc.map (body
sforall a. a -> [a] -> [a]
:) forall (m :: * -> *) body.
(Monad m, C body) =>
AsynchronousExceptional body m [body]
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 :: forall (m :: * -> *) a body.
(Monad m, Monoid a) =>
(body -> AsynchronousExceptional body m a)
-> AsynchronousExceptional body m a
readLineSwitch body -> AsynchronousExceptional body m a
next =
   forall (m :: * -> *) b e a.
(Monad m, Monoid b) =>
ExceptionalT e m a
-> (a -> ExceptionalT e m b) -> ExceptionalT e m b
Async.bindT forall (m :: * -> *) body. Monad m => AsyncExceptional body m body
readLine body -> AsynchronousExceptional body m a
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)
-}