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

module Data.Morpheus.Types.Internal.Subscription.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
  { apolloId :: Maybe ID,
    apolloType :: Text,
    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 $ "id" .= id' <> "type" .= type' <> "payload" .= payload'

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 _ = AcceptRequest Nothing []

toApolloResponse :: ID -> GQLResponse -> ByteString
toApolloResponse sid val =
  encode $ ApolloSubscription (Just sid) "data" (Just val)

data ApolloAction
  = SessionStop ID
  | SessionStart ID GQLRequest
  | ConnectionInit

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 = "connection_init"} =
      pure ConnectionInit
    validateSub ApolloSubscription {apolloType = "start", apolloId, apolloPayload} =
      do
        sessionId <- validateSession apolloId
        payload <- validatePayload apolloPayload
        pure $ SessionStart sessionId payload
    validateSub ApolloSubscription {apolloType = "stop", apolloId} =
      SessionStop <$> validateSession apolloId
    validateSub ApolloSubscription {apolloType} =
      Left $ "Unknown Request type \"" <> pack (unpack 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}