{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Subscriptions.Apollo
( ApolloAction (..),
apolloFormat,
acceptApolloRequest,
toApolloResponse,
Validation,
)
where
import Control.Applicative (Applicative (..))
import Control.Monad.IO.Class (MonadIO (..))
import Data.Aeson
( (.:),
(.:?),
(.=),
FromJSON (..),
ToJSON (..),
Value (..),
eitherDecode,
encode,
pairs,
withObject,
)
import Data.ByteString.Lazy.Char8
( ByteString,
pack,
)
import Data.Either
( Either (..),
either,
)
import Data.Functor ((<$>))
import Data.Maybe
( Maybe (..),
maybe,
)
import Data.Morpheus.Types.IO
( GQLRequest (..),
GQLResponse,
)
import Data.Morpheus.Types.Internal.AST
( FieldName,
Token,
)
import Data.Semigroup ((<>))
import Data.Text
( Text,
unpack,
)
import GHC.Generics (Generic)
import Network.WebSockets
( AcceptRequest (..),
Connection,
PendingConnection,
RequestHead,
acceptRequestWith,
getRequestSubprotocols,
pendingRequest,
)
import Prelude
( ($),
(.),
Show,
String,
)
type ID = Text
data ApolloSubscription payload = ApolloSubscription
{ ApolloSubscription payload -> Maybe ID
apolloId :: Maybe ID,
ApolloSubscription payload -> ID
apolloType :: Text,
ApolloSubscription payload -> Maybe payload
apolloPayload :: Maybe payload
}
deriving (Int -> ApolloSubscription payload -> ShowS
[ApolloSubscription payload] -> ShowS
ApolloSubscription payload -> String
(Int -> ApolloSubscription payload -> ShowS)
-> (ApolloSubscription payload -> String)
-> ([ApolloSubscription payload] -> ShowS)
-> Show (ApolloSubscription payload)
forall payload.
Show payload =>
Int -> ApolloSubscription payload -> ShowS
forall payload.
Show payload =>
[ApolloSubscription payload] -> ShowS
forall payload.
Show payload =>
ApolloSubscription payload -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ApolloSubscription payload] -> ShowS
$cshowList :: forall payload.
Show payload =>
[ApolloSubscription payload] -> ShowS
show :: ApolloSubscription payload -> String
$cshow :: forall payload.
Show payload =>
ApolloSubscription payload -> String
showsPrec :: Int -> ApolloSubscription payload -> ShowS
$cshowsPrec :: forall payload.
Show payload =>
Int -> ApolloSubscription payload -> ShowS
Show, (forall x.
ApolloSubscription payload -> Rep (ApolloSubscription payload) x)
-> (forall x.
Rep (ApolloSubscription payload) x -> ApolloSubscription payload)
-> Generic (ApolloSubscription payload)
forall x.
Rep (ApolloSubscription payload) x -> ApolloSubscription payload
forall x.
ApolloSubscription payload -> Rep (ApolloSubscription payload) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall payload x.
Rep (ApolloSubscription payload) x -> ApolloSubscription payload
forall payload x.
ApolloSubscription payload -> Rep (ApolloSubscription payload) x
$cto :: forall payload x.
Rep (ApolloSubscription payload) x -> ApolloSubscription payload
$cfrom :: forall payload x.
ApolloSubscription payload -> Rep (ApolloSubscription payload) x
Generic)
instance FromJSON a => FromJSON (ApolloSubscription a) where
parseJSON :: Value -> Parser (ApolloSubscription a)
parseJSON = String
-> (Object -> Parser (ApolloSubscription a))
-> Value
-> Parser (ApolloSubscription a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ApolloSubscription" Object -> Parser (ApolloSubscription a)
forall payload.
FromJSON payload =>
Object -> Parser (ApolloSubscription payload)
objectParser
where
objectParser :: Object -> Parser (ApolloSubscription payload)
objectParser Object
o =
Maybe ID -> ID -> Maybe payload -> ApolloSubscription payload
forall payload.
Maybe ID -> ID -> Maybe payload -> ApolloSubscription payload
ApolloSubscription (Maybe ID -> ID -> Maybe payload -> ApolloSubscription payload)
-> Parser (Maybe ID)
-> Parser (ID -> Maybe payload -> ApolloSubscription payload)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> ID -> Parser (Maybe ID)
forall a. FromJSON a => Object -> ID -> Parser (Maybe a)
.:? ID
"id" Parser (ID -> Maybe payload -> ApolloSubscription payload)
-> Parser ID
-> Parser (Maybe payload -> ApolloSubscription payload)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> ID -> Parser ID
forall a. FromJSON a => Object -> ID -> Parser a
.: ID
"type" Parser (Maybe payload -> ApolloSubscription payload)
-> Parser (Maybe payload) -> Parser (ApolloSubscription payload)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> ID -> Parser (Maybe payload)
forall a. FromJSON a => Object -> ID -> Parser (Maybe a)
.:? ID
"payload"
data RequestPayload = RequestPayload
{ RequestPayload -> Maybe FieldName
payloadOperationName :: Maybe FieldName,
RequestPayload -> Maybe ID
payloadQuery :: Maybe Token,
RequestPayload -> Maybe Value
payloadVariables :: Maybe Value
}
deriving (Int -> RequestPayload -> ShowS
[RequestPayload] -> ShowS
RequestPayload -> String
(Int -> RequestPayload -> ShowS)
-> (RequestPayload -> String)
-> ([RequestPayload] -> ShowS)
-> Show RequestPayload
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RequestPayload] -> ShowS
$cshowList :: [RequestPayload] -> ShowS
show :: RequestPayload -> String
$cshow :: RequestPayload -> String
showsPrec :: Int -> RequestPayload -> ShowS
$cshowsPrec :: Int -> RequestPayload -> ShowS
Show, (forall x. RequestPayload -> Rep RequestPayload x)
-> (forall x. Rep RequestPayload x -> RequestPayload)
-> Generic RequestPayload
forall x. Rep RequestPayload x -> RequestPayload
forall x. RequestPayload -> Rep RequestPayload x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RequestPayload x -> RequestPayload
$cfrom :: forall x. RequestPayload -> Rep RequestPayload x
Generic)
instance FromJSON RequestPayload where
parseJSON :: Value -> Parser RequestPayload
parseJSON = String
-> (Object -> Parser RequestPayload)
-> Value
-> Parser RequestPayload
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ApolloPayload" Object -> Parser RequestPayload
objectParser
where
objectParser :: Object -> Parser RequestPayload
objectParser Object
o =
Maybe FieldName -> Maybe ID -> Maybe Value -> RequestPayload
RequestPayload (Maybe FieldName -> Maybe ID -> Maybe Value -> RequestPayload)
-> Parser (Maybe FieldName)
-> Parser (Maybe ID -> Maybe Value -> RequestPayload)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> ID -> Parser (Maybe FieldName)
forall a. FromJSON a => Object -> ID -> Parser (Maybe a)
.:? ID
"operationName" Parser (Maybe ID -> Maybe Value -> RequestPayload)
-> Parser (Maybe ID) -> Parser (Maybe Value -> RequestPayload)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> ID -> Parser (Maybe ID)
forall a. FromJSON a => Object -> ID -> Parser (Maybe a)
.:? ID
"query"
Parser (Maybe Value -> RequestPayload)
-> Parser (Maybe Value) -> Parser RequestPayload
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> ID -> Parser (Maybe Value)
forall a. FromJSON a => Object -> ID -> Parser (Maybe a)
.:? ID
"variables"
instance ToJSON a => ToJSON (ApolloSubscription a) where
toEncoding :: ApolloSubscription a -> Encoding
toEncoding (ApolloSubscription Maybe ID
id' ID
type' Maybe a
payload') =
Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ ID
"id" ID -> Maybe ID -> Series
forall kv v. (KeyValue kv, ToJSON v) => ID -> v -> kv
.= Maybe ID
id' Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> ID
"type" ID -> ID -> Series
forall kv v. (KeyValue kv, ToJSON v) => ID -> v -> kv
.= ID
type' Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> ID
"payload" ID -> Maybe a -> Series
forall kv v. (KeyValue kv, ToJSON v) => ID -> v -> kv
.= Maybe a
payload'
acceptApolloRequest ::
MonadIO m =>
PendingConnection ->
m Connection
acceptApolloRequest :: PendingConnection -> m Connection
acceptApolloRequest PendingConnection
pending =
IO Connection -> m Connection
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Connection -> m Connection) -> IO Connection -> m Connection
forall a b. (a -> b) -> a -> b
$
PendingConnection -> AcceptRequest -> IO Connection
acceptRequestWith
PendingConnection
pending
(RequestHead -> AcceptRequest
acceptApolloSubProtocol (PendingConnection -> RequestHead
pendingRequest PendingConnection
pending))
acceptApolloSubProtocol :: RequestHead -> AcceptRequest
acceptApolloSubProtocol :: RequestHead -> AcceptRequest
acceptApolloSubProtocol RequestHead
reqHead =
[ByteString] -> AcceptRequest
forall a. (Eq a, IsString a) => [a] -> AcceptRequest
apolloProtocol (RequestHead -> [ByteString]
getRequestSubprotocols RequestHead
reqHead)
where
apolloProtocol :: [a] -> AcceptRequest
apolloProtocol [a
"graphql-subscriptions"] =
Maybe ByteString -> Headers -> AcceptRequest
AcceptRequest (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"graphql-subscriptions") []
apolloProtocol [a
"graphql-ws"] = Maybe ByteString -> Headers -> AcceptRequest
AcceptRequest (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"graphql-ws") []
apolloProtocol [a]
_ = Maybe ByteString -> Headers -> AcceptRequest
AcceptRequest Maybe ByteString
forall a. Maybe a
Nothing []
toApolloResponse :: ID -> GQLResponse -> ByteString
toApolloResponse :: ID -> GQLResponse -> ByteString
toApolloResponse ID
sid GQLResponse
val =
ApolloSubscription GQLResponse -> ByteString
forall a. ToJSON a => a -> ByteString
encode (ApolloSubscription GQLResponse -> ByteString)
-> ApolloSubscription GQLResponse -> ByteString
forall a b. (a -> b) -> a -> b
$ Maybe ID
-> ID -> Maybe GQLResponse -> ApolloSubscription GQLResponse
forall payload.
Maybe ID -> ID -> Maybe payload -> ApolloSubscription payload
ApolloSubscription (ID -> Maybe ID
forall a. a -> Maybe a
Just ID
sid) ID
"data" (GQLResponse -> Maybe GQLResponse
forall a. a -> Maybe a
Just GQLResponse
val)
data ApolloAction
= SessionStop ID
| SessionStart ID GQLRequest
| ConnectionInit
type Validation = Either ByteString
apolloFormat :: ByteString -> Validation ApolloAction
apolloFormat :: ByteString -> Validation ApolloAction
apolloFormat = Either String (ApolloSubscription RequestPayload)
-> Validation ApolloAction
validateReq (Either String (ApolloSubscription RequestPayload)
-> Validation ApolloAction)
-> (ByteString
-> Either String (ApolloSubscription RequestPayload))
-> ByteString
-> Validation ApolloAction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String (ApolloSubscription RequestPayload)
forall a. FromJSON a => ByteString -> Either String a
eitherDecode
where
validateReq :: Either String (ApolloSubscription RequestPayload) -> Validation ApolloAction
validateReq :: Either String (ApolloSubscription RequestPayload)
-> Validation ApolloAction
validateReq = (String -> Validation ApolloAction)
-> (ApolloSubscription RequestPayload -> Validation ApolloAction)
-> Either String (ApolloSubscription RequestPayload)
-> Validation ApolloAction
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ByteString -> Validation ApolloAction
forall a b. a -> Either a b
Left (ByteString -> Validation ApolloAction)
-> (String -> ByteString) -> String -> Validation ApolloAction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
pack) ApolloSubscription RequestPayload -> Validation ApolloAction
validateSub
validateSub :: ApolloSubscription RequestPayload -> Validation ApolloAction
validateSub :: ApolloSubscription RequestPayload -> Validation ApolloAction
validateSub ApolloSubscription {apolloType :: forall payload. ApolloSubscription payload -> ID
apolloType = ID
"connection_init"} =
ApolloAction -> Validation ApolloAction
forall (f :: * -> *) a. Applicative f => a -> f a
pure ApolloAction
ConnectionInit
validateSub ApolloSubscription {apolloType :: forall payload. ApolloSubscription payload -> ID
apolloType = ID
"start", Maybe ID
apolloId :: Maybe ID
apolloId :: forall payload. ApolloSubscription payload -> Maybe ID
apolloId, Maybe RequestPayload
apolloPayload :: Maybe RequestPayload
apolloPayload :: forall payload. ApolloSubscription payload -> Maybe payload
apolloPayload} =
do
ID
sessionId <- Maybe ID -> Validation ID
validateSession Maybe ID
apolloId
GQLRequest
payload <- Maybe RequestPayload -> Either ByteString GQLRequest
validatePayload Maybe RequestPayload
apolloPayload
ApolloAction -> Validation ApolloAction
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ApolloAction -> Validation ApolloAction)
-> ApolloAction -> Validation ApolloAction
forall a b. (a -> b) -> a -> b
$ ID -> GQLRequest -> ApolloAction
SessionStart ID
sessionId GQLRequest
payload
validateSub ApolloSubscription {apolloType :: forall payload. ApolloSubscription payload -> ID
apolloType = ID
"stop", Maybe ID
apolloId :: Maybe ID
apolloId :: forall payload. ApolloSubscription payload -> Maybe ID
apolloId} =
ID -> ApolloAction
SessionStop (ID -> ApolloAction) -> Validation ID -> Validation ApolloAction
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ID -> Validation ID
validateSession Maybe ID
apolloId
validateSub ApolloSubscription {ID
apolloType :: ID
apolloType :: forall payload. ApolloSubscription payload -> ID
apolloType} =
ByteString -> Validation ApolloAction
forall a b. a -> Either a b
Left (ByteString -> Validation ApolloAction)
-> ByteString -> Validation ApolloAction
forall a b. (a -> b) -> a -> b
$ ByteString
"Unknown Request type \"" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
pack (ID -> String
unpack ID
apolloType) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\"."
validateSession :: Maybe ID -> Validation ID
validateSession :: Maybe ID -> Validation ID
validateSession = Validation ID -> (ID -> Validation ID) -> Maybe ID -> Validation ID
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ByteString -> Validation ID
forall a b. a -> Either a b
Left ByteString
"\"id\" was not provided") ID -> Validation ID
forall a b. b -> Either a b
Right
validatePayload :: Maybe RequestPayload -> Either ByteString GQLRequest
validatePayload = Either ByteString GQLRequest
-> (RequestPayload -> Either ByteString GQLRequest)
-> Maybe RequestPayload
-> Either ByteString GQLRequest
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ByteString -> Either ByteString GQLRequest
forall a b. a -> Either a b
Left ByteString
"\"payload\" was not provided") RequestPayload -> Either ByteString GQLRequest
forall a. IsString a => RequestPayload -> Either a GQLRequest
validatePayloadContent
validatePayloadContent :: RequestPayload -> Either a GQLRequest
validatePayloadContent
RequestPayload
{ Maybe ID
payloadQuery :: Maybe ID
payloadQuery :: RequestPayload -> Maybe ID
payloadQuery,
payloadOperationName :: RequestPayload -> Maybe FieldName
payloadOperationName = Maybe FieldName
operationName,
payloadVariables :: RequestPayload -> Maybe Value
payloadVariables = Maybe Value
variables
} = do
ID
query <- Either a ID -> (ID -> Either a ID) -> Maybe ID -> Either a ID
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a -> Either a ID
forall a b. a -> Either a b
Left a
"\"payload.query\" was not provided") ID -> Either a ID
forall a b. b -> Either a b
Right Maybe ID
payloadQuery
GQLRequest -> Either a GQLRequest
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GQLRequest -> Either a GQLRequest)
-> GQLRequest -> Either a GQLRequest
forall a b. (a -> b) -> a -> b
$ GQLRequest :: Maybe FieldName -> ID -> Maybe Value -> GQLRequest
GQLRequest {ID
query :: ID
query :: ID
query, Maybe FieldName
operationName :: Maybe FieldName
operationName :: Maybe FieldName
operationName, Maybe Value
variables :: Maybe Value
variables :: Maybe Value
variables}