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 Aeson.Value where
    coerceVariableValue _ Aeson.Null = Just Type.Null
    coerceVariableValue (In.ScalarBaseType scalarType) 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 _) (Aeson.String stringValue) =
        Just $ Type.Enum stringValue
    coerceVariableValue (In.InputObjectBaseType objectType) 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 variableValue
                        pure (newObjectValue, insert coerced)
                    Nothing -> Just (objectValue, resultMap)
    coerceVariableValue (In.ListBaseType listType) value
        | (Aeson.Array arrayValue) <- value =
            Type.List <$> foldr foldVector (Just []) arrayValue
        | otherwise = coerceVariableValue listType value
      where
        foldVector _ Nothing = Nothing
        foldVector variableValue (Just list) = do
            coerced <- coerceVariableValue listType variableValue
            pure $ coerced : list 
    coerceVariableValue _ _ = Nothing