{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Client.Fetch.WebSockets
  ( useWS,
    sendInitialRequest,
    responseStream,
    sendRequest,
    receiveResponse,
    endSession,
  )
where

import Control.Monad.IO.Unlift (MonadUnliftIO (..))
import qualified Data.Aeson as A
import qualified Data.ByteString.Char8 as BS
import Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.Map as M
import Data.Morpheus.Client.Fetch.GQLClient (Headers)
import Data.Morpheus.Client.Fetch.RequestType (Request, RequestType (..), processResponse, toRequest)
import Data.Morpheus.Client.Fetch.Types (FetchError (..), GQLClientResult)
import Data.Morpheus.Client.Schema.JSON.Types (JSONResponse (..))
import Data.Morpheus.Subscriptions.Internal (ApolloSubscription (..))
import qualified Data.Text as T
import Network.WebSockets.Client (runClientWith)
import Network.WebSockets.Connection (Connection, defaultConnectionOptions, receiveData, sendTextData)
import Relude hiding (ByteString)
import Text.URI
  ( Authority (..),
    RText,
    RTextLabel (..),
    URI (..),
    unRText,
  )
import Wuss (runSecureClientWith)

handleHost :: Text -> String
handleHost :: Text -> String
handleHost Text
"localhost" = String
"127.0.0.1"
handleHost Text
x = Text -> String
T.unpack Text
x

toPort :: Maybe Word -> Int
toPort :: Maybe Word -> Int
toPort Maybe Word
Nothing = Int
80
toPort (Just Word
x) = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
x

getPath :: Maybe (Bool, NonEmpty (RText 'PathPiece)) -> String
getPath :: Maybe (Bool, NonEmpty (RText 'PathPiece)) -> String
getPath (Just (Bool
_, RText 'PathPiece
h :| [RText 'PathPiece]
t)) = Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"/" forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (l :: RTextLabel). RText l -> Text
unRText (RText 'PathPiece
h forall a. a -> [a] -> [a]
: [RText 'PathPiece]
t)
getPath Maybe (Bool, NonEmpty (RText 'PathPiece))
_ = String
""

data WebSocketSettings = WebSocketSettings
  { WebSocketSettings -> Bool
isSecure :: Bool,
    WebSocketSettings -> Int
port :: Int,
    WebSocketSettings -> String
host :: String,
    WebSocketSettings -> String
path :: String,
    WebSocketSettings -> Headers
headers :: Headers
  }
  deriving (Int -> WebSocketSettings -> ShowS
[WebSocketSettings] -> ShowS
WebSocketSettings -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WebSocketSettings] -> ShowS
$cshowList :: [WebSocketSettings] -> ShowS
show :: WebSocketSettings -> String
$cshow :: WebSocketSettings -> String
showsPrec :: Int -> WebSocketSettings -> ShowS
$cshowsPrec :: Int -> WebSocketSettings -> ShowS
Show)

parseProtocol :: MonadFail m => Text -> m Bool
parseProtocol :: forall (m :: * -> *). MonadFail m => Text -> m Bool
parseProtocol Text
"ws" = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
parseProtocol Text
"wss" = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
parseProtocol Text
p = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"unsupported protocol" forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Text
p

getWebsocketURI :: MonadFail m => URI -> Headers -> m WebSocketSettings
getWebsocketURI :: forall (m :: * -> *).
MonadFail m =>
URI -> Headers -> m WebSocketSettings
getWebsocketURI URI {uriScheme :: URI -> Maybe (RText 'Scheme)
uriScheme = Just RText 'Scheme
scheme, uriAuthority :: URI -> Either Bool Authority
uriAuthority = Right Authority {RText 'Host
authHost :: Authority -> RText 'Host
authHost :: RText 'Host
authHost, Maybe Word
authPort :: Authority -> Maybe Word
authPort :: Maybe Word
authPort}, Maybe (Bool, NonEmpty (RText 'PathPiece))
uriPath :: URI -> Maybe (Bool, NonEmpty (RText 'PathPiece))
uriPath :: Maybe (Bool, NonEmpty (RText 'PathPiece))
uriPath} Headers
headers = do
  Bool
isSecure <- forall (m :: * -> *). MonadFail m => Text -> m Bool
parseProtocol forall a b. (a -> b) -> a -> b
$ forall (l :: RTextLabel). RText l -> Text
unRText RText 'Scheme
scheme
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    WebSocketSettings
      { Bool
isSecure :: Bool
isSecure :: Bool
isSecure,
        host :: String
host = Text -> String
handleHost forall a b. (a -> b) -> a -> b
$ forall (l :: RTextLabel). RText l -> Text
unRText RText 'Host
authHost,
        port :: Int
port = Maybe Word -> Int
toPort Maybe Word
authPort,
        path :: String
path = Maybe (Bool, NonEmpty (RText 'PathPiece)) -> String
getPath Maybe (Bool, NonEmpty (RText 'PathPiece))
uriPath,
        Headers
headers :: Headers
headers :: Headers
headers
      }
getWebsocketURI URI
uri Headers
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Invalid Endpoint: " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show URI
uri forall a. Semigroup a => a -> a -> a
<> String
"!")

toHeader :: IsString a => (Text, Text) -> (a, BS.ByteString)
toHeader :: forall a. IsString a => (Text, Text) -> (a, ByteString)
toHeader (Text
x, Text
y) = (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
x, String -> ByteString
BS.pack forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
y)

_useWS :: WebSocketSettings -> (Connection -> IO a) -> IO a
_useWS :: forall a. WebSocketSettings -> (Connection -> IO a) -> IO a
_useWS WebSocketSettings {Bool
isSecure :: Bool
isSecure :: WebSocketSettings -> Bool
isSecure, Int
String
Headers
headers :: Headers
path :: String
host :: String
port :: Int
headers :: WebSocketSettings -> Headers
path :: WebSocketSettings -> String
host :: WebSocketSettings -> String
port :: WebSocketSettings -> Int
..} Connection -> IO a
app
  | Bool
isSecure = forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String
-> PortNumber
-> String
-> ConnectionOptions
-> Headers
-> ClientApp a
-> m a
runSecureClientWith String
host PortNumber
443 String
path ConnectionOptions
options Headers
wsHeaders Connection -> IO a
app
  | Bool
otherwise = forall a.
String
-> Int
-> String
-> ConnectionOptions
-> Headers
-> ClientApp a
-> IO a
runClientWith String
host Int
port String
path ConnectionOptions
options Headers
wsHeaders Connection -> IO a
app
  where
    wsHeaders :: Headers
wsHeaders = forall a b. (a -> b) -> [a] -> [b]
map forall a. IsString a => (Text, Text) -> (a, ByteString)
toHeader forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList Headers
headers
    options :: ConnectionOptions
options = ConnectionOptions
defaultConnectionOptions

useWS :: (MonadFail m, MonadIO m, MonadUnliftIO m) => URI -> Headers -> (Connection -> m a) -> m a
useWS :: forall (m :: * -> *) a.
(MonadFail m, MonadIO m, MonadUnliftIO m) =>
URI -> Headers -> (Connection -> m a) -> m a
useWS URI
uri Headers
headers Connection -> m a
app = do
  WebSocketSettings
wsURI <- forall (m :: * -> *).
MonadFail m =>
URI -> Headers -> m WebSocketSettings
getWebsocketURI URI
uri Headers
headers
  forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO -> forall a. WebSocketSettings -> (Connection -> IO a) -> IO a
_useWS WebSocketSettings
wsURI (forall a. m a -> IO a
runInIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> m a
app)

processMessage :: ApolloSubscription (JSONResponse a) -> GQLClientResult a
processMessage :: forall a. ApolloSubscription (JSONResponse a) -> GQLClientResult a
processMessage ApolloSubscription {apolloPayload :: forall payload. ApolloSubscription payload -> Maybe payload
apolloPayload = Just JSONResponse a
payload} = forall a. JSONResponse a -> Either (FetchError a) a
processResponse JSONResponse a
payload
processMessage ApolloSubscription {} = forall a b. a -> Either a b
Left (forall a. String -> FetchError a
FetchErrorParseFailure String
"empty message")

decodeMessage :: A.FromJSON a => ByteString -> GQLClientResult a
decodeMessage :: forall a. FromJSON a => ByteString -> GQLClientResult a
decodeMessage = (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. String -> FetchError a
FetchErrorParseFailure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode) forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall a. ApolloSubscription (JSONResponse a) -> GQLClientResult a
processMessage

initialMessage :: ApolloSubscription ()
initialMessage :: ApolloSubscription ()
initialMessage = ApolloSubscription {apolloType :: Text
apolloType = Text
"connection_init", apolloPayload :: Maybe ()
apolloPayload = forall a. Maybe a
Nothing, apolloId :: Maybe Text
apolloId = forall a. Maybe a
Nothing}

encodeRequestMessage :: (RequestType a, A.ToJSON (RequestArgs a)) => Text -> Request a -> ByteString
encodeRequestMessage :: forall a.
(RequestType a, ToJSON (RequestArgs a)) =>
Text -> Request a -> ByteString
encodeRequestMessage Text
uid Request a
r =
  forall a. ToJSON a => a -> ByteString
A.encode
    ApolloSubscription
      { apolloPayload :: Maybe GQLRequest
apolloPayload = forall a. a -> Maybe a
Just (forall a.
(RequestType a, ToJSON (RequestArgs a)) =>
Request a -> GQLRequest
toRequest Request a
r),
        apolloType :: Text
apolloType = Text
"start",
        apolloId :: Maybe Text
apolloId = forall a. a -> Maybe a
Just Text
uid
      }

endMessage :: Text -> ApolloSubscription ()
endMessage :: Text -> ApolloSubscription ()
endMessage Text
uid = ApolloSubscription {apolloType :: Text
apolloType = Text
"stop", apolloPayload :: Maybe ()
apolloPayload = forall a. Maybe a
Nothing, apolloId :: Maybe Text
apolloId = forall a. a -> Maybe a
Just Text
uid}

endSession :: MonadIO m => Connection -> Text -> m ()
endSession :: forall (m :: * -> *). MonadIO m => Connection -> Text -> m ()
endSession Connection
conn Text
uid = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
A.encode forall a b. (a -> b) -> a -> b
$ Text -> ApolloSubscription ()
endMessage Text
uid

receiveResponse :: MonadIO m => A.FromJSON a => Connection -> m (GQLClientResult a)
receiveResponse :: forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Connection -> m (GQLClientResult a)
receiveResponse Connection
conn = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  ByteString
message <- forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
conn
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => ByteString -> GQLClientResult a
decodeMessage ByteString
message

-- returns infinite number of responses
responseStream :: (A.FromJSON a, MonadIO m) => Connection -> [m (GQLClientResult a)]
responseStream :: forall a (m :: * -> *).
(FromJSON a, MonadIO m) =>
Connection -> [m (GQLClientResult a)]
responseStream Connection
conn = m (GQLClientResult a)
getResponse forall a. a -> [a] -> [a]
: forall a (m :: * -> *).
(FromJSON a, MonadIO m) =>
Connection -> [m (GQLClientResult a)]
responseStream Connection
conn
  where
    getResponse :: m (GQLClientResult a)
getResponse = forall (m :: * -> *) a.
(MonadIO m, FromJSON a) =>
Connection -> m (GQLClientResult a)
receiveResponse Connection
conn

sendRequest :: (RequestType a, A.ToJSON (RequestArgs a), MonadIO m) => Connection -> Text -> Request a -> m ()
sendRequest :: forall a (m :: * -> *).
(RequestType a, ToJSON (RequestArgs a), MonadIO m) =>
Connection -> Text -> Request a -> m ()
sendRequest Connection
conn Text
uid Request a
r = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn (forall a.
(RequestType a, ToJSON (RequestArgs a)) =>
Text -> Request a -> ByteString
encodeRequestMessage Text
uid Request a
r)

sendInitialRequest :: MonadIO m => Connection -> m ()
sendInitialRequest :: forall (m :: * -> *). MonadIO m => Connection -> m ()
sendInitialRequest Connection
conn = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn (forall a. ToJSON a => a -> ByteString
A.encode ApolloSubscription ()
initialMessage)