diff --git a/mu-graphql.cabal b/mu-graphql.cabal --- a/mu-graphql.cabal +++ b/mu-graphql.cabal @@ -1,5 +1,5 @@ name: mu-graphql -version: 0.5.0.2 +version: 0.5.0.3 synopsis: GraphQL support for Mu description: GraphQL servers and clients for Mu-Haskell cabal-version: >=1.10 @@ -35,7 +35,7 @@ , bytestring >=0.10 && <0.11 , conduit >=1.3.2 && <2 , foldl >=1.4 && <2 - , graphql >=0.11 + , graphql >=1.0 , http-types >=0.12 && <0.13 , list-t >=1.0 && <2 , megaparsec >=8 && <10 diff --git a/src/Mu/GraphQL/Annotations.hs b/src/Mu/GraphQL/Annotations.hs --- a/src/Mu/GraphQL/Annotations.hs +++ b/src/Mu/GraphQL/Annotations.hs @@ -64,7 +64,7 @@ fromGQLValueConst (GQL.ConstEnum s) = pure $ VCEnum $ T.unpack s fromGQLValueConst (GQL.ConstList xs) - = VCList <$> traverse fromGQLValueConst xs + = VCList <$> traverse (fromGQLValueConst . GQL.node) xs fromGQLValueConst (GQL.ConstObject o) = VCObject <$> traverse fromGQLField o where fromGQLField :: GQL.ObjectField GQL.ConstValue @@ -94,7 +94,8 @@ instance KnownSymbol e => ReflectValueConst ('VCEnum e) where reflectValueConst _ = GQL.ConstString $ T.pack $ symbolVal (Proxy @e) instance ReflectValueConstList xs => ReflectValueConst ('VCList xs) where - reflectValueConst _ = GQL.ConstList $ reflectValueConstList (Proxy @xs) + reflectValueConst _ = GQL.ConstList $ + map (`GQL.Node` GQL.Location 0 0) $ reflectValueConstList (Proxy @xs) instance ReflectValueConstObject xs => ReflectValueConst ('VCObject xs) where reflectValueConst _ = GQL.ConstObject $ reflectValueConstObject (Proxy @xs) diff --git a/src/Mu/GraphQL/Quasi.hs b/src/Mu/GraphQL/Quasi.hs --- a/src/Mu/GraphQL/Quasi.hs +++ b/src/Mu/GraphQL/Quasi.hs @@ -11,6 +11,8 @@ -} module Mu.GraphQL.Quasi ( graphql +, Primitives +, graphqlWithExtendedPrimitives , graphql' ) where @@ -35,19 +37,40 @@ graphql :: String -- ^ Name for the 'Package' type, the 'Schema' is derived from it -> FilePath -- ^ Route to the file -> Q [Dec] -graphql name = graphql' (name <> "Schema") name +graphql name = graphql' [] (name <> "Schema") name -- | Imports an GraphQL schema definition from a file. -graphql' :: String -- ^ Name for the 'Schema' type +graphqlWithExtendedPrimitives + :: Primitives + -> String -- ^ Name for the 'Package' type, the 'Schema' is derived from it + -> FilePath -- ^ Route to the file + -> Q [Dec] +graphqlWithExtendedPrimitives prims name = graphql' prims (name <> "Schema") name + +-- | Imports an GraphQL schema definition from a file. +graphql' :: Primitives + -> String -- ^ Name for the 'Schema' type -> String -- ^ Name for the 'Package' type -> FilePath -- ^ Route to the file -> Q [Dec] -graphql' scName svName file = do +graphql' prims scName svName file = do schema <- liftIO $ TIO.readFile file case parseTypeSysDefinition schema of Left e -> fail ("could not parse graphql spec: " ++ show e) - Right p -> graphqlToDecls scName svName p + Right p -> graphqlToDecls (basicPrimitives <> prims) scName svName p +type Primitives = [(GQL.Name, TypeQ)] + +basicPrimitives :: Primitives +basicPrimitives + = [ ("Int", [t|Integer|]) + , ("Float", [t|Double|]) + , ("String", [t|T.Text|]) + , ("Boolean", [t|Bool|]) + , ("UUID", [t|UUID|]) + , ("JSON", [t|JSON.Value|]) + , ("JSONObject", [t|JSON.Object|])] + type TypeMap = HM.HashMap T.Text GQLType type SchemaMap = HM.HashMap T.Text GQL.OperationType @@ -91,15 +114,18 @@ = (name, InputObject) -- | Constructs the GraphQL tree splitting between Schemas and Services. -graphqlToDecls :: String -> String -> [GQL.TypeSystemDefinition] -> Q [Dec] -graphqlToDecls schemaName serviceName allTypes = do +graphqlToDecls + :: Primitives + -> String -> String + -> [GQL.TypeSystemDefinition] -> Q [Dec] +graphqlToDecls prims schemaName serviceName allTypes = do let schemaName' = mkName schemaName serviceName' = mkName serviceName types = [t | GQL.TypeDefinition t <- allTypes] schTypes = [t | t@GQL.SchemaDefinition {} <- allTypes] typeMap = classify types schMap = classifySchema schTypes - rs <- traverse (typeToDec schemaName' typeMap schMap) types + rs <- traverse (typeToDec prims schemaName' typeMap schMap) types let schemaTypes = [x | GQLSchema x <- rs] serviceTypes = [x | GQLService x _ <- rs] defaultDefs = concat [d | GQLService _ d <- rs] @@ -116,17 +142,19 @@ = [t| 'AnnArg $(textToStrLit sn) $(textToStrLit mn) $(textToStrLit an) $(pure dv) |] -- | Reads a GraphQL 'TypeDefinition' and returns a 'Result'. -typeToDec :: Name -> TypeMap -> SchemaMap -> GQL.TypeDefinition -> Q Result -typeToDec _ _ _ GQL.InterfaceTypeDefinition {} +typeToDec :: Primitives + -> Name -> TypeMap -> SchemaMap + -> GQL.TypeDefinition -> Q Result +typeToDec _ _ _ _ GQL.InterfaceTypeDefinition {} = fail "interface types are not supported" -typeToDec _ _ _ (GQL.UnionTypeDefinition _ nm _ (GQL.UnionMemberTypes elts)) = do +typeToDec _ _ _ _ (GQL.UnionTypeDefinition _ nm _ (GQL.UnionMemberTypes elts)) = do selts <- mapM textToStrLit elts GQLService <$> [t| 'OneOf $(textToStrLit nm) $(pure $ typesToList selts) |] <*> pure [] -typeToDec schemaName tm _ (GQL.ScalarTypeDefinition _ s _) = - GQLScalar <$ gqlTypeToType s tm schemaName -typeToDec schemaName tm sm (GQL.ObjectTypeDefinition _ nm _ _ flds) = do +typeToDec prims schemaName tm _ (GQL.ScalarTypeDefinition _ s _) = + GQLScalar <$ gqlTypeToType prims s tm schemaName +typeToDec prims schemaName tm sm (GQL.ObjectTypeDefinition _ nm _ _ flds) = do (fieldInfos, defaults) <- unzip <$> traverse (gqlFieldToType nm) flds GQLService <$> [t| 'Service $(textToStrLit nm) $(pure $ typesToList fieldInfos) |] @@ -162,28 +190,28 @@ defToVConst (GQL.ConstEnum e) = [t| 'VCEnum $(textToStrLit e) |] defToVConst (GQL.ConstList xs) - = [t| 'VCList $(typesToList <$> traverse defToVConst xs) |] + = [t| 'VCList $(typesToList <$> traverse (defToVConst . GQL.node) xs) |] defToVConst (GQL.ConstObject obj) = [t| 'VCObject $(typesToList <$> traverse fromGQLField obj) |] fromGQLField :: GQL.ObjectField GQL.ConstValue -> Q Type fromGQLField (GQL.ObjectField n (GQL.Node v _) _) = [t| ($(textToStrLit n), $(defToVConst v)) |] retToType :: GQL.Type -> Q Type retToType (GQL.TypeNonNull (GQL.NonNullTypeNamed a)) = - [t| $(gqlTypeToType a tm schemaName) |] + [t| $(gqlTypeToType prims a tm schemaName) |] retToType (GQL.TypeNonNull (GQL.NonNullTypeList a)) = [t| 'ListRef $(retToType a) |] retToType (GQL.TypeNamed a) = - [t| 'OptionalRef $(gqlTypeToType a tm schemaName) |] + [t| 'OptionalRef $(gqlTypeToType prims a tm schemaName) |] retToType (GQL.TypeList a) = [t| 'OptionalRef ('ListRef $(retToType a)) |] -typeToDec _ _ _ (GQL.EnumTypeDefinition _ name _ symbols) = +typeToDec _ _ _ _ (GQL.EnumTypeDefinition _ name _ symbols) = GQLSchema <$> [t|'DEnum $(textToStrLit name) $(typesToList <$> traverse gqlChoiceToType symbols)|] where gqlChoiceToType :: GQL.EnumValueDefinition -> Q Type gqlChoiceToType (GQL.EnumValueDefinition _ c _) = [t|'ChoiceDef $(textToStrLit c)|] -typeToDec _ _ _ (GQL.InputObjectTypeDefinition _ name _ fields) = +typeToDec prims _ _ _ (GQL.InputObjectTypeDefinition _ name _ fields) = GQLSchema <$> [t|'DRecord $(textToStrLit name) $(typesToList <$> traverse gqlFieldToType fields)|] where @@ -200,32 +228,24 @@ ginputTypeToType (GQL.TypeList a) = [t| 'TOption ('TList $(ginputTypeToType a)) |] typeToPrimType :: GQL.Name -> Q Type - typeToPrimType "Int" = [t|'TPrimitive Integer|] - typeToPrimType "Float" = [t|'TPrimitive Double|] - typeToPrimType "String" = [t|'TPrimitive T.Text|] - typeToPrimType "Boolean" = [t|'TPrimitive Bool|] - typeToPrimType "ID" = [t|'TPrimitive UUID|] - typeToPrimType "JSON" = [t|'TPrimitive JSON.Value|] - typeToPrimType "JSONObject" = [t|'TPrimitive JSON.Object|] - typeToPrimType nm = [t|'TSchematic $(textToStrLit nm)|] + typeToPrimType nm + = case lookup nm prims of + Just ty -> [t|'TPrimitive $ty|] + Nothing -> [t|'TSchematic $(textToStrLit nm)|] -- For the JSON scalar we follow -- https://github.com/taion/graphql-type-json -gqlTypeToType :: GQL.Name -> TypeMap -> Name -> Q Type -gqlTypeToType "Int" _ _ = [t|'PrimitiveRef Integer|] -gqlTypeToType "Float" _ _ = [t|'PrimitiveRef Double|] -gqlTypeToType "String" _ _ = [t|'PrimitiveRef T.Text|] -gqlTypeToType "Boolean" _ _ = [t|'PrimitiveRef Bool|] -gqlTypeToType "ID" _ _ = [t|'PrimitiveRef UUID|] -gqlTypeToType "JSON" _ _ = [t|'PrimitiveRef JSON.Value|] -gqlTypeToType "JSONObject" _ _ = [t|'PrimitiveRef JSON.Object|] -gqlTypeToType name tm schemaName = - let schemaRef = [t|'SchemaRef $(conT schemaName) $(textToStrLit name)|] - in case HM.lookup name tm of - Just Enum -> schemaRef - Just InputObject -> schemaRef - _ -> [t|'ObjectRef $(textToStrLit name)|] +gqlTypeToType :: Primitives -> GQL.Name -> TypeMap -> Name -> Q Type +gqlTypeToType prims name tm schemaName + = case lookup name prims of + Just ty -> [t|'PrimitiveRef $ty|] + Nothing + -> let schemaRef = [t|'SchemaRef $(conT schemaName) $(textToStrLit name)|] + in case HM.lookup name tm of + Just Enum -> schemaRef + Just InputObject -> schemaRef + _ -> [t|'ObjectRef $(textToStrLit name)|] typesToList :: [Type] -> Type typesToList = foldr (AppT . AppT PromotedConsT) PromotedNilT diff --git a/src/Mu/GraphQL/Query/Parse.hs b/src/Mu/GraphQL/Query/Parse.hs --- a/src/Mu/GraphQL/Query/Parse.hs +++ b/src/Mu/GraphQL/Query/Parse.hs @@ -45,7 +45,8 @@ parseJSON (A.Number n) = case floatingOrInteger n :: Either Double Int32 of Right i -> pure $ GQL.ConstInt i Left m -> pure $ GQL.ConstFloat m - parseJSON (A.Array xs) = GQL.ConstList . F.toList <$> traverse A.parseJSON xs + parseJSON (A.Array xs) = GQL.ConstList . map (`GQL.Node` GQL.Location 0 0) . F.toList + <$> traverse A.parseJSON xs parseJSON (A.Object o) = GQL.ConstObject . fmap toObjFld . HM.toList <$> traverse A.parseJSON o where toObjFld :: (T.Text, GQL.ConstValue) -> GQL.ObjectField GQL.ConstValue @@ -262,7 +263,7 @@ constToValue GQL.ConstNull = GQL.Null constToValue (GQL.ConstEnum n) = GQL.Enum n constToValue (GQL.ConstList n) - = GQL.List $ constToValue <$> n + = GQL.List $ flip map n $ \(GQL.Node x loc) -> GQL.Node (constToValue x) loc constToValue (GQL.ConstObject n) = GQL.Object [ GQL.ObjectField a (GQL.Node (constToValue v) m) l @@ -557,7 +558,7 @@ instance (ParseArg p r) => ParseArg p ('ListRef r) where parseArg vmap aname (GQL.List xs) - = ArgList <$> traverse (parseArg' vmap aname) xs + = ArgList <$> traverse (parseArg' vmap aname . GQL.node) xs parseArg _ aname _ = throwError $ "argument '" <> aname <> "' was not of right type" instance ParseArg p ('PrimitiveRef Bool) where @@ -715,7 +716,7 @@ valueParser _ _ (GQL.String b) = pure $ FPrimitive $ T.unpack b valueParser _ fname _ = throwError $ "field '" <> fname <> "' was not of right type" instance (ValueParser sch r) => ValueParser sch ('TList r) where - valueParser vmap fname (GQL.List xs) = FList <$> traverse (valueParser' vmap fname) xs + valueParser vmap fname (GQL.List xs) = FList <$> traverse (valueParser' vmap fname . GQL.node) xs valueParser _ fname _ = throwError $ "field '" <> fname <> "' was not of right type" instance (ValueParser sch r) => ValueParser sch ('TOption r) where valueParser _ _ GQL.Null = pure $ FOption Nothing @@ -743,7 +744,7 @@ toAesonValue _ (GQL.Boolean b) = pure $ A.Bool b toAesonValue _ GQL.Null = pure A.Null toAesonValue _ (GQL.Enum e) = pure $ A.String e -toAesonValue vm (GQL.List xs) = A.toJSON <$> traverse (toAesonValue vm) xs +toAesonValue vm (GQL.List xs) = A.toJSON <$> traverse (toAesonValue vm . GQL.node) xs toAesonValue vm (GQL.Object xs) = A.Object . HM.fromList <$> traverse (toKeyValuePairs vm) xs class ParseDifferentReturn (p :: Package') (r :: Return Symbol (TypeRef Symbol)) where diff --git a/src/Mu/GraphQL/Server.hs b/src/Mu/GraphQL/Server.hs --- a/src/Mu/GraphQL/Server.hs +++ b/src/Mu/GraphQL/Server.hs @@ -39,6 +39,7 @@ import Control.Monad.Except (MonadIO (..), join, runExceptT) import qualified Data.Aeson as A import Data.Aeson.Text (encodeToLazyText) +import Data.ByteString.Char8 (split) import Data.ByteString.Lazy (fromStrict, toStrict) import Data.Conduit (ConduitT, transPipe) import qualified Data.HashMap.Strict as HM @@ -151,12 +152,12 @@ _ -> toError "Error parsing query" Right POST -> do body <- strictRequestBody req - case lookup hContentType $ requestHeaders req of - Just "application/json" -> + case split ';' <$> lookup hContentType (requestHeaders req) of + Just ("application/json" : _) -> case A.eitherDecode body of Left err -> toError $ T.pack err Right (GraphQLInput qry vars opName) -> execQuery opName vars qry - Just "application/graphql" -> + Just ("application/graphql" : _) -> case decodeUtf8' $ toStrict body of Left err -> toError $ "Could not decode utf8 from body: " <> unpackUnicodeException err Right msg -> execQuery Nothing HM.empty msg