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
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]
:
[]
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
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
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"
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
(Int
1,Int
_,Int
_) -> Behaviour
Continue
(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
(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
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
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)
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
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)
switchResponse :: (Monad m, Body.C body) =>
Bool
-> Bool
-> Request body
-> ResponseData
-> SynchronousExceptional body m (Async.Exceptional ConnError (Response body))
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
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
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 ->
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
fixHostHeader :: Request body -> Request body
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
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"
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 :: (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)
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
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) =
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
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
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)
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)
forall (m :: * -> *) body.
Monad m =>
body -> SyncExceptional body m ()
writeBlock (forall a. Response a -> a
rspBody Response body
rsp)
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
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
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
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)
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
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))
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])]
_ ->
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))
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"
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
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
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