{-# LANGUAGE LambdaCase #-}

-- | Glue code for [http-client](https://hackage.haskell.org/package/http-client)
--   and [websockets](https://hackage.haskell.org/package/websockets).
--
--   This module is intended to be imported @qualified@.
--
--   If you want to use TLS-secured WebSockets (via the @wss@ scheme)
--   you need to supply a 'Manager' which supports TLS, for example
--   from [http-client-tls](https://hackage.haskell.org/package/http-client-tls)
--   or [http-client-openssl](https://hackage.haskell.org/package/http-client-openssl).
--
--   == Example
--   >>> :set -XOverloadedStrings
--   >>> :set -XQuasiQuotes
--   >>>
--   >>> import Network.HTTP.Client (Manager, defaultManagerSettings, newManager)
--   >>> import qualified Network.WebSockets as WS
--   >>> import qualified Network.HTTP.Client.WebSockets as HCWS
--   >>> import Network.URI.Static
--   >>> import Data.ByteString (ByteString)
--   >>>
--   >>> :{
--       runEchoExample :: Manager -> IO ByteString
--       runEchoExample mgr = HCWS.runClient mgr echoUri $ \conn -> do
--           WS.sendTextData conn ("hello there" :: ByteString)
--           _ <- WS.receiveDataMessage conn -- skip first msg
--           msg <- WS.receiveData conn
--           pure (msg :: ByteString)
--         where
--           echoUri = [uri|ws://echo.websocket.events|] -- no TLS in this example
--   :}
--
--   >>> runEchoExample =<< newManager defaultManagerSettings
--   "hello there"
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' to use to establish the connection
  HTTP.Manager ->
  -- | 'URI' to connect to. Only the schemes @ws@ and @wss@ are valid.
  URI ->
  -- | Client application
  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' to use to establish the connection
  HTTP.Manager ->
  -- | 'URI' to connect to. Only the schemes @ws@ and @wss@ are valid.
  URI ->
  -- | Options
  WS.ConnectionOptions ->
  -- | Custom headers to send
  WS.Headers ->
  -- | Client application
  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' to use to establish the connection
  HTTP.Manager ->
  -- | 'HTTP.Request' to use to open the connection, content will be ignored.
  HTTP.Request ->
  -- | Options
  WS.ConnectionOptions ->
  -- | Client application
  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'