graphql-spice/src/Language/GraphQL/Serialize.hs

{-# LANGUAGE OverloadedStrings #-}

module Language.GraphQL.Serialize
    ( JSON(..)
    ) where

import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Key as Aeson.Key
import qualified Data.Aeson.KeyMap as KeyMap
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Scientific (toBoundedInteger, toRealFloat)
import Data.Text (Text)
import Language.GraphQL.AST (Name)
import Language.GraphQL.Execute.Coerce
import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
import qualified Language.GraphQL.Type as Type

newtype JSON = JSON Aeson.Value

instance Aeson.ToJSON JSON where
    toJSON (JSON value) = value

instance Aeson.FromJSON JSON where
    parseJSON = pure . JSON

instance Serialize JSON where
    serialize (Out.ScalarBaseType scalarType) value
        | Type.ScalarType "Int" _ <- scalarType
        , Int int <- value = Just $ JSON $ Aeson.Number $ fromIntegral int
        | Type.ScalarType "Float" _ <- scalarType
        , Float float <- value = Just $ JSON $ Aeson.toJSON float
        | Type.ScalarType "String" _ <- scalarType
        , String string <- value = Just $ JSON $ Aeson.String string
        | Type.ScalarType "ID" _ <- scalarType
        , String string <- value = Just $ JSON $ Aeson.String string
        | Type.ScalarType "Boolean" _ <- scalarType
        , Boolean boolean <- value = Just $ JSON $ Aeson.Bool boolean
    serialize _ (Enum enum) = Just $ JSON $ Aeson.String enum
    serialize _ (List list) = Just $ JSON $ Aeson.toJSON list
    serialize _ (Object object) = Just
        $ JSON
        $ Aeson.object
        $ toJSONKeyValue <$> OrderedMap.toList object
      where
        toJSONKeyValue (key, value) = (Aeson.Key.fromText key, Aeson.toJSON value)
    serialize _ _ = Nothing
    null = JSON Aeson.Null

instance VariableValue JSON where
    coerceVariableValue _ (JSON Aeson.Null) = Just Type.Null
    coerceVariableValue (In.ScalarBaseType scalarType) (JSON value)
        | (Aeson.String stringValue) <- value = Just $ Type.String stringValue
        | (Aeson.Bool booleanValue) <- value = Just $ Type.Boolean booleanValue
        | (Aeson.Number numberValue) <- value
        , (Type.ScalarType "Float" _) <- scalarType =
            Just $ Type.Float $ toRealFloat numberValue
        | (Aeson.Number numberValue) <- value = -- ID or Int
            Type.Int <$> toBoundedInteger numberValue
    coerceVariableValue (In.EnumBaseType _) (JSON (Aeson.String stringValue)) =
        Just $ Type.Enum stringValue
    coerceVariableValue (In.InputObjectBaseType objectType) (JSON value)
        | (Aeson.Object objectValue) <- value = do
            let (In.InputObjectType _ _ inputFields) = objectType
            (newObjectValue, resultMap) <- foldWithKey objectValue inputFields
            if KeyMap.null newObjectValue
                then Just $ Type.Object resultMap
                else Nothing
      where
        foldWithKey :: Aeson.Object
            -> HashMap Name In.InputField
            -> Maybe (Aeson.Object, HashMap Name Type.Value)
        foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues'
            $ Just (objectValue, HashMap.empty)
        matchFieldValues' :: Text
            -> In.InputField
            -> Maybe (Aeson.Object, HashMap Name Type.Value)
            -> Maybe (Aeson.Object, HashMap Name Type.Value)
        matchFieldValues' _ _ Nothing = Nothing
        matchFieldValues' fieldName inputField (Just (objectValue, resultMap)) =
            let fieldKey = Aeson.Key.fromText fieldName
                In.InputField _ fieldType _ = inputField
                insert = flip (HashMap.insert fieldName) resultMap
                newObjectValue = KeyMap.delete fieldKey objectValue
             in case KeyMap.lookup fieldKey objectValue of
                    Just variableValue -> do
                        coerced <- coerceVariableValue fieldType
                            $ JSON variableValue
                        pure (newObjectValue, insert coerced)
                    Nothing -> Just (objectValue, resultMap)
    coerceVariableValue (In.ListBaseType listType) (JSON value)
        | (Aeson.Array arrayValue) <- value =
            Type.List <$> foldr foldVector (Just []) arrayValue
        | otherwise = coerceVariableValue listType $ JSON value
      where
        foldVector _ Nothing = Nothing
        foldVector variableValue (Just list) = do
            coerced <- coerceVariableValue listType $ JSON variableValue
            pure $ coerced : list 
    coerceVariableValue _ _ = Nothing