{-# LANGUAGE LambdaCase #-}
module Network.HTTP.Client.WebSockets
( runClient,
runClientWith,
runClientWithRequest,
)
where
import Control.Exception (throwIO)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
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
[Char]
host <- ByteString -> IO [Char]
toStringUtf8 (ByteString -> IO [Char]) -> ByteString -> IO [Char]
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
HTTP.host Request
req
[Char]
path <- ByteString -> IO [Char]
toStringUtf8 (ByteString -> IO [Char]) -> ByteString -> IO [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
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 [Char]
host [Char]
path ConnectionOptions
connOpts (Request -> Headers
HTTP.requestHeaders Request
req) ClientApp a
app
where
toStringUtf8 :: ByteString -> IO [Char]
toStringUtf8 = (Text -> [Char]) -> IO Text -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> [Char]
T.unpack (IO Text -> IO [Char])
-> (ByteString -> IO Text) -> ByteString -> IO [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnicodeException -> IO Text)
-> (Text -> IO Text) -> Either UnicodeException Text -> IO Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either UnicodeException -> IO Text
forall e a. Exception e => e -> IO a
throwIO Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either UnicodeException Text -> IO Text)
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
T.decodeUtf8'