mu-graphql 0.5.0.2 → 0.5.0.3
raw patch · 5 files changed
+75/−52 lines, 5 filesdep ~graphqlPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: graphql
API changes (from Hackage documentation)
+ Mu.GraphQL.Quasi: graphqlWithExtendedPrimitives :: Primitives -> String -> FilePath -> Q [Dec]
+ Mu.GraphQL.Quasi: type Primitives = [(Name, TypeQ)]
- Mu.GraphQL.Quasi: graphql' :: String -> String -> FilePath -> Q [Dec]
+ Mu.GraphQL.Quasi: graphql' :: Primitives -> String -> String -> FilePath -> Q [Dec]
Files
- mu-graphql.cabal +2/−2
- src/Mu/GraphQL/Annotations.hs +3/−2
- src/Mu/GraphQL/Quasi.hs +60/−40
- src/Mu/GraphQL/Query/Parse.hs +6/−5
- src/Mu/GraphQL/Server.hs +4/−3
mu-graphql.cabal view
@@ -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
src/Mu/GraphQL/Annotations.hs view
@@ -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)
src/Mu/GraphQL/Quasi.hs view
@@ -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
src/Mu/GraphQL/Query/Parse.hs view
@@ -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
src/Mu/GraphQL/Server.hs view
@@ -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