{-# LANGUAGE LambdaCase #-}
module Network.HTTP.Client.WebSockets
( runClient,
runClientWith,
runClientWithRequest,
)
where
import qualified Codec.Binary.UTF8.Generic as UTF8
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Client.Internal as HTTP
import Network.URI (URI (..))
import qualified Network.WebSockets as WS
import qualified Network.WebSockets.Stream as WS
runClient ::
HTTP.Manager ->
URI ->
WS.ClientApp a ->
IO a
runClient :: Manager -> URI -> ClientApp a -> IO a
runClient Manager
mgr URI
uri = Manager
-> URI -> ConnectionOptions -> Headers -> ClientApp a -> IO a
forall a.
Manager
-> URI -> ConnectionOptions -> Headers -> ClientApp a -> IO a
runClientWith Manager
mgr URI
uri ConnectionOptions
WS.defaultConnectionOptions []
runClientWith ::
HTTP.Manager ->
URI ->
WS.ConnectionOptions ->
WS.Headers ->
WS.ClientApp a ->
IO a
runClientWith :: Manager
-> URI -> ConnectionOptions -> Headers -> ClientApp a -> IO a
runClientWith Manager
mgr URI
uri ConnectionOptions
connOpts Headers
headers ClientApp a
app = do
[Char]
httpScheme <- case URI -> [Char]
uriScheme URI
uri of
[Char]
"ws:" -> [Char] -> IO [Char]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"http:"
[Char]
"wss:" -> [Char] -> IO [Char]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"https:"
[Char]
s -> [Char] -> IO [Char]
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"invalid WebSockets scheme: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
s
Request
req <- URI -> IO Request
forall (m :: * -> *). MonadThrow m => URI -> m Request
HTTP.requestFromURI URI
uri {uriScheme :: [Char]
uriScheme = [Char]
httpScheme}
Manager -> Request -> ConnectionOptions -> ClientApp a -> IO a
forall a.
Manager -> Request -> ConnectionOptions -> ClientApp a -> IO a
runClientWithRequest Manager
mgr (Request
req {requestHeaders :: Headers
HTTP.requestHeaders = Headers
headers}) ConnectionOptions
connOpts ClientApp a
app
runClientWithRequest ::
HTTP.Manager ->
HTTP.Request ->
WS.ConnectionOptions ->
WS.ClientApp a ->
IO a
runClientWithRequest :: Manager -> Request -> ConnectionOptions -> ClientApp a -> IO a
runClientWithRequest Manager
mgr Request
req ConnectionOptions
connOpts ClientApp a
app = do
Request -> Manager -> (Connection -> IO a) -> IO a
forall a. Request -> Manager -> (Connection -> IO a) -> IO a
HTTP.withConnection Request
req Manager
mgr ((Connection -> IO a) -> IO a) -> (Connection -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
let read :: IO (Maybe ByteString)
read = do
ByteString
bs <- Connection -> IO ByteString
HTTP.connectionRead Connection
conn
Maybe ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ if ByteString -> Bool
B.null ByteString
bs then Maybe ByteString
forall a. Maybe a
Nothing else ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bs
write :: Maybe ByteString -> IO ()
write = \case
Maybe ByteString
Nothing -> Connection -> IO ()
HTTP.connectionClose Connection
conn
Just ByteString
bs -> Connection -> ByteString -> IO ()
HTTP.connectionWrite Connection
conn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LB.toStrict ByteString
bs
Stream
stream <- IO (Maybe ByteString) -> (Maybe ByteString -> IO ()) -> IO Stream
WS.makeStream IO (Maybe ByteString)
read Maybe ByteString -> IO ()
write
Stream
-> [Char]
-> [Char]
-> ConnectionOptions
-> Headers
-> ClientApp a
-> IO a
forall a.
Stream
-> [Char]
-> [Char]
-> ConnectionOptions
-> Headers
-> ClientApp a
-> IO a
WS.runClientWithStream
Stream
stream
(ByteString -> [Char]
forall b s. UTF8Bytes b s => b -> [Char]
UTF8.toString (ByteString -> [Char]) -> ByteString -> [Char]
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
HTTP.host Request
req)
(ByteString -> [Char]
forall b s. UTF8Bytes b s => b -> [Char]
UTF8.toString (ByteString -> [Char]) -> ByteString -> [Char]
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
HTTP.path Request
req ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Request -> ByteString
HTTP.queryString Request
req)
ConnectionOptions
connOpts
(Request -> Headers
HTTP.requestHeaders Request
req)
ClientApp a
app