{-# 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 (ApolloMessageType (..))
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) = Word -> Int
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 (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"/" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (RText 'PathPiece -> Text) -> [RText 'PathPiece] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RText 'PathPiece -> Text
forall (l :: RTextLabel). RText l -> Text
unRText (RText 'PathPiece
h RText 'PathPiece -> [RText 'PathPiece] -> [RText 'PathPiece]
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
(Int -> WebSocketSettings -> ShowS)
-> (WebSocketSettings -> String)
-> ([WebSocketSettings] -> ShowS)
-> Show WebSocketSettings
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WebSocketSettings -> ShowS
showsPrec :: Int -> WebSocketSettings -> ShowS
$cshow :: WebSocketSettings -> String
show :: WebSocketSettings -> String
$cshowList :: [WebSocketSettings] -> ShowS
showList :: [WebSocketSettings] -> ShowS
Show)

parseProtocol :: MonadFail m => Text -> m Bool
parseProtocol :: forall (m :: * -> *). MonadFail m => Text -> m Bool
parseProtocol Text
"ws" = Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
parseProtocol Text
"wss" = Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
parseProtocol Text
p = String -> m Bool
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Bool) -> String -> m Bool
forall a b. (a -> b) -> a -> b
$ String
"unsupported protocol" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
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 :: RText 'Host
authHost :: Authority -> RText 'Host
authHost, Maybe Word
authPort :: Maybe Word
authPort :: Authority -> Maybe Word
authPort}, Maybe (Bool, NonEmpty (RText 'PathPiece))
uriPath :: Maybe (Bool, NonEmpty (RText 'PathPiece))
uriPath :: URI -> Maybe (Bool, NonEmpty (RText 'PathPiece))
uriPath} Headers
headers = do
  Bool
isSecure <- Text -> m Bool
forall (m :: * -> *). MonadFail m => Text -> m Bool
parseProtocol (Text -> m Bool) -> Text -> m Bool
forall a b. (a -> b) -> a -> b
$ RText 'Scheme -> Text
forall (l :: RTextLabel). RText l -> Text
unRText RText 'Scheme
scheme
  WebSocketSettings -> m WebSocketSettings
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    WebSocketSettings
      { Bool
isSecure :: Bool
isSecure :: Bool
isSecure,
        host :: String
host = Text -> String
handleHost (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ RText 'Host -> Text
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
_ = String -> m WebSocketSettings
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Invalid Endpoint: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> URI -> String
forall b a. (Show a, IsString b) => a -> b
show URI
uri String -> ShowS
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) = (String -> a
forall a. IsString a => String -> a
fromString (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
x, String -> ByteString
BS.pack (String -> ByteString) -> String -> ByteString
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 :: WebSocketSettings -> Bool
isSecure :: Bool
isSecure, Int
String
Headers
port :: WebSocketSettings -> Int
host :: WebSocketSettings -> String
path :: WebSocketSettings -> String
headers :: WebSocketSettings -> Headers
port :: Int
host :: String
path :: String
headers :: Headers
..} Connection -> IO a
app
  | Bool
isSecure = String
-> PortNumber
-> String
-> ConnectionOptions
-> Headers
-> (Connection -> IO a)
-> IO a
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 = String
-> Int
-> String
-> ConnectionOptions
-> Headers
-> (Connection -> IO a)
-> IO a
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 = ((Text, Text) -> (CI ByteString, ByteString))
-> [(Text, Text)] -> Headers
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> (CI ByteString, ByteString)
forall a. IsString a => (Text, Text) -> (a, ByteString)
toHeader ([(Text, Text)] -> Headers) -> [(Text, Text)] -> Headers
forall a b. (a -> b) -> a -> b
$ Headers -> [(Text, Text)]
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 <- URI -> Headers -> m WebSocketSettings
forall (m :: * -> *).
MonadFail m =>
URI -> Headers -> m WebSocketSettings
getWebsocketURI URI
uri Headers
headers
  ((forall a. m a -> IO a) -> IO a) -> m a
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO -> WebSocketSettings -> (Connection -> IO a) -> IO a
forall a. WebSocketSettings -> (Connection -> IO a) -> IO a
_useWS WebSocketSettings
wsURI (m a -> IO a
forall a. m a -> IO a
runInIO (m a -> IO a) -> (Connection -> m a) -> Connection -> IO a
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} = JSONResponse a -> Either (FetchError a) a
forall a. JSONResponse a -> Either (FetchError a) a
processResponse JSONResponse a
payload
processMessage ApolloSubscription {} = FetchError a -> Either (FetchError a) a
forall a b. a -> Either a b
Left (String -> FetchError a
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 = ((String -> FetchError a)
-> Either String (ApolloSubscription (JSONResponse a))
-> Either (FetchError a) (ApolloSubscription (JSONResponse a))
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> FetchError a
forall a. String -> FetchError a
FetchErrorParseFailure (Either String (ApolloSubscription (JSONResponse a))
 -> Either (FetchError a) (ApolloSubscription (JSONResponse a)))
-> (ByteString
    -> Either String (ApolloSubscription (JSONResponse a)))
-> ByteString
-> Either (FetchError a) (ApolloSubscription (JSONResponse a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String (ApolloSubscription (JSONResponse a))
forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode) (ByteString
 -> Either (FetchError a) (ApolloSubscription (JSONResponse a)))
-> (ApolloSubscription (JSONResponse a) -> Either (FetchError a) a)
-> ByteString
-> Either (FetchError a) a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> ApolloSubscription (JSONResponse a) -> Either (FetchError a) a
forall a. ApolloSubscription (JSONResponse a) -> GQLClientResult a
processMessage

initialMessage :: ApolloSubscription ()
initialMessage :: ApolloSubscription ()
initialMessage = ApolloSubscription {apolloType :: ApolloMessageType
apolloType = ApolloMessageType
GqlConnectionInit, apolloPayload :: Maybe ()
apolloPayload = Maybe ()
forall a. Maybe a
Nothing, apolloId :: Maybe Text
apolloId = Maybe Text
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 =
  ApolloSubscription GQLRequest -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode
    ApolloSubscription
      { apolloPayload :: Maybe GQLRequest
apolloPayload = GQLRequest -> Maybe GQLRequest
forall a. a -> Maybe a
Just (Request a -> GQLRequest
forall a.
(RequestType a, ToJSON (RequestArgs a)) =>
Request a -> GQLRequest
toRequest Request a
r),
        apolloType :: ApolloMessageType
apolloType = ApolloMessageType
GqlSubscribe,
        apolloId :: Maybe Text
apolloId = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
uid
      }

endMessage :: Text -> ApolloSubscription ()
endMessage :: Text -> ApolloSubscription ()
endMessage Text
uid = ApolloSubscription {apolloType :: ApolloMessageType
apolloType = ApolloMessageType
GqlComplete, apolloPayload :: Maybe ()
apolloPayload = Maybe ()
forall a. Maybe a
Nothing, apolloId :: Maybe Text
apolloId = Text -> Maybe Text
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 = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ApolloSubscription () -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode (ApolloSubscription () -> ByteString)
-> ApolloSubscription () -> ByteString
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 = IO (GQLClientResult a) -> m (GQLClientResult a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (GQLClientResult a) -> m (GQLClientResult a))
-> IO (GQLClientResult a) -> m (GQLClientResult a)
forall a b. (a -> b) -> a -> b
$ do
  ByteString
message <- Connection -> IO ByteString
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
conn
  GQLClientResult a -> IO (GQLClientResult a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GQLClientResult a -> IO (GQLClientResult a))
-> GQLClientResult a -> IO (GQLClientResult a)
forall a b. (a -> b) -> a -> b
$ ByteString -> GQLClientResult a
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 m (GQLClientResult a)
-> [m (GQLClientResult a)] -> [m (GQLClientResult a)]
forall a. a -> [a] -> [a]
: Connection -> [m (GQLClientResult a)]
forall a (m :: * -> *).
(FromJSON a, MonadIO m) =>
Connection -> [m (GQLClientResult a)]
responseStream Connection
conn
  where
    getResponse :: m (GQLClientResult a)
getResponse = Connection -> m (GQLClientResult a)
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 = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn (Text -> Request a -> ByteString
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 = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn (ApolloSubscription () -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode ApolloSubscription ()
initialMessage)