module Network.HTTP.Stream
( module Network.Stream
, simpleHTTP
, simpleHTTP_
, sendHTTP
, sendHTTP_notify
, receiveHTTP
, respondHTTP
) where
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)
debug :: Bool
debug :: Bool
debug = Bool
False
httpLogFile :: String
httpLogFile :: String
httpLogFile = String
"http-debug.log"
simpleHTTP :: Request_String -> IO (Result Response_String)
simpleHTTP :: Request_String -> IO (Result Response_String)
simpleHTTP Request_String
r = do
URIAuthority
auth <- 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) (forall a. a -> Maybe a -> a
fromMaybe Int
80 (URIAuthority -> Maybe Int
port URIAuthority
auth))
forall s.
Stream s =>
s -> Request_String -> IO (Result Response_String)
simpleHTTP_ Connection
c Request_String
r
simpleHTTP_ :: Stream s => s -> Request_String -> IO (Result Response_String)
simpleHTTP_ :: forall s.
Stream s =>
s -> Request_String -> IO (Result Response_String)
simpleHTTP_ s
s Request_String
r
| Bool -> Bool
not Bool
debug = forall s.
Stream s =>
s -> Request_String -> IO (Result Response_String)
sendHTTP s
s Request_String
r
| Bool
otherwise = do
StreamDebugger s
s' <- forall a. Stream a => String -> a -> IO (StreamDebugger a)
debugStream String
httpLogFile s
s
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 :: forall s.
Stream s =>
s -> Request_String -> IO (Result Response_String)
sendHTTP s
conn Request_String
rq = forall s.
Stream s =>
s -> Request_String -> IO () -> IO (Result Response_String)
sendHTTP_notify s
conn Request_String
rq (forall (m :: * -> *) a. Monad m => a -> m a
return ())
sendHTTP_notify :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String)
sendHTTP_notify :: forall s.
Stream s =>
s -> Request_String -> IO () -> IO (Result Response_String)
sendHTTP_notify s
conn Request_String
rq IO ()
onSendComplete = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
providedClose forall a b. (a -> b) -> a -> b
$ (forall x. Stream x => x -> Bool -> IO ()
closeOnEnd s
conn Bool
True)
forall a b. IO a -> IO b -> IO a
onException (forall s.
Stream s =>
s -> Request_String -> IO () -> IO (Result Response_String)
sendMain s
conn Request_String
rq IO ()
onSendComplete)
(forall x. Stream x => x -> IO ()
close s
conn)
where
providedClose :: Bool
providedClose = [Header] -> Bool
findConnClose (forall a. Request a -> [Header]
rqHeaders Request_String
rq)
sendMain :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String)
sendMain :: forall s.
Stream s =>
s -> Request_String -> IO () -> IO (Result Response_String)
sendMain s
conn Request_String
rqst IO ()
onSendComplete = do
Result ()
_ <- forall x. Stream x => x -> String -> IO (Result ())
writeBlock s
conn (forall a. Show a => a -> String
show Request_String
rqst)
Result ()
_ <- forall x. Stream x => x -> String -> IO (Result ())
writeBlock s
conn (forall a. Request a -> a
rqBody Request_String
rqst)
IO ()
onSendComplete
Result ResponseData
rsp <- forall s. Stream s => s -> IO (Result ResponseData)
getResponseHead s
conn
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
getResponseHead :: Stream s => s -> IO (Result ResponseData)
getResponseHead :: forall s. Stream s => s -> IO (Result ResponseData)
getResponseHead s
conn = do
Result [String]
lor <- forall a. BufferOp a -> IO (Result a) -> IO (Result [a])
readTillEmpty1 BufferOp String
stringBufferOp (forall x. Stream x => x -> IO (Result String)
readLine s
conn)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Result [String]
lor forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [String] -> Result ResponseData
parseResponseHead
switchResponse :: Stream s
=> s
-> Bool
-> Bool
-> Result ResponseData
-> Request_String
-> IO (Result Response_String)
switchResponse :: forall s.
Stream s =>
s
-> Bool
-> Bool
-> Result ResponseData
-> Request_String
-> IO (Result Response_String)
switchResponse s
_ Bool
_ Bool
_ (Left ConnError
e) Request_String
_ = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left ConnError
e)
switchResponse s
conn Bool
allow_retry Bool
bdy_sent (Right (ResponseCode
cd,String
rn,[Header]
hdrs)) Request_String
rqst =
case RequestMethod -> ResponseCode -> ResponseNextStep
matchResponse (forall a. Request a -> RequestMethod
rqMethod Request_String
rqst) ResponseCode
cd of
ResponseNextStep
Continue
| Bool -> Bool
not Bool
bdy_sent ->
do { Result ()
val <- forall x. Stream x => x -> String -> IO (Result ())
writeBlock s
conn (forall a. Request a -> a
rqBody Request_String
rqst)
; case Result ()
val of
Left ConnError
e -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left ConnError
e)
Right ()
_ ->
do { Result ResponseData
rsp <- forall s. Stream s => s -> IO (Result ResponseData)
getResponseHead s
conn
; 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 ->
do { Result ResponseData
rsp <- forall s. Stream s => s -> IO (Result ResponseData)
getResponseHead s
conn
; 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 ->
do {
Result ()
_ <- forall x. Stream x => x -> String -> IO (Result ())
writeBlock s
conn (forall a. Show a => a -> String
show Request_String
rqst forall a. [a] -> [a] -> [a]
++ forall a. Request a -> a
rqBody Request_String
rqst)
; Result ResponseData
rsp <- forall s. Stream s => s -> IO (Result ResponseData)
getResponseHead s
conn
; 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Header] -> Bool
findConnClose [Header]
hdrs)
(forall x. Stream x => x -> Bool -> IO ()
closeOnEnd s
conn Bool
True)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. ResponseCode -> String -> [Header] -> a -> Response a
Response ResponseCode
cd String
rn [Header]
hdrs String
"")
DieHorribly String
str -> do
forall x. Stream x => x -> IO ()
close s
conn
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. String -> String -> Result a
responseParseError String
"sendHTTP" (String
"Invalid response: " 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 -> forall a.
(Int -> IO (Result a)) -> Int -> IO (Result ([Header], a))
linearTransfer (forall x. Stream x => x -> Int -> IO (Result String)
readBlock s
conn) (forall a. Read a => String -> a
read String
x :: Int)
Maybe String
Nothing -> forall a.
BufferOp a -> IO (Result a) -> [a] -> IO (Result ([Header], a))
hopefulTransfer BufferOp String
stringBufferOp (forall x. Stream x => x -> IO (Result String)
readLine s
conn) []
Just String
x ->
case forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String
trim String
x) of
String
"chunked" -> forall a.
BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> IO (Result ([Header], a))
chunkedTransfer BufferOp String
stringBufferOp
(forall x. Stream x => x -> IO (Result String)
readLine s
conn) (forall x. Stream x => x -> Int -> IO (Result String)
readBlock s
conn)
String
_ -> forall a. String -> IO (Result ([Header], a))
uglyDeathTransfer String
"sendHTTP"
; case Result ([Header], String)
rslt of
Left ConnError
e -> forall x. Stream x => x -> IO ()
close s
conn forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left ConnError
e)
Right ([Header]
ftrs,String
bdy) -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Header] -> Bool
findConnClose ([Header]
hdrsforall a. [a] -> [a] -> [a]
++[Header]
ftrs))
(forall x. Stream x => x -> Bool -> IO ()
closeOnEnd s
conn Bool
True)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (forall a. ResponseCode -> String -> [Header] -> a -> Response a
Response ResponseCode
cd String
rn ([Header]
hdrsforall a. [a] -> [a] -> [a]
++[Header]
ftrs) String
bdy))
}
receiveHTTP :: Stream s => s -> IO (Result Request_String)
receiveHTTP :: forall s. Stream s => s -> IO (Result Request_String)
receiveHTTP s
conn = IO (Result RequestData)
getRequestHead forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Result RequestData -> IO (Result Request_String)
processRequest
where
getRequestHead :: IO (Result RequestData)
getRequestHead :: IO (Result RequestData)
getRequestHead =
do { Result [String]
lor <- forall a. BufferOp a -> IO (Result a) -> IO (Result [a])
readTillEmpty1 BufferOp String
stringBufferOp (forall x. Stream x => x -> IO (Result String)
readLine s
conn)
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Result [String]
lor 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) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ConnError
e
processRequest (Right (RequestMethod
rm,URI
uri,[Header]
hdrs)) =
do
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 -> forall a.
(Int -> IO (Result a)) -> Int -> IO (Result ([Header], a))
linearTransfer (forall x. Stream x => x -> Int -> IO (Result String)
readBlock s
conn) (forall a. Read a => String -> a
read String
x :: Int)
Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right ([], String
""))
Just String
x ->
case forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String
trim String
x) of
String
"chunked" -> forall a.
BufferOp a
-> IO (Result a)
-> (Int -> IO (Result a))
-> IO (Result ([Header], a))
chunkedTransfer BufferOp String
stringBufferOp
(forall x. Stream x => x -> IO (Result String)
readLine s
conn) (forall x. Stream x => x -> Int -> IO (Result String)
readBlock s
conn)
String
_ -> forall a. String -> IO (Result ([Header], a))
uglyDeathTransfer String
"receiveHTTP"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do
([Header]
ftrs,String
bdy) <- Result ([Header], String)
rslt
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. URI -> RequestMethod -> [Header] -> a -> Request a
Request URI
uri RequestMethod
rm ([Header]
hdrsforall a. [a] -> [a] -> [a]
++[Header]
ftrs) String
bdy)
respondHTTP :: Stream s => s -> Response_String -> IO ()
respondHTTP :: forall s. Stream s => s -> Response_String -> IO ()
respondHTTP s
conn Response_String
rsp = do
Result ()
_ <- forall x. Stream x => x -> String -> IO (Result ())
writeBlock s
conn (forall a. Show a => a -> String
show Response_String
rsp)
Result ()
_ <- forall x. Stream x => x -> String -> IO (Result ())
writeBlock s
conn (forall a. Response a -> a
rspBody Response_String
rsp)
forall (m :: * -> *) a. Monad m => a -> m a
return ()