-- | This file contains types for both the websocket protocols (Apollo) and (graphql-ws)
-- | See Apollo: https://github.com/apollographql/subscriptions-transport-ws/blob/master/PROTOCOL.md
-- | See graphql-ws: https://github.com/enisdenjo/graphql-ws/blob/master/PROTOCOL.md
module Hasura.GraphQL.Transport.WebSocket.Protocol
  ( ClientMsg (CMConnInit, CMConnTerm, CMPing, CMPong, CMStart, CMStop),
    CompletionMsg (CompletionMsg),
    ConnErrMsg (ConnErrMsg, unConnErrMsg),
    ConnParams (_cpHeaders),
    DataMsg (DataMsg),
    ErrorMsg (ErrorMsg),
    OperationId (unOperationId),
    PingPongPayload,
    ServerErrorCode (..),
    ServerMsg (SMComplete, SMConnAck, SMConnErr, SMConnKeepAlive, SMData, SMErr, SMNext, SMPing, SMPong),
    ServerMsgType (..),
    StartMsg (StartMsg),
    StopMsg (StopMsg),
    WSConnInitTimerStatus (Done),
    WSSubProtocol (..),
    encodeServerErrorMsg,
    encodeServerMsg,
    getNewWSTimer,
    getWSTimerState,
    keepAliveMessage,
    showSubProtocol,
    toWSSubProtocol,

    -- * exported for testing
    unsafeMkOperationId,
  )
where

import Control.Concurrent
import Control.Concurrent.Extended (sleep)
import Control.Concurrent.STM
import Data.Aeson qualified as J
import Data.ByteString.Lazy qualified as BL
import Data.Text (pack)
import Hasura.EncJSON
import Hasura.GraphQL.Transport.HTTP.Protocol
import Hasura.Prelude

-- NOTE: the `subProtocol` is decided based on the `Sec-WebSocket-Protocol`
-- header on every request sent to the server.
data WSSubProtocol = Apollo | GraphQLWS
  deriving (WSSubProtocol -> WSSubProtocol -> Bool
(WSSubProtocol -> WSSubProtocol -> Bool)
-> (WSSubProtocol -> WSSubProtocol -> Bool) -> Eq WSSubProtocol
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WSSubProtocol -> WSSubProtocol -> Bool
== :: WSSubProtocol -> WSSubProtocol -> Bool
$c/= :: WSSubProtocol -> WSSubProtocol -> Bool
/= :: WSSubProtocol -> WSSubProtocol -> Bool
Eq, Int -> WSSubProtocol -> ShowS
[WSSubProtocol] -> ShowS
WSSubProtocol -> String
(Int -> WSSubProtocol -> ShowS)
-> (WSSubProtocol -> String)
-> ([WSSubProtocol] -> ShowS)
-> Show WSSubProtocol
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WSSubProtocol -> ShowS
showsPrec :: Int -> WSSubProtocol -> ShowS
$cshow :: WSSubProtocol -> String
show :: WSSubProtocol -> String
$cshowList :: [WSSubProtocol] -> ShowS
showList :: [WSSubProtocol] -> ShowS
Show)

-- NOTE: Please do not change them, as they're used for to identify the type of client
-- on every request that reaches the server. They are unique to each of the protocols.
showSubProtocol :: WSSubProtocol -> String
showSubProtocol :: WSSubProtocol -> String
showSubProtocol WSSubProtocol
subProtocol = case WSSubProtocol
subProtocol of
  -- REF: https://github.com/apollographql/subscriptions-transport-ws/blob/master/src/server.ts#L144
  WSSubProtocol
Apollo -> String
"graphql-ws"
  -- REF: https://github.com/enisdenjo/graphql-ws/blob/master/PROTOCOL.md#communication
  WSSubProtocol
GraphQLWS -> String
"graphql-transport-ws"

toWSSubProtocol :: String -> WSSubProtocol
toWSSubProtocol :: String -> WSSubProtocol
toWSSubProtocol String
str = case String
str of
  String
"graphql-transport-ws" -> WSSubProtocol
GraphQLWS
  String
_ -> WSSubProtocol
Apollo

-- This is set by the client when it connects to the server
newtype OperationId = OperationId {OperationId -> Text
unOperationId :: Text}
  deriving (Int -> OperationId -> ShowS
[OperationId] -> ShowS
OperationId -> String
(Int -> OperationId -> ShowS)
-> (OperationId -> String)
-> ([OperationId] -> ShowS)
-> Show OperationId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OperationId -> ShowS
showsPrec :: Int -> OperationId -> ShowS
$cshow :: OperationId -> String
show :: OperationId -> String
$cshowList :: [OperationId] -> ShowS
showList :: [OperationId] -> ShowS
Show, OperationId -> OperationId -> Bool
(OperationId -> OperationId -> Bool)
-> (OperationId -> OperationId -> Bool) -> Eq OperationId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OperationId -> OperationId -> Bool
== :: OperationId -> OperationId -> Bool
$c/= :: OperationId -> OperationId -> Bool
/= :: OperationId -> OperationId -> Bool
Eq, [OperationId] -> Value
[OperationId] -> Encoding
OperationId -> Value
OperationId -> Encoding
(OperationId -> Value)
-> (OperationId -> Encoding)
-> ([OperationId] -> Value)
-> ([OperationId] -> Encoding)
-> ToJSON OperationId
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: OperationId -> Value
toJSON :: OperationId -> Value
$ctoEncoding :: OperationId -> Encoding
toEncoding :: OperationId -> Encoding
$ctoJSONList :: [OperationId] -> Value
toJSONList :: [OperationId] -> Value
$ctoEncodingList :: [OperationId] -> Encoding
toEncodingList :: [OperationId] -> Encoding
J.ToJSON, Value -> Parser [OperationId]
Value -> Parser OperationId
(Value -> Parser OperationId)
-> (Value -> Parser [OperationId]) -> FromJSON OperationId
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
$cparseJSON :: Value -> Parser OperationId
parseJSON :: Value -> Parser OperationId
$cparseJSONList :: Value -> Parser [OperationId]
parseJSONList :: Value -> Parser [OperationId]
J.FromJSON, String -> OperationId
(String -> OperationId) -> IsString OperationId
forall a. (String -> a) -> IsString a
$cfromString :: String -> OperationId
fromString :: String -> OperationId
IsString, Eq OperationId
Eq OperationId
-> (Int -> OperationId -> Int)
-> (OperationId -> Int)
-> Hashable OperationId
Int -> OperationId -> Int
OperationId -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> OperationId -> Int
hashWithSalt :: Int -> OperationId -> Int
$chash :: OperationId -> Int
hash :: OperationId -> Int
Hashable)

unsafeMkOperationId :: Text -> OperationId
unsafeMkOperationId :: Text -> OperationId
unsafeMkOperationId = Text -> OperationId
OperationId

data ServerMsgType
  = -- specific to `Apollo` clients
    SMT_GQL_CONNECTION_KEEP_ALIVE
  | SMT_GQL_CONNECTION_ERROR
  | SMT_GQL_DATA
  | -- specific to `graphql-ws` clients
    SMT_GQL_NEXT
  | SMT_GQL_PING
  | SMT_GQL_PONG
  | -- common to clients of both protocols
    SMT_GQL_CONNECTION_ACK
  | SMT_GQL_ERROR
  | SMT_GQL_COMPLETE
  deriving (ServerMsgType -> ServerMsgType -> Bool
(ServerMsgType -> ServerMsgType -> Bool)
-> (ServerMsgType -> ServerMsgType -> Bool) -> Eq ServerMsgType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ServerMsgType -> ServerMsgType -> Bool
== :: ServerMsgType -> ServerMsgType -> Bool
$c/= :: ServerMsgType -> ServerMsgType -> Bool
/= :: ServerMsgType -> ServerMsgType -> Bool
Eq)

instance Show ServerMsgType where
  show :: ServerMsgType -> String
show = \case
    -- specific to `Apollo` clients
    ServerMsgType
SMT_GQL_CONNECTION_KEEP_ALIVE -> String
"ka"
    ServerMsgType
SMT_GQL_CONNECTION_ERROR -> String
"connection_error"
    ServerMsgType
SMT_GQL_DATA -> String
"data"
    -- specific to `graphql-ws` clients
    ServerMsgType
SMT_GQL_NEXT -> String
"next"
    ServerMsgType
SMT_GQL_PING -> String
"ping"
    ServerMsgType
SMT_GQL_PONG -> String
"pong"
    -- common to clients of both protocols
    ServerMsgType
SMT_GQL_CONNECTION_ACK -> String
"connection_ack"
    ServerMsgType
SMT_GQL_ERROR -> String
"error"
    ServerMsgType
SMT_GQL_COMPLETE -> String
"complete"

instance J.ToJSON ServerMsgType where
  toJSON :: ServerMsgType -> Value
toJSON = String -> Value
forall a. ToJSON a => a -> Value
J.toJSON (String -> Value)
-> (ServerMsgType -> String) -> ServerMsgType -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerMsgType -> String
forall a. Show a => a -> String
show

data ConnParams = ConnParams
  {ConnParams -> Maybe (HashMap Text Text)
_cpHeaders :: Maybe (HashMap Text Text)}
  deriving stock (Int -> ConnParams -> ShowS
[ConnParams] -> ShowS
ConnParams -> String
(Int -> ConnParams -> ShowS)
-> (ConnParams -> String)
-> ([ConnParams] -> ShowS)
-> Show ConnParams
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConnParams -> ShowS
showsPrec :: Int -> ConnParams -> ShowS
$cshow :: ConnParams -> String
show :: ConnParams -> String
$cshowList :: [ConnParams] -> ShowS
showList :: [ConnParams] -> ShowS
Show, ConnParams -> ConnParams -> Bool
(ConnParams -> ConnParams -> Bool)
-> (ConnParams -> ConnParams -> Bool) -> Eq ConnParams
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConnParams -> ConnParams -> Bool
== :: ConnParams -> ConnParams -> Bool
$c/= :: ConnParams -> ConnParams -> Bool
/= :: ConnParams -> ConnParams -> Bool
Eq, (forall x. ConnParams -> Rep ConnParams x)
-> (forall x. Rep ConnParams x -> ConnParams) -> Generic ConnParams
forall x. Rep ConnParams x -> ConnParams
forall x. ConnParams -> Rep ConnParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ConnParams -> Rep ConnParams x
from :: forall x. ConnParams -> Rep ConnParams x
$cto :: forall x. Rep ConnParams x -> ConnParams
to :: forall x. Rep ConnParams x -> ConnParams
Generic)

instance J.FromJSON ConnParams where
  parseJSON :: Value -> Parser ConnParams
parseJSON = Options -> Value -> Parser ConnParams
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
J.genericParseJSON Options
hasuraJSON

instance J.ToJSON ConnParams where
  toJSON :: ConnParams -> Value
toJSON = Options -> ConnParams -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
J.genericToJSON Options
hasuraJSON
  toEncoding :: ConnParams -> Encoding
toEncoding = Options -> ConnParams -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
J.genericToEncoding Options
hasuraJSON

data StartMsg = StartMsg
  { StartMsg -> OperationId
_smId :: !OperationId,
    StartMsg -> GQLReqUnparsed
_smPayload :: !GQLReqUnparsed
  }
  deriving (Int -> StartMsg -> ShowS
[StartMsg] -> ShowS
StartMsg -> String
(Int -> StartMsg -> ShowS)
-> (StartMsg -> String) -> ([StartMsg] -> ShowS) -> Show StartMsg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StartMsg -> ShowS
showsPrec :: Int -> StartMsg -> ShowS
$cshow :: StartMsg -> String
show :: StartMsg -> String
$cshowList :: [StartMsg] -> ShowS
showList :: [StartMsg] -> ShowS
Show, StartMsg -> StartMsg -> Bool
(StartMsg -> StartMsg -> Bool)
-> (StartMsg -> StartMsg -> Bool) -> Eq StartMsg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StartMsg -> StartMsg -> Bool
== :: StartMsg -> StartMsg -> Bool
$c/= :: StartMsg -> StartMsg -> Bool
/= :: StartMsg -> StartMsg -> Bool
Eq, (forall x. StartMsg -> Rep StartMsg x)
-> (forall x. Rep StartMsg x -> StartMsg) -> Generic StartMsg
forall x. Rep StartMsg x -> StartMsg
forall x. StartMsg -> Rep StartMsg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. StartMsg -> Rep StartMsg x
from :: forall x. StartMsg -> Rep StartMsg x
$cto :: forall x. Rep StartMsg x -> StartMsg
to :: forall x. Rep StartMsg x -> StartMsg
Generic)

instance J.FromJSON StartMsg where
  parseJSON :: Value -> Parser StartMsg
parseJSON = Options -> Value -> Parser StartMsg
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
J.genericParseJSON Options
hasuraJSON

instance J.ToJSON StartMsg where
  toJSON :: StartMsg -> Value
toJSON = Options -> StartMsg -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
J.genericToJSON Options
hasuraJSON
  toEncoding :: StartMsg -> Encoding
toEncoding = Options -> StartMsg -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
J.genericToEncoding Options
hasuraJSON

data StopMsg = StopMsg
  { StopMsg -> OperationId
_stId :: OperationId
  }
  deriving (Int -> StopMsg -> ShowS
[StopMsg] -> ShowS
StopMsg -> String
(Int -> StopMsg -> ShowS)
-> (StopMsg -> String) -> ([StopMsg] -> ShowS) -> Show StopMsg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StopMsg -> ShowS
showsPrec :: Int -> StopMsg -> ShowS
$cshow :: StopMsg -> String
show :: StopMsg -> String
$cshowList :: [StopMsg] -> ShowS
showList :: [StopMsg] -> ShowS
Show, StopMsg -> StopMsg -> Bool
(StopMsg -> StopMsg -> Bool)
-> (StopMsg -> StopMsg -> Bool) -> Eq StopMsg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StopMsg -> StopMsg -> Bool
== :: StopMsg -> StopMsg -> Bool
$c/= :: StopMsg -> StopMsg -> Bool
/= :: StopMsg -> StopMsg -> Bool
Eq, (forall x. StopMsg -> Rep StopMsg x)
-> (forall x. Rep StopMsg x -> StopMsg) -> Generic StopMsg
forall x. Rep StopMsg x -> StopMsg
forall x. StopMsg -> Rep StopMsg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. StopMsg -> Rep StopMsg x
from :: forall x. StopMsg -> Rep StopMsg x
$cto :: forall x. Rep StopMsg x -> StopMsg
to :: forall x. Rep StopMsg x -> StopMsg
Generic)

instance J.FromJSON StopMsg where
  parseJSON :: Value -> Parser StopMsg
parseJSON = Options -> Value -> Parser StopMsg
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
J.genericParseJSON Options
hasuraJSON

instance J.ToJSON StopMsg where
  toJSON :: StopMsg -> Value
toJSON = Options -> StopMsg -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
J.genericToJSON Options
hasuraJSON
  toEncoding :: StopMsg -> Encoding
toEncoding = Options -> StopMsg -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
J.genericToEncoding Options
hasuraJSON

-- Specific to graphql-ws
data PingPongPayload = PingPongPayload
  { PingPongPayload -> Maybe Text
_smMessage :: !(Maybe Text) -- NOTE: this is not within the spec, but is specific to our usecase
  }
  deriving stock (Int -> PingPongPayload -> ShowS
[PingPongPayload] -> ShowS
PingPongPayload -> String
(Int -> PingPongPayload -> ShowS)
-> (PingPongPayload -> String)
-> ([PingPongPayload] -> ShowS)
-> Show PingPongPayload
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PingPongPayload -> ShowS
showsPrec :: Int -> PingPongPayload -> ShowS
$cshow :: PingPongPayload -> String
show :: PingPongPayload -> String
$cshowList :: [PingPongPayload] -> ShowS
showList :: [PingPongPayload] -> ShowS
Show, PingPongPayload -> PingPongPayload -> Bool
(PingPongPayload -> PingPongPayload -> Bool)
-> (PingPongPayload -> PingPongPayload -> Bool)
-> Eq PingPongPayload
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PingPongPayload -> PingPongPayload -> Bool
== :: PingPongPayload -> PingPongPayload -> Bool
$c/= :: PingPongPayload -> PingPongPayload -> Bool
/= :: PingPongPayload -> PingPongPayload -> Bool
Eq, (forall x. PingPongPayload -> Rep PingPongPayload x)
-> (forall x. Rep PingPongPayload x -> PingPongPayload)
-> Generic PingPongPayload
forall x. Rep PingPongPayload x -> PingPongPayload
forall x. PingPongPayload -> Rep PingPongPayload x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PingPongPayload -> Rep PingPongPayload x
from :: forall x. PingPongPayload -> Rep PingPongPayload x
$cto :: forall x. Rep PingPongPayload x -> PingPongPayload
to :: forall x. Rep PingPongPayload x -> PingPongPayload
Generic)

instance J.FromJSON PingPongPayload where
  parseJSON :: Value -> Parser PingPongPayload
parseJSON = Options -> Value -> Parser PingPongPayload
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
J.genericParseJSON Options
hasuraJSON

instance J.ToJSON PingPongPayload where
  toJSON :: PingPongPayload -> Value
toJSON = Options -> PingPongPayload -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
J.genericToJSON Options
hasuraJSON
  toEncoding :: PingPongPayload -> Encoding
toEncoding = Options -> PingPongPayload -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
J.genericToEncoding Options
hasuraJSON

-- Specific to graphql-ws
keepAliveMessage :: PingPongPayload
keepAliveMessage :: PingPongPayload
keepAliveMessage = Maybe Text -> PingPongPayload
PingPongPayload (Maybe Text -> PingPongPayload)
-> (String -> Maybe Text) -> String -> PingPongPayload
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> (String -> Text) -> String -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> PingPongPayload) -> String -> PingPongPayload
forall a b. (a -> b) -> a -> b
$ String
"keepalive"

-- Specific to graphql-ws
data SubscribeMsg = SubscribeMsg
  { SubscribeMsg -> OperationId
_subId :: !OperationId,
    SubscribeMsg -> GQLReqUnparsed
_subPayload :: !GQLReqUnparsed
  }
  deriving (Int -> SubscribeMsg -> ShowS
[SubscribeMsg] -> ShowS
SubscribeMsg -> String
(Int -> SubscribeMsg -> ShowS)
-> (SubscribeMsg -> String)
-> ([SubscribeMsg] -> ShowS)
-> Show SubscribeMsg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SubscribeMsg -> ShowS
showsPrec :: Int -> SubscribeMsg -> ShowS
$cshow :: SubscribeMsg -> String
show :: SubscribeMsg -> String
$cshowList :: [SubscribeMsg] -> ShowS
showList :: [SubscribeMsg] -> ShowS
Show, SubscribeMsg -> SubscribeMsg -> Bool
(SubscribeMsg -> SubscribeMsg -> Bool)
-> (SubscribeMsg -> SubscribeMsg -> Bool) -> Eq SubscribeMsg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SubscribeMsg -> SubscribeMsg -> Bool
== :: SubscribeMsg -> SubscribeMsg -> Bool
$c/= :: SubscribeMsg -> SubscribeMsg -> Bool
/= :: SubscribeMsg -> SubscribeMsg -> Bool
Eq, (forall x. SubscribeMsg -> Rep SubscribeMsg x)
-> (forall x. Rep SubscribeMsg x -> SubscribeMsg)
-> Generic SubscribeMsg
forall x. Rep SubscribeMsg x -> SubscribeMsg
forall x. SubscribeMsg -> Rep SubscribeMsg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SubscribeMsg -> Rep SubscribeMsg x
from :: forall x. SubscribeMsg -> Rep SubscribeMsg x
$cto :: forall x. Rep SubscribeMsg x -> SubscribeMsg
to :: forall x. Rep SubscribeMsg x -> SubscribeMsg
Generic)

instance J.FromJSON SubscribeMsg where
  parseJSON :: Value -> Parser SubscribeMsg
parseJSON = Options -> Value -> Parser SubscribeMsg
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
J.genericParseJSON Options
hasuraJSON

instance J.ToJSON SubscribeMsg where
  toJSON :: SubscribeMsg -> Value
toJSON = Options -> SubscribeMsg -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
J.genericToJSON Options
hasuraJSON
  toEncoding :: SubscribeMsg -> Encoding
toEncoding = Options -> SubscribeMsg -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
J.genericToEncoding Options
hasuraJSON

data ClientMsg
  = CMConnInit !(Maybe ConnParams)
  | CMStart !StartMsg
  | CMStop !StopMsg
  | -- specific to apollo clients
    CMConnTerm
  | -- specific to graphql-ws clients
    CMPing !(Maybe PingPongPayload)
  | CMPong !(Maybe PingPongPayload)
  deriving (Int -> ClientMsg -> ShowS
[ClientMsg] -> ShowS
ClientMsg -> String
(Int -> ClientMsg -> ShowS)
-> (ClientMsg -> String)
-> ([ClientMsg] -> ShowS)
-> Show ClientMsg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClientMsg -> ShowS
showsPrec :: Int -> ClientMsg -> ShowS
$cshow :: ClientMsg -> String
show :: ClientMsg -> String
$cshowList :: [ClientMsg] -> ShowS
showList :: [ClientMsg] -> ShowS
Show, ClientMsg -> ClientMsg -> Bool
(ClientMsg -> ClientMsg -> Bool)
-> (ClientMsg -> ClientMsg -> Bool) -> Eq ClientMsg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ClientMsg -> ClientMsg -> Bool
== :: ClientMsg -> ClientMsg -> Bool
$c/= :: ClientMsg -> ClientMsg -> Bool
/= :: ClientMsg -> ClientMsg -> Bool
Eq)

instance J.FromJSON ClientMsg where
  parseJSON :: Value -> Parser ClientMsg
parseJSON = String -> (Object -> Parser ClientMsg) -> Value -> Parser ClientMsg
forall a. String -> (Object -> Parser a) -> Value -> Parser a
J.withObject String
"ClientMessage" ((Object -> Parser ClientMsg) -> Value -> Parser ClientMsg)
-> (Object -> Parser ClientMsg) -> Value -> Parser ClientMsg
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
    String
t <- Object
obj Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
J..: Key
"type"
    case (String
t :: String) of
      String
"connection_init" -> Maybe ConnParams -> ClientMsg
CMConnInit (Maybe ConnParams -> ClientMsg)
-> Parser (Maybe ConnParams) -> Parser ClientMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser (Maybe ConnParams)
forall {a}. FromJSON a => Object -> Parser (Maybe a)
parsePayload Object
obj
      String
"start" -> StartMsg -> ClientMsg
CMStart (StartMsg -> ClientMsg) -> Parser StartMsg -> Parser ClientMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser StartMsg
forall {a}. FromJSON a => Object -> Parser a
parseObj Object
obj
      String
"stop" -> StopMsg -> ClientMsg
CMStop (StopMsg -> ClientMsg) -> Parser StopMsg -> Parser ClientMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser StopMsg
forall {a}. FromJSON a => Object -> Parser a
parseObj Object
obj
      String
"connection_terminate" -> ClientMsg -> Parser ClientMsg
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientMsg
CMConnTerm
      -- graphql-ws specific message types
      String
"complete" -> StopMsg -> ClientMsg
CMStop (StopMsg -> ClientMsg) -> Parser StopMsg -> Parser ClientMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser StopMsg
forall {a}. FromJSON a => Object -> Parser a
parseObj Object
obj
      String
"subscribe" -> StartMsg -> ClientMsg
CMStart (StartMsg -> ClientMsg) -> Parser StartMsg -> Parser ClientMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser StartMsg
forall {a}. FromJSON a => Object -> Parser a
parseObj Object
obj
      String
"ping" -> Maybe PingPongPayload -> ClientMsg
CMPing (Maybe PingPongPayload -> ClientMsg)
-> Parser (Maybe PingPongPayload) -> Parser ClientMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser (Maybe PingPongPayload)
forall {a}. FromJSON a => Object -> Parser (Maybe a)
parsePayload Object
obj
      String
"pong" -> Maybe PingPongPayload -> ClientMsg
CMPong (Maybe PingPongPayload -> ClientMsg)
-> Parser (Maybe PingPongPayload) -> Parser ClientMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser (Maybe PingPongPayload)
forall {a}. FromJSON a => Object -> Parser (Maybe a)
parsePayload Object
obj
      String
_ -> String -> Parser ClientMsg
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ClientMsg) -> String -> Parser ClientMsg
forall a b. (a -> b) -> a -> b
$ String
"unexpected type for ClientMessage: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
t
    where
      parseObj :: Object -> Parser a
parseObj Object
o = Value -> Parser a
forall a. FromJSON a => Value -> Parser a
J.parseJSON (Object -> Value
J.Object Object
o)

      parsePayload :: Object -> Parser (Maybe a)
parsePayload Object
py = Object
py Object -> Key -> Parser (Maybe a)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
J..:? Key
"payload"

data DataMsg = DataMsg
  { DataMsg -> OperationId
_dmId :: !OperationId,
    DataMsg -> GQResponse
_dmPayload :: !GQResponse
  }

data ErrorMsg = ErrorMsg
  { ErrorMsg -> OperationId
_emId :: !OperationId,
    ErrorMsg -> Encoding
_emPayload :: !J.Encoding
  }
  deriving (Int -> ErrorMsg -> ShowS
[ErrorMsg] -> ShowS
ErrorMsg -> String
(Int -> ErrorMsg -> ShowS)
-> (ErrorMsg -> String) -> ([ErrorMsg] -> ShowS) -> Show ErrorMsg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ErrorMsg -> ShowS
showsPrec :: Int -> ErrorMsg -> ShowS
$cshow :: ErrorMsg -> String
show :: ErrorMsg -> String
$cshowList :: [ErrorMsg] -> ShowS
showList :: [ErrorMsg] -> ShowS
Show, ErrorMsg -> ErrorMsg -> Bool
(ErrorMsg -> ErrorMsg -> Bool)
-> (ErrorMsg -> ErrorMsg -> Bool) -> Eq ErrorMsg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ErrorMsg -> ErrorMsg -> Bool
== :: ErrorMsg -> ErrorMsg -> Bool
$c/= :: ErrorMsg -> ErrorMsg -> Bool
/= :: ErrorMsg -> ErrorMsg -> Bool
Eq)

newtype CompletionMsg = CompletionMsg {CompletionMsg -> OperationId
unCompletionMsg :: OperationId}
  deriving (Int -> CompletionMsg -> ShowS
[CompletionMsg] -> ShowS
CompletionMsg -> String
(Int -> CompletionMsg -> ShowS)
-> (CompletionMsg -> String)
-> ([CompletionMsg] -> ShowS)
-> Show CompletionMsg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CompletionMsg -> ShowS
showsPrec :: Int -> CompletionMsg -> ShowS
$cshow :: CompletionMsg -> String
show :: CompletionMsg -> String
$cshowList :: [CompletionMsg] -> ShowS
showList :: [CompletionMsg] -> ShowS
Show, CompletionMsg -> CompletionMsg -> Bool
(CompletionMsg -> CompletionMsg -> Bool)
-> (CompletionMsg -> CompletionMsg -> Bool) -> Eq CompletionMsg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CompletionMsg -> CompletionMsg -> Bool
== :: CompletionMsg -> CompletionMsg -> Bool
$c/= :: CompletionMsg -> CompletionMsg -> Bool
/= :: CompletionMsg -> CompletionMsg -> Bool
Eq)

instance J.FromJSON CompletionMsg where
  parseJSON :: Value -> Parser CompletionMsg
parseJSON = String
-> (Object -> Parser CompletionMsg)
-> Value
-> Parser CompletionMsg
forall a. String -> (Object -> Parser a) -> Value -> Parser a
J.withObject String
"CompletionMsg" ((Object -> Parser CompletionMsg) -> Value -> Parser CompletionMsg)
-> (Object -> Parser CompletionMsg)
-> Value
-> Parser CompletionMsg
forall a b. (a -> b) -> a -> b
$ \Object
t ->
    OperationId -> CompletionMsg
CompletionMsg (OperationId -> CompletionMsg)
-> Parser OperationId -> Parser CompletionMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
t Object -> Key -> Parser OperationId
forall a. FromJSON a => Object -> Key -> Parser a
J..: Key
"id"

instance J.ToJSON CompletionMsg where
  toJSON :: CompletionMsg -> Value
toJSON (CompletionMsg OperationId
opId) = Text -> Value
J.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ OperationId -> Text
forall a. Show a => a -> Text
tshow OperationId
opId

newtype ConnErrMsg = ConnErrMsg {ConnErrMsg -> Text
unConnErrMsg :: Text}
  deriving (Int -> ConnErrMsg -> ShowS
[ConnErrMsg] -> ShowS
ConnErrMsg -> String
(Int -> ConnErrMsg -> ShowS)
-> (ConnErrMsg -> String)
-> ([ConnErrMsg] -> ShowS)
-> Show ConnErrMsg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConnErrMsg -> ShowS
showsPrec :: Int -> ConnErrMsg -> ShowS
$cshow :: ConnErrMsg -> String
show :: ConnErrMsg -> String
$cshowList :: [ConnErrMsg] -> ShowS
showList :: [ConnErrMsg] -> ShowS
Show, ConnErrMsg -> ConnErrMsg -> Bool
(ConnErrMsg -> ConnErrMsg -> Bool)
-> (ConnErrMsg -> ConnErrMsg -> Bool) -> Eq ConnErrMsg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConnErrMsg -> ConnErrMsg -> Bool
== :: ConnErrMsg -> ConnErrMsg -> Bool
$c/= :: ConnErrMsg -> ConnErrMsg -> Bool
/= :: ConnErrMsg -> ConnErrMsg -> Bool
Eq, [ConnErrMsg] -> Value
[ConnErrMsg] -> Encoding
ConnErrMsg -> Value
ConnErrMsg -> Encoding
(ConnErrMsg -> Value)
-> (ConnErrMsg -> Encoding)
-> ([ConnErrMsg] -> Value)
-> ([ConnErrMsg] -> Encoding)
-> ToJSON ConnErrMsg
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
$ctoJSON :: ConnErrMsg -> Value
toJSON :: ConnErrMsg -> Value
$ctoEncoding :: ConnErrMsg -> Encoding
toEncoding :: ConnErrMsg -> Encoding
$ctoJSONList :: [ConnErrMsg] -> Value
toJSONList :: [ConnErrMsg] -> Value
$ctoEncodingList :: [ConnErrMsg] -> Encoding
toEncodingList :: [ConnErrMsg] -> Encoding
J.ToJSON, Value -> Parser [ConnErrMsg]
Value -> Parser ConnErrMsg
(Value -> Parser ConnErrMsg)
-> (Value -> Parser [ConnErrMsg]) -> FromJSON ConnErrMsg
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
$cparseJSON :: Value -> Parser ConnErrMsg
parseJSON :: Value -> Parser ConnErrMsg
$cparseJSONList :: Value -> Parser [ConnErrMsg]
parseJSONList :: Value -> Parser [ConnErrMsg]
J.FromJSON, String -> ConnErrMsg
(String -> ConnErrMsg) -> IsString ConnErrMsg
forall a. (String -> a) -> IsString a
$cfromString :: String -> ConnErrMsg
fromString :: String -> ConnErrMsg
IsString)

data ServerErrorMsg = ServerErrorMsg {ServerErrorMsg -> Text
unServerErrorMsg :: Text}
  deriving stock (Int -> ServerErrorMsg -> ShowS
[ServerErrorMsg] -> ShowS
ServerErrorMsg -> String
(Int -> ServerErrorMsg -> ShowS)
-> (ServerErrorMsg -> String)
-> ([ServerErrorMsg] -> ShowS)
-> Show ServerErrorMsg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerErrorMsg -> ShowS
showsPrec :: Int -> ServerErrorMsg -> ShowS
$cshow :: ServerErrorMsg -> String
show :: ServerErrorMsg -> String
$cshowList :: [ServerErrorMsg] -> ShowS
showList :: [ServerErrorMsg] -> ShowS
Show, ServerErrorMsg -> ServerErrorMsg -> Bool
(ServerErrorMsg -> ServerErrorMsg -> Bool)
-> (ServerErrorMsg -> ServerErrorMsg -> Bool) -> Eq ServerErrorMsg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ServerErrorMsg -> ServerErrorMsg -> Bool
== :: ServerErrorMsg -> ServerErrorMsg -> Bool
$c/= :: ServerErrorMsg -> ServerErrorMsg -> Bool
/= :: ServerErrorMsg -> ServerErrorMsg -> Bool
Eq, (forall x. ServerErrorMsg -> Rep ServerErrorMsg x)
-> (forall x. Rep ServerErrorMsg x -> ServerErrorMsg)
-> Generic ServerErrorMsg
forall x. Rep ServerErrorMsg x -> ServerErrorMsg
forall x. ServerErrorMsg -> Rep ServerErrorMsg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ServerErrorMsg -> Rep ServerErrorMsg x
from :: forall x. ServerErrorMsg -> Rep ServerErrorMsg x
$cto :: forall x. Rep ServerErrorMsg x -> ServerErrorMsg
to :: forall x. Rep ServerErrorMsg x -> ServerErrorMsg
Generic)

instance J.FromJSON ServerErrorMsg where
  parseJSON :: Value -> Parser ServerErrorMsg
parseJSON = Options -> Value -> Parser ServerErrorMsg
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
J.genericParseJSON Options
hasuraJSON

instance J.ToJSON ServerErrorMsg where
  toJSON :: ServerErrorMsg -> Value
toJSON = Options -> ServerErrorMsg -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
J.genericToJSON Options
hasuraJSON
  toEncoding :: ServerErrorMsg -> Encoding
toEncoding = Options -> ServerErrorMsg -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
J.genericToEncoding Options
hasuraJSON

data ServerMsg
  = SMConnAck
  | SMConnKeepAlive
  | SMConnErr !ConnErrMsg
  | SMData !DataMsg
  | SMErr !ErrorMsg
  | SMComplete !CompletionMsg
  | -- graphql-ws specific values
    SMNext !DataMsg
  | SMPing !(Maybe PingPongPayload)
  | SMPong !(Maybe PingPongPayload)

-- | This is sent from the server to the client while closing the websocket
--   on encountering an error.
data ServerErrorCode
  = ProtocolError1002
  | GenericError4400 !String
  | Unauthorized4401
  | Forbidden4403
  | ConnectionInitTimeout4408
  | NonUniqueSubscription4409 !OperationId
  | TooManyRequests4429
  deriving stock (Int -> ServerErrorCode -> ShowS
[ServerErrorCode] -> ShowS
ServerErrorCode -> String
(Int -> ServerErrorCode -> ShowS)
-> (ServerErrorCode -> String)
-> ([ServerErrorCode] -> ShowS)
-> Show ServerErrorCode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerErrorCode -> ShowS
showsPrec :: Int -> ServerErrorCode -> ShowS
$cshow :: ServerErrorCode -> String
show :: ServerErrorCode -> String
$cshowList :: [ServerErrorCode] -> ShowS
showList :: [ServerErrorCode] -> ShowS
Show)

encodeServerErrorMsg :: ServerErrorCode -> BL.ByteString
encodeServerErrorMsg :: ServerErrorCode -> ByteString
encodeServerErrorMsg ServerErrorCode
ecode = EncJSON -> ByteString
encJToLBS (EncJSON -> ByteString)
-> (ServerErrorMsg -> EncJSON) -> ServerErrorMsg -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerErrorMsg -> EncJSON
forall a. ToJSON a => a -> EncJSON
encJFromJValue (ServerErrorMsg -> ByteString) -> ServerErrorMsg -> ByteString
forall a b. (a -> b) -> a -> b
$ case ServerErrorCode
ecode of
  ServerErrorCode
ProtocolError1002 -> String -> ServerErrorMsg
packMsg String
"1002: Protocol Error"
  GenericError4400 String
msg -> String -> ServerErrorMsg
packMsg (String -> ServerErrorMsg) -> String -> ServerErrorMsg
forall a b. (a -> b) -> a -> b
$ String
"4400: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
msg
  ServerErrorCode
Unauthorized4401 -> String -> ServerErrorMsg
packMsg String
"4401: Unauthorized"
  ServerErrorCode
Forbidden4403 -> String -> ServerErrorMsg
packMsg String
"4403: Forbidden"
  ServerErrorCode
ConnectionInitTimeout4408 -> String -> ServerErrorMsg
packMsg String
"4408: Connection initialisation timeout"
  NonUniqueSubscription4409 OperationId
opId -> String -> ServerErrorMsg
packMsg (String -> ServerErrorMsg) -> String -> ServerErrorMsg
forall a b. (a -> b) -> a -> b
$ String
"4409: Subscriber for " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> OperationId -> String
forall a. Show a => a -> String
show OperationId
opId String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" already exists"
  ServerErrorCode
TooManyRequests4429 -> String -> ServerErrorMsg
packMsg String
"4429: Too many requests"
  where
    packMsg :: String -> ServerErrorMsg
packMsg = Text -> ServerErrorMsg
ServerErrorMsg (Text -> ServerErrorMsg)
-> (String -> Text) -> String -> ServerErrorMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack

encodeServerMsg :: ServerMsg -> BL.ByteString
encodeServerMsg :: ServerMsg -> ByteString
encodeServerMsg ServerMsg
msg =
  EncJSON -> ByteString
encJToLBS
    (EncJSON -> ByteString) -> EncJSON -> ByteString
forall a b. (a -> b) -> a -> b
$ [(Text, EncJSON)] -> EncJSON
encJFromAssocList
    ([(Text, EncJSON)] -> EncJSON) -> [(Text, EncJSON)] -> EncJSON
forall a b. (a -> b) -> a -> b
$ case ServerMsg
msg of
      ServerMsg
SMConnAck ->
        [ServerMsgType -> (Text, EncJSON)
forall {a} {a}. (IsString a, ToJSON a) => a -> (a, EncJSON)
encTy ServerMsgType
SMT_GQL_CONNECTION_ACK]
      ServerMsg
SMConnKeepAlive ->
        [ServerMsgType -> (Text, EncJSON)
forall {a} {a}. (IsString a, ToJSON a) => a -> (a, EncJSON)
encTy ServerMsgType
SMT_GQL_CONNECTION_KEEP_ALIVE]
      SMConnErr ConnErrMsg
connErr ->
        [ ServerMsgType -> (Text, EncJSON)
forall {a} {a}. (IsString a, ToJSON a) => a -> (a, EncJSON)
encTy ServerMsgType
SMT_GQL_CONNECTION_ERROR,
          (Text
"payload", ConnErrMsg -> EncJSON
forall a. ToJSON a => a -> EncJSON
encJFromJValue ConnErrMsg
connErr)
        ]
      SMData (DataMsg OperationId
opId GQResponse
payload) ->
        [ ServerMsgType -> (Text, EncJSON)
forall {a} {a}. (IsString a, ToJSON a) => a -> (a, EncJSON)
encTy ServerMsgType
SMT_GQL_DATA,
          (Text
"id", OperationId -> EncJSON
forall a. ToJSON a => a -> EncJSON
encJFromJValue OperationId
opId),
          (Text
"payload", GQResponse -> EncJSON
encodeGQResp GQResponse
payload)
        ]
      SMErr (ErrorMsg OperationId
opId Encoding
payload) ->
        [ ServerMsgType -> (Text, EncJSON)
forall {a} {a}. (IsString a, ToJSON a) => a -> (a, EncJSON)
encTy ServerMsgType
SMT_GQL_ERROR,
          (Text
"id", OperationId -> EncJSON
forall a. ToJSON a => a -> EncJSON
encJFromJValue OperationId
opId),
          (Text
"payload", Encoding -> EncJSON
encJFromJEncoding Encoding
payload)
        ]
      SMComplete CompletionMsg
compMsg ->
        [ ServerMsgType -> (Text, EncJSON)
forall {a} {a}. (IsString a, ToJSON a) => a -> (a, EncJSON)
encTy ServerMsgType
SMT_GQL_COMPLETE,
          (Text
"id", OperationId -> EncJSON
forall a. ToJSON a => a -> EncJSON
encJFromJValue (OperationId -> EncJSON) -> OperationId -> EncJSON
forall a b. (a -> b) -> a -> b
$ CompletionMsg -> OperationId
unCompletionMsg CompletionMsg
compMsg)
        ]
      SMPing Maybe PingPongPayload
mPayload ->
        Maybe PingPongPayload -> ServerMsgType -> [(Text, EncJSON)]
forall {a} {a} {a}.
(IsString a, ToJSON a, ToJSON a) =>
Maybe a -> a -> [(a, EncJSON)]
encodePingPongPayload Maybe PingPongPayload
mPayload ServerMsgType
SMT_GQL_PING
      SMPong Maybe PingPongPayload
mPayload ->
        Maybe PingPongPayload -> ServerMsgType -> [(Text, EncJSON)]
forall {a} {a} {a}.
(IsString a, ToJSON a, ToJSON a) =>
Maybe a -> a -> [(a, EncJSON)]
encodePingPongPayload Maybe PingPongPayload
mPayload ServerMsgType
SMT_GQL_PONG
      SMNext (DataMsg OperationId
opId GQResponse
payload) ->
        [ ServerMsgType -> (Text, EncJSON)
forall {a} {a}. (IsString a, ToJSON a) => a -> (a, EncJSON)
encTy ServerMsgType
SMT_GQL_NEXT,
          (Text
"id", OperationId -> EncJSON
forall a. ToJSON a => a -> EncJSON
encJFromJValue OperationId
opId),
          (Text
"payload", GQResponse -> EncJSON
encodeGQResp GQResponse
payload)
        ]
  where
    encTy :: a -> (a, EncJSON)
encTy a
ty = (a
"type", a -> EncJSON
forall a. ToJSON a => a -> EncJSON
encJFromJValue a
ty)

    encodePingPongPayload :: Maybe a -> a -> [(a, EncJSON)]
encodePingPongPayload Maybe a
mPayload a
msgType = case Maybe a
mPayload of
      Just a
payload ->
        [ a -> (a, EncJSON)
forall {a} {a}. (IsString a, ToJSON a) => a -> (a, EncJSON)
encTy a
msgType,
          (a
"payload", a -> EncJSON
forall a. ToJSON a => a -> EncJSON
encJFromJValue a
payload)
        ]
      Maybe a
Nothing -> [a -> (a, EncJSON)
forall {a} {a}. (IsString a, ToJSON a) => a -> (a, EncJSON)
encTy a
msgType]

-- This "timer" is necessary while initialising the connection
-- with the server. Also, this is specific to the GraphQL-WS protocol.
data WSConnInitTimerStatus = Running | Done
  deriving stock (Int -> WSConnInitTimerStatus -> ShowS
[WSConnInitTimerStatus] -> ShowS
WSConnInitTimerStatus -> String
(Int -> WSConnInitTimerStatus -> ShowS)
-> (WSConnInitTimerStatus -> String)
-> ([WSConnInitTimerStatus] -> ShowS)
-> Show WSConnInitTimerStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WSConnInitTimerStatus -> ShowS
showsPrec :: Int -> WSConnInitTimerStatus -> ShowS
$cshow :: WSConnInitTimerStatus -> String
show :: WSConnInitTimerStatus -> String
$cshowList :: [WSConnInitTimerStatus] -> ShowS
showList :: [WSConnInitTimerStatus] -> ShowS
Show, WSConnInitTimerStatus -> WSConnInitTimerStatus -> Bool
(WSConnInitTimerStatus -> WSConnInitTimerStatus -> Bool)
-> (WSConnInitTimerStatus -> WSConnInitTimerStatus -> Bool)
-> Eq WSConnInitTimerStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WSConnInitTimerStatus -> WSConnInitTimerStatus -> Bool
== :: WSConnInitTimerStatus -> WSConnInitTimerStatus -> Bool
$c/= :: WSConnInitTimerStatus -> WSConnInitTimerStatus -> Bool
/= :: WSConnInitTimerStatus -> WSConnInitTimerStatus -> Bool
Eq)

type WSConnInitTimer = (TVar WSConnInitTimerStatus, TMVar ())

getWSTimerState :: WSConnInitTimer -> IO WSConnInitTimerStatus
getWSTimerState :: WSConnInitTimer -> IO WSConnInitTimerStatus
getWSTimerState (TVar WSConnInitTimerStatus
timerState, TMVar ()
_) = TVar WSConnInitTimerStatus -> IO WSConnInitTimerStatus
forall a. TVar a -> IO a
readTVarIO TVar WSConnInitTimerStatus
timerState

{-# ANN getNewWSTimer ("HLint: ignore Use withAsync" :: String) #-}
getNewWSTimer :: Seconds -> IO WSConnInitTimer
getNewWSTimer :: Seconds -> IO WSConnInitTimer
getNewWSTimer Seconds
timeout = do
  TVar WSConnInitTimerStatus
timerState <- WSConnInitTimerStatus -> IO (TVar WSConnInitTimerStatus)
forall a. a -> IO (TVar a)
newTVarIO WSConnInitTimerStatus
Running
  TMVar ()
timer <- IO (TMVar ())
forall a. IO (TMVar a)
newEmptyTMVarIO
  IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
    (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO
    (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
      DiffTime -> IO ()
sleep (Seconds -> DiffTime
seconds Seconds
timeout)
      STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        WSConnInitTimerStatus
runTimerState <- TVar WSConnInitTimerStatus -> STM WSConnInitTimerStatus
forall a. TVar a -> STM a
readTVar TVar WSConnInitTimerStatus
timerState
        case WSConnInitTimerStatus
runTimerState of
          WSConnInitTimerStatus
Running -> do
            -- time's up, we set status to "Done"
            TVar WSConnInitTimerStatus -> WSConnInitTimerStatus -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar WSConnInitTimerStatus
timerState WSConnInitTimerStatus
Done
            TMVar () -> () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
timer ()
          WSConnInitTimerStatus
Done -> () -> STM ()
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  WSConnInitTimer -> IO WSConnInitTimer
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TVar WSConnInitTimerStatus
timerState, TMVar ()
timer)