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
auth <- Request_String -> IO URIAuthority
forall (m :: * -> *) ty.
MonadFail m =>
Request ty -> m URIAuthority
getAuth Request_String
r
c <- openTCPPort (host auth) (fromMaybe 80 (port auth))
simpleHTTP_ c 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 = 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
s' <- String -> s -> IO (StreamDebugger s)
forall a. Stream a => String -> a -> IO (StreamDebugger a)
debugStream String
httpLogFile s
s
sendHTTP s' 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 = 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 a. a -> IO a
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
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)
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
_ <- 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)
_ <- writeBlock conn (rqBody rqst)
onSendComplete
rsp <- getResponseHead conn
switchResponse conn True False rsp rqst
getResponseHead :: Stream s => s -> IO (Result ResponseData)
getResponseHead :: forall s. Stream s => s -> IO (Result ResponseData)
getResponseHead s
conn = do
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)
return $ lor >>= 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
_ = Result Response_String -> IO (Result Response_String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ConnError -> Result Response_String
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 (Request_String -> RequestMethod
forall a. Request a -> RequestMethod
rqMethod Request_String
rqst) ResponseCode
cd of
ResponseNextStep
Continue
| Bool -> Bool
not Bool
bdy_sent ->
do { 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 val of
Left ConnError
e -> Result Response_String -> IO (Result Response_String)
forall a. a -> IO a
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 { rsp <- s -> IO (Result ResponseData)
forall s. Stream s => s -> IO (Result ResponseData)
getResponseHead s
conn
; switchResponse conn allow_retry True rsp rqst
}
}
| Bool
otherwise ->
do { rsp <- s -> IO (Result ResponseData)
forall s. Stream s => s -> IO (Result ResponseData)
getResponseHead s
conn
; switchResponse conn allow_retry bdy_sent rsp rqst
}
ResponseNextStep
Retry ->
do {
_ <- 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)
; rsp <- getResponseHead conn
; switchResponse conn False bdy_sent rsp 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 a. a -> IO a
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 a. a -> IO a
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 { 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 (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 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 a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Result Response_String -> IO (Result Response_String)
forall a. a -> IO a
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 a. a -> IO a
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))
}
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 IO (Result RequestData)
-> (Result RequestData -> IO (Result Request_String))
-> IO (Result Request_String)
forall a b. IO a -> (a -> IO b) -> IO b
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 { 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)
; return $ lor >>= parseRequestHead
}
processRequest :: Result RequestData -> IO (Result Request_String)
processRequest (Left ConnError
e) = Result Request_String -> IO (Result Request_String)
forall a. a -> IO a
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
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
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (([Header], String) -> Result ([Header], String)
forall a b. b -> Either a b
Right ([], String
""))
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"
return $ do
(ftrs,bdy) <- rslt
return (Request uri rm (hdrs++ftrs) bdy)
respondHTTP :: Stream s => s -> Response_String -> IO ()
respondHTTP :: forall s. Stream s => s -> Response_String -> IO ()
respondHTTP s
conn Response_String
rsp = do
_ <- 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)
_ <- writeBlock conn (rspBody rsp)
return ()