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

module Data.Morpheus.Subscriptions.Apollo
  ( ApolloAction (..),
    apolloFormat,
    acceptApolloRequest,
    toApolloResponse,
    Validation,
    ApolloSubscription (..),
    ApolloMessageType (..),
  )
where

import Control.Applicative (Applicative (..))
import Control.Monad.Fail (fail)
import Control.Monad.IO.Class (MonadIO (..))
import Data.Aeson
  ( FromJSON (..),
    ToJSON (..),
    Value (..),
    eitherDecode,
    encode,
    pairs,
    withObject,
    withText,
    (.:),
    (.:?),
    (.=),
  )
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
  ( Eq,
    Show,
    String,
    mempty,
    return,
    ($),
    (.),
  )

type ID = Text

data ApolloSubscription payload = ApolloSubscription
  { apolloId :: Maybe ID,
    apolloType :: ApolloMessageType,
    apolloPayload :: Maybe payload
  }
  deriving (Show, Generic)

instance (FromJSON a) => FromJSON (ApolloSubscription a) where
  parseJSON = withObject "ApolloSubscription" objectParser
    where
      objectParser o =
        ApolloSubscription
          <$> o
          .:? "id"
          <*> o
          .: "type"
          <*> o
          .:? "payload"

data RequestPayload = RequestPayload
  { payloadOperationName :: Maybe FieldName,
    payloadQuery :: Maybe Token,
    payloadVariables :: Maybe Value
  }
  deriving (Show, Generic)

instance FromJSON RequestPayload where
  parseJSON = withObject "ApolloPayload" objectParser
    where
      objectParser o =
        RequestPayload
          <$> o
          .:? "operationName"
          <*> o
          .:? "query"
          <*> o
          .:? "variables"

instance (ToJSON a) => ToJSON (ApolloSubscription a) where
  toEncoding (ApolloSubscription id' type' payload') =
    pairs
      $ encodeMaybe "id" id'
      <> "type"
      .= type'
      <> encodeMaybe "payload" payload'
    where
      -- Messages should only include these fields when they have real values,
      -- for example the MessageAck response should only include the type and optionally
      -- extraneous data in the payload.
      -- Aeson < 2.0.0 has Keys as Text, >= 2.0.0 has Data.Aeson.Key.Key
      -- encodeMaybe :: ToJSON b => Text -> Maybe b -> Series
      encodeMaybe _ Nothing = Prelude.mempty
      encodeMaybe k (Just v) = k .= v

acceptApolloRequest ::
  (MonadIO m) =>
  PendingConnection ->
  m Connection
acceptApolloRequest pending =
  liftIO
    $ acceptRequestWith
      pending
      (acceptApolloSubProtocol (pendingRequest pending))

acceptApolloSubProtocol :: RequestHead -> AcceptRequest
acceptApolloSubProtocol reqHead =
  apolloProtocol (getRequestSubprotocols reqHead)
  where
    apolloProtocol ["graphql-subscriptions"] =
      AcceptRequest (Just "graphql-subscriptions") []
    apolloProtocol ["graphql-ws"] =
      AcceptRequest (Just "graphql-ws") []
    apolloProtocol ["graphql-transport-ws"] =
      AcceptRequest (Just "graphql-transport-ws") []
    apolloProtocol _ = AcceptRequest Nothing []

toApolloResponse :: ApolloMessageType -> Maybe ID -> Maybe GQLResponse -> ByteString
toApolloResponse responseType sid_myb val_myb =
  encode $ ApolloSubscription sid_myb responseType val_myb

data ApolloMessageType
  = GqlConnectionAck
  | GqlConnectionError
  | GqlData
  | GqlError
  | GqlComplete
  | GqlConnectionInit
  | GqlSubscribe
  | GqlPing
  | GqlPong
  deriving (Eq, Show, Generic)

instance FromJSON ApolloMessageType where
  parseJSON = withText "ApolloMessageType" txtParser
    where
      txtParser "connection_ack" = return GqlConnectionAck
      txtParser "connection_error" = return GqlConnectionError
      txtParser "next" = return GqlData
      txtParser "error" = return GqlError
      txtParser "complete" = return GqlComplete
      txtParser "connection_init" = return GqlConnectionInit
      txtParser "subscribe" = return GqlSubscribe
      txtParser "ping" = return GqlPing
      txtParser "pong" = return GqlPong
      txtParser _ = fail "Invalid type encountered."

instance ToJSON ApolloMessageType where
  toEncoding = toEncoding . apolloResponseToProtocolMsgType

apolloResponseToProtocolMsgType :: ApolloMessageType -> Text
apolloResponseToProtocolMsgType GqlConnectionAck = "connection_ack"
apolloResponseToProtocolMsgType GqlConnectionError = "connection_error"
apolloResponseToProtocolMsgType GqlConnectionInit = "connection_init"
apolloResponseToProtocolMsgType GqlData = "next"
apolloResponseToProtocolMsgType GqlError = "error"
apolloResponseToProtocolMsgType GqlComplete = "complete"
apolloResponseToProtocolMsgType GqlSubscribe = "subscribe"
apolloResponseToProtocolMsgType GqlPing = "ping"
apolloResponseToProtocolMsgType GqlPong = "pong"

data ApolloAction
  = SessionStop ID
  | SessionStart ID GQLRequest
  | ConnectionInit
  | Ping

type Validation = Either ByteString

apolloFormat :: ByteString -> Validation ApolloAction
apolloFormat = validateReq . eitherDecode
  where
    validateReq :: Either String (ApolloSubscription RequestPayload) -> Validation ApolloAction
    validateReq = either (Left . pack) validateSub
    -------------------------------------
    validateSub :: ApolloSubscription RequestPayload -> Validation ApolloAction
    validateSub ApolloSubscription {apolloType = GqlConnectionInit} =
      pure ConnectionInit
    validateSub ApolloSubscription {apolloType = GqlPing} =
      pure Ping
    validateSub ApolloSubscription {apolloType = GqlSubscribe, apolloId, apolloPayload} =
      do
        sessionId <- validateSession apolloId
        payload <- validatePayload apolloPayload
        pure $ SessionStart sessionId payload
    validateSub ApolloSubscription {apolloType = GqlComplete, apolloId} =
      SessionStop <$> validateSession apolloId
    validateSub ApolloSubscription {apolloType} =
      Left
        $ "Unknown Request type \""
        <> pack (unpack $ apolloResponseToProtocolMsgType apolloType)
        <> "\"."

    validateSession :: Maybe ID -> Validation ID
    validateSession = maybe (Left "\"id\" was not provided") Right
    -------------------------------------
    validatePayload = maybe (Left "\"payload\" was not provided") validatePayloadContent
    -------------------------------------
    validatePayloadContent
      RequestPayload
        { payloadQuery,
          payloadOperationName = operationName,
          payloadVariables = variables
        } = do
        query <- maybe (Left "\"payload.query\" was not provided") Right payloadQuery
        pure $ GQLRequest {query, operationName, variables}
