{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Subscriptions.Apollo
  ( ApolloAction (..),
    apolloFormat,
    acceptApolloRequest,
    toApolloResponse,
    Validation,
    ApolloSubscription (..),
  )
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
  { forall payload. ApolloSubscription payload -> Maybe ID
apolloId :: Maybe ID,
    forall payload. ApolloSubscription payload -> ID
apolloType :: Text,
    forall payload. ApolloSubscription payload -> Maybe payload
apolloPayload :: Maybe payload
  }
  deriving (Int -> ApolloSubscription payload -> ShowS
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 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 = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ApolloSubscription" forall {payload}.
FromJSON payload =>
Object -> Parser (ApolloSubscription payload)
objectParser
    where
      objectParser :: Object -> Parser (ApolloSubscription payload)
objectParser Object
o =
        forall payload.
Maybe ID -> ID -> Maybe payload -> ApolloSubscription payload
ApolloSubscription forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"id" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"type" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"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
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. 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 = 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
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"operationName"
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"query"
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"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 forall a b. (a -> b) -> a -> b
$ Key
"id" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe ID
id' forall a. Semigroup a => a -> a -> a
<> Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ID
type' forall a. Semigroup a => a -> a -> a
<> Key
"payload" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe a
payload'

acceptApolloRequest ::
  MonadIO m =>
  PendingConnection ->
  m Connection
acceptApolloRequest :: forall (m :: * -> *).
MonadIO m =>
PendingConnection -> m Connection
acceptApolloRequest PendingConnection
pending =
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 =
  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 (forall a. a -> Maybe a
Just ByteString
"graphql-subscriptions") []
    apolloProtocol [a
"graphql-ws"] = Maybe ByteString -> Headers -> AcceptRequest
AcceptRequest (forall a. a -> Maybe a
Just ByteString
"graphql-ws") []
    apolloProtocol [a]
_ = Maybe ByteString -> Headers -> AcceptRequest
AcceptRequest forall a. Maybe a
Nothing []

toApolloResponse :: ID -> GQLResponse -> ByteString
toApolloResponse :: ID -> GQLResponse -> ByteString
toApolloResponse ID
sid GQLResponse
val =
  forall a. ToJSON a => a -> ByteString
encode forall a b. (a -> b) -> a -> b
$ forall payload.
Maybe ID -> ID -> Maybe payload -> ApolloSubscription payload
ApolloSubscription (forall a. a -> Maybe a
Just ID
sid) ID
"data" (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left 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"} =
      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
        forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 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} =
      forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ ByteString
"Unknown Request type \"" forall a. Semigroup a => a -> a -> a
<> String -> ByteString
pack (ID -> String
unpack ID
apolloType) forall a. Semigroup a => a -> a -> a
<> ByteString
"\"."
    --------------------------------------------
    validateSession :: Maybe ID -> Validation ID
    validateSession :: Maybe ID -> Validation ID
validateSession = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left ByteString
"\"id\" was not provided") forall a b. b -> Either a b
Right
    -------------------------------------
    validatePayload :: Maybe RequestPayload -> Either ByteString GQLRequest
validatePayload = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left ByteString
"\"payload\" was not provided") 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 <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left a
"\"payload.query\" was not provided") forall a b. b -> Either a b
Right Maybe ID
payloadQuery
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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}