ihp-graphql (empty) → 1.5.0
raw patch · 14 files changed
+1629/−0 lines, 14 filesdep +aesondep +attoparsecdep +base
Dependencies added: aeson, attoparsec, base, bytestring, countable-inflections, hspec, ihp, ihp-graphql, ihp-postgres-parser, megaparsec, postgresql-simple, scientific, text, unordered-containers
Files
- IHP/GraphQL/Compiler.hs +352/−0
- IHP/GraphQL/JSON.hs +42/−0
- IHP/GraphQL/Parser.hs +169/−0
- IHP/GraphQL/SchemaCompiler.hs +218/−0
- IHP/GraphQL/ToText.hs +88/−0
- IHP/GraphQL/Types.hs +125/−0
- LICENSE +21/−0
- README.md +5/−0
- Test/GraphQL/CompilerSpec.hs +146/−0
- Test/GraphQL/ParserSpec.hs +253/−0
- Test/GraphQL/SchemaCompilerSpec.hs +108/−0
- Test/Spec.hs +14/−0
- changelog.md +9/−0
- ihp-graphql.cabal +79/−0
+ IHP/GraphQL/Compiler.hs view
@@ -0,0 +1,352 @@+module IHP.GraphQL.Compiler where++import IHP.Prelude+import IHP.GraphQL.Types++import qualified Database.PostgreSQL.Simple.ToField as PG+import qualified Database.PostgreSQL.Simple.Types as PG+import Prelude (Semigroup (..))+import qualified Data.Text as Text+import qualified Data.HashMap.Strict as HashMap+import Text.Countable (singularize, pluralize)++data SqlQuery = SqlQuery { query :: Text, params :: [PG.Action]}++data QueryPart = QueryPart { sql :: PG.Query, params :: [PG.Action] }++compileDocument :: Variables -> Document -> [(PG.Query, [PG.Action])]+compileDocument (Variables arguments) document@(Document { definitions = (definition:rest) }) =+ case definition of+ ExecutableDefinition { operation = OperationDefinition { operationType = Query } } ->+ [ unpackQueryPart ("SELECT to_json(_root.data) FROM (" <> compileDefinition document definition arguments <> ") AS _root") ]+ ExecutableDefinition { operation = OperationDefinition { operationType = Mutation } } ->+ map unpackQueryPart $ compileMutationDefinition definition arguments+ _ -> error $ "Unsupported definition: " <> show definition+compileDocument _ (Document { definitions = [] }) = error "Empty document"++compileDefinition :: Document -> Definition -> [Argument] -> QueryPart+compileDefinition document ExecutableDefinition { operation = OperationDefinition { operationType = Query, selectionSet } } variables =+ selectionSet+ |> map (compileSelection document variables)+ |> unionAll+compileDefinition _ definition _ = error $ "Expected query definition, got: " <> show definition++compileMutationDefinition :: Definition -> [Argument] -> [QueryPart]+compileMutationDefinition ExecutableDefinition { operation = OperationDefinition { operationType = Mutation, selectionSet } } arguments =+ selectionSet+ |> map (compileMutationSelection arguments)+compileMutationDefinition definition _ = error $ "Expected mutation definition, got: " <> show definition++compileSelection :: Document -> [Argument] -> Selection -> QueryPart+compileSelection _ _ (FragmentSpread {}) = error "Fragment spreads not supported at top level of query selection"+compileSelection document variables field@(Field { alias, name = fieldName, arguments }) =+ ("(SELECT json_build_object(?, json_agg(?.*)) AS data FROM (SELECT " |> withParams [PG.toField nameOrAlias, PG.toField (PG.Identifier subqueryId)])+ <> selectQueryPieces document (PG.toField (PG.Identifier tableName)) field+ <> (" FROM ?" |> withParams [PG.toField (PG.Identifier tableName)])+ <> joins+ <> where_+ <> (") AS ?)" |> withParams [ PG.toField (PG.Identifier subqueryId) ])+ where+ subqueryId = "_" <> fieldName+ nameOrAlias = fromMaybe fieldName alias++ tableName = if isJust idArgument+ then pluralize fieldName+ else fieldName++ where_ :: QueryPart+ where_ = case idArgument of+ Just id -> " WHERE id = ?" |> withParams [valueToSQL $ resolveVariables id variables]+ Nothing -> ""++ idArgument :: Maybe Value+ idArgument = case arguments of+ [Argument { argumentName = "id", argumentValue }] -> Just argumentValue+ _ -> Nothing+++ isJoinField :: Selection -> Bool+ isJoinField Field { selectionSet } = not (null selectionSet)+ isJoinField FragmentSpread {} = False -- TODO: Also support fragment spreads in joined tables++ joins :: QueryPart+ joins = field.selectionSet+ |> filter isJoinField+ |> map (fieldToJoin document tableName)+ |> \case+ [] -> ""+ joins -> " " <> spaceSep joins+++selectQueryPieces :: Document -> PG.Action -> Selection -> QueryPart+selectQueryPieces document tableName field = field.selectionSet+ |> map compileSelection+ |> mconcat+ |> commaSep+ where+ qualified field = if isEmpty (field.selectionSet)+ then "?." |> withParams [tableName]+ else ""++ compileSelection :: Selection -> [QueryPart]+ compileSelection field@(Field {}) = [compileField field]+ compileSelection fragmentSpread@(FragmentSpread {}) = compileFragmentSpread fragmentSpread++ compileField :: Selection -> QueryPart+ compileField field@(Field { alias = Just alias, name }) = qualified field <> "? AS ?" |> withParams [ PG.toField (PG.Identifier (fieldNameToColumnName name)), PG.toField (PG.Identifier alias) ]+ compileField field@(Field { alias = Nothing, name }) =+ let+ columnName = fieldNameToColumnName name+ in+ if columnName /= name+ then qualified field <> "? AS ?" |> withParams [ PG.toField (PG.Identifier (fieldNameToColumnName name)), PG.toField (PG.Identifier name) ]+ else qualified field <> "?" |> withParams [ PG.toField (PG.Identifier (fieldNameToColumnName name)) ]+ compileField _ = error "compileField called with non-Field selection"++ + compileFragmentSpread :: Selection -> [QueryPart]+ compileFragmentSpread FragmentSpread { fragmentName } =+ fragment.selectionSet+ |> map compileSelection+ |> mconcat+ where+ fragment :: Fragment+ fragment = document.definitions+ |> find (\case+ FragmentDefinition (Fragment { name }) -> name == fragmentName+ _ -> False+ )+ |> fromMaybe (error $ "Could not find fragment named " <> fragmentName)+ |> \case+ FragmentDefinition fragment -> fragment+ _ -> error $ "Expected FragmentDefinition for " <> fragmentName+ compileFragmentSpread _ = error "compileFragmentSpread called with non-FragmentSpread"++fieldToJoin :: Document -> Text -> Selection -> QueryPart+fieldToJoin _ _ (FragmentSpread {}) = error "Fragment spreads not supported in joins"+fieldToJoin document rootTableName field@(Field { name }) =+ "LEFT JOIN LATERAL ("+ <> "SELECT ARRAY("+ <> "SELECT to_json(_sub) FROM ("+ <> "SELECT "+ <> selectQueryPieces document foreignTable field+ <> (" FROM ?" |> withParams [foreignTable])+ <> (" WHERE ?.? = ?.?" |> withParams [foreignTable, foreignTableForeignKey, rootTable, rootTablePrimaryKey])+ <> ") AS _sub"+ <> (") AS ?" |> withParams [aliasOrName])+ <> (") ? ON true" |> withParams [aliasOrName])+ where+ foreignTable = PG.toField (PG.Identifier name)+ foreignTableForeignKey = PG.toField (PG.Identifier foreignTableForeignKeyName)+ foreignTableForeignKeyName = rootTableName+ |> singularize+ |> (\name -> name <> "_id")+ rootTable = PG.toField (PG.Identifier rootTableName)+ rootTablePrimaryKey = PG.toField (PG.Identifier "id")++ aliasOrName = PG.toField $ PG.Identifier $+ case field.alias of+ Just alias -> alias+ Nothing -> field.name++compileMutationSelection :: [Argument] -> Selection -> QueryPart+compileMutationSelection _ (FragmentSpread {}) = error "Fragment spreads not supported in mutations"+compileMutationSelection queryArguments field@(Field { alias, name = fieldName, arguments, selectionSet }) = fromMaybe (error ("Invalid mutation: " <> tshow fieldName)) do+ let create = do+ modelName <- Text.stripPrefix "create" fieldName+ pure $ compileSelectionToInsertStatement queryArguments field modelName++ let delete = do+ modelName <- Text.stripPrefix "delete" fieldName+ pure $ compileSelectionToDeleteStatement queryArguments field modelName+ + let update = do+ modelName <- Text.stripPrefix "update" fieldName+ pure $ compileSelectionToUpdateStatement queryArguments field modelName++ create <|> delete <|> update++-- | Turns a @create..@ mutation into a INSERT SQL query+--+-- Input GraphQL document:+--+-- > mutation CreateProject($$project: Project) {+-- > createProject(project: $$project) {+-- > id title+-- > }+-- > }+--+-- Input Arguments:+--+-- > project =+-- > { title: "Hello World"+-- > , userId: "dc984c2f-d91c-4143-9091-400ad2333f83"+-- > }+--+-- Output SQL Query:+--+-- > INSERT INTO projects (user_id, title)+-- > VALUES ('dc984c2f-d91c-4143-9091-400ad2333f83', 'Hello World')+-- > RETURNING json_build_object('id', projects.id, 'title', projects.title)+--+compileSelectionToInsertStatement :: [Argument] -> Selection -> Text -> QueryPart+compileSelectionToInsertStatement queryArguments (FragmentSpread {}) _ = error "Fragment spreads not supported in mutations"+compileSelectionToInsertStatement queryArguments field@(Field { alias, name = fieldName, arguments, selectionSet }) modelName =+ ("INSERT INTO ? (" |> withParams [PG.toField $ PG.Identifier tableName]) <> commaSep columns <> ") VALUES (" <> commaSep values <> ") RETURNING " <> returning+ where+ tableName = modelNameToTableName modelName++ newRecord :: HashMap.HashMap Text Value+ newRecord = case headMay arguments of+ Just (Argument { argumentValue }) -> case resolveVariables argumentValue queryArguments of+ ObjectValue hashMap -> hashMap+ otherwise -> error $ "Expected first argument to " <> fieldName <> " to be an object, got: " <> tshow otherwise+ Nothing -> error $ "Expected first argument to " <> fieldName <> " to be an object, got no arguments"+ + (columns, values) = newRecord+ |> HashMap.toList+ |> map (\(fieldName, value) -> (+ ("?" |> withParams [PG.toField (PG.Identifier (fieldNameToColumnName fieldName))]),+ ("?" |> withParams [valueToSQL value])+ ))+ |> unzip++ returning :: QueryPart+ returning = "json_build_object(" <> returningArgs <> ")"+ returningArgs = selectionSet+ |> map (\case Field { name = fieldName } -> "?, ?.?" |> withParams [PG.toField (fieldNameToColumnName fieldName), PG.toField (PG.Identifier tableName), PG.toField (PG.Identifier (fieldNameToColumnName fieldName))]; _ -> error "Fragment spreads not supported in mutation returning clause")+ |> commaSep++-- | Turns a @update..@ mutation into a UPDATE SQL query+--+-- Input GraphQL document:+--+-- > mutation UpdateProject($projectId: ProjectId, patch: $patch) {+-- > updateProject(id: $projectId, patch: $patch) {+-- > id title+-- > }+-- > }+--+-- Input Arguments:+--+-- > projectId = "df1f54d5-ced6-4f65-8aea-fcd5ea6b9df1"+-- > project =+-- > { title: "Hello World"+-- > , userId: "dc984c2f-d91c-4143-9091-400ad2333f83"+-- > }+--+-- Output SQL Query:+--+-- > UPDATE projects+-- > SET title = 'Hello World', user_id = 'dc984c2f-d91c-4143-9091-400ad2333f83'+-- > WHERE id = 'df1f54d5-ced6-4f65-8aea-fcd5ea6b9df1'+-- > RETURNING json_build_object('id', projects.id, 'title', projects.title)+--+compileSelectionToUpdateStatement :: [Argument] -> Selection -> Text -> QueryPart+compileSelectionToUpdateStatement queryArguments (FragmentSpread {}) _ = error "Fragment spreads not supported in mutations"+compileSelectionToUpdateStatement queryArguments field@(Field { alias, name = fieldName, arguments, selectionSet }) modelName =+ ("UPDATE ? SET " |> withParams [PG.toField $ PG.Identifier tableName]) <> commaSep setValues <> where_ <> " RETURNING " <> returning+ where+ tableName = modelNameToTableName modelName++ where_ = " WHERE id = ?" |> withParams [recordId]++ recordId = case headMay arguments of+ Just Argument { argumentValue } -> valueToSQL (resolveVariables argumentValue queryArguments)+ Nothing -> error $ "Expected first argument to " <> fieldName <> " to be an ID, got no arguments"++ patch :: HashMap.HashMap Text Value+ patch = case headMay <$> tail arguments of+ Just (Just (Argument { argumentValue })) -> case resolveVariables argumentValue queryArguments of+ ObjectValue hashMap -> hashMap+ otherwise -> error $ "Expected second argument to " <> fieldName <> " to be an object, got: " <> tshow otherwise+ _ -> error $ "Expected first argument to " <> fieldName <> " to be an object, got no arguments"+ + setValues = patch+ |> HashMap.toList+ |> map (\(fieldName, value) -> ("? = ?" |> withParams [PG.toField (PG.Identifier (fieldNameToColumnName fieldName)), valueToSQL value]))++ returning :: QueryPart+ returning = "json_build_object(" <> returningArgs <> ")"+ returningArgs = selectionSet+ |> map (\case Field { name = fieldName } -> "?, ?.?" |> withParams [PG.toField (fieldNameToColumnName fieldName), PG.toField (PG.Identifier tableName), PG.toField (PG.Identifier (fieldNameToColumnName fieldName))]; _ -> error "Fragment spreads not supported in mutation returning clause")+ |> commaSep++-- | Turns a @delete..@ mutation into a DELETE SQL query+--+-- Input GraphQL document:+--+-- > mutation DeleteProject($$projectId: ProjectId) {+-- > deleteProject(id: $$project) {+-- > id title+-- > }+-- > }+--+-- Input Arguments:+--+-- > projectId = "dc984c2f-d91c-4143-9091-400ad2333f83"+--+-- Output SQL Query:+--+-- > DELETE FROM projects+-- > WHERE project_id = 'dc984c2f-d91c-4143-9091-400ad2333f83'+-- > RETURNING json_build_object('id', projects.id, 'title', projects.title)+--+compileSelectionToDeleteStatement :: [Argument] -> Selection -> Text -> QueryPart+compileSelectionToDeleteStatement queryArguments (FragmentSpread {}) _ = error "Fragment spreads not supported in mutations"+compileSelectionToDeleteStatement queryArguments field@(Field { alias, name = fieldName, arguments, selectionSet }) modelName =+ ("DELETE FROM ? WHERE id = ?" |> withParams [PG.toField $ PG.Identifier tableName, recordId]) <> " RETURNING " <> returning+ where+ tableName = modelNameToTableName modelName++ recordId = case headMay arguments of+ Just (Argument { argumentValue }) -> valueToSQL (resolveVariables argumentValue queryArguments)+ Nothing -> error $ "Expected first argument to " <> fieldName <> " to be an ID, got no arguments"+ + returning :: QueryPart+ returning = "json_build_object(" <> returningArgs <> ")"+ returningArgs = selectionSet+ |> map (\case Field { name = fieldName } -> "?, ?.?" |> withParams [PG.toField (fieldNameToColumnName fieldName), PG.toField (PG.Identifier tableName), PG.toField (PG.Identifier (fieldNameToColumnName fieldName))]; _ -> error "Fragment spreads not supported in mutation returning clause")+ |> commaSep++valueToSQL :: Value -> PG.Action+valueToSQL (IntValue int) = PG.toField int+valueToSQL (StringValue string) = PG.toField string+valueToSQL (FloatValue double) = PG.toField double+valueToSQL (BooleanValue bool) = PG.toField bool+valueToSQL NullValue = PG.toField PG.Null+valueToSQL (Variable varName) = error $ "Unresolved variable: " <> show varName+valueToSQL value = error $ "Unsupported GraphQL value: " <> show value+++resolveVariables :: Value -> [Argument] -> Value+resolveVariables (Variable varName) arguments =+ arguments+ |> find (\Argument { argumentName } -> argumentName == varName)+ |> \case+ Just Argument { argumentValue } -> argumentValue+ Nothing -> error ("Could not resolve variable " <> varName)+resolveVariables otherwise _ = otherwise++unionAll :: [QueryPart] -> QueryPart+unionAll list = foldl' (\a b -> if a.sql == "" then b else a <> " UNION ALL " <> b) "" list++commaSep :: [QueryPart] -> QueryPart+commaSep list = foldl' (\a b -> if a.sql == "" then b else a <> ", " <> b) "" list++spaceSep :: [QueryPart] -> QueryPart+spaceSep list = foldl' (\a b -> if a.sql == "" then b else a <> " " <> b) "" list++instance Semigroup QueryPart where+ QueryPart { sql = sqlA, params = paramsA } <> QueryPart { sql = sqlB, params = paramsB } = QueryPart { sql = sqlA <> sqlB, params = paramsA <> paramsB }+instance Monoid QueryPart where+ mempty = QueryPart { sql = "", params = [] }++instance IsString QueryPart where+ fromString string = QueryPart { sql = fromString string, params = [] }++unpackQueryPart :: QueryPart -> (PG.Query, [PG.Action])+unpackQueryPart QueryPart { sql, params } = (sql, params)++withParams :: [PG.Action] -> QueryPart -> QueryPart+withParams params (QueryPart { sql, params = existingParams }) = QueryPart { sql, params = existingParams <> params }
+ IHP/GraphQL/JSON.hs view
@@ -0,0 +1,42 @@+module IHP.GraphQL.JSON where++import IHP.Prelude+import qualified IHP.GraphQL.Types as GraphQL+import qualified IHP.GraphQL.Parser as GraphQL+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.KeyMap as Aeson+import qualified Data.Aeson.Key as Aeson+import Data.Aeson ((.:))+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Attoparsec.Text as Attoparsec+import qualified Data.Scientific++instance Aeson.FromJSON GraphQL.GraphQLRequest where+ parseJSON = Aeson.withObject "GraphQLRequest" \v -> do+ query <- v .: "query"+ variables <- (v .: "variables") <|> (pure (GraphQL.Variables []))+ pure GraphQL.GraphQLRequest { query, variables }++instance Aeson.FromJSON GraphQL.Document where+ parseJSON = Aeson.withText "Document" \gql -> do+ case Attoparsec.parseOnly GraphQL.parseDocument gql of+ Left parserError -> fail (cs $ (tshow parserError) <> " while parsing: " <> gql)+ Right statements -> pure statements++instance Aeson.FromJSON GraphQL.Variables where+ parseJSON = Aeson.withObject "Variables" \keyMap -> do+ GraphQL.Variables <$>+ keyMap+ |> Aeson.toList+ |> map (\(argumentName, argumentValue) -> GraphQL.Argument { argumentName = Aeson.toText argumentName, argumentValue = aesonValueToGraphQLValue argumentValue })+ |> pure++aesonValueToGraphQLValue :: Aeson.Value -> GraphQL.Value+aesonValueToGraphQLValue (Aeson.String text) = GraphQL.StringValue text+aesonValueToGraphQLValue (Aeson.Bool bool) = GraphQL.BooleanValue bool+aesonValueToGraphQLValue (Aeson.Object keyMap) = GraphQL.ObjectValue (HashMap.map aesonValueToGraphQLValue (keyMap |> Aeson.toHashMap |> HashMap.mapKeys Aeson.toText))+aesonValueToGraphQLValue Aeson.Null = GraphQL.NullValue+aesonValueToGraphQLValue (Aeson.Number num) = case Data.Scientific.toBoundedInteger num of+ Just int -> GraphQL.IntValue (int :: Int)+ Nothing -> GraphQL.FloatValue (Data.Scientific.toRealFloat num)+aesonValueToGraphQLValue (Aeson.Array _) = error "GraphQL ListValue not yet supported"
+ IHP/GraphQL/Parser.hs view
@@ -0,0 +1,169 @@+{-|+Module: IHP.GraphQL.Parser+Description: Parser for GraphQL requests+Copyright: (c) digitally induced GmbH, 2022+-}+module IHP.GraphQL.Parser where++import IHP.Prelude hiding (Type)+import IHP.GraphQL.Types+import Data.Attoparsec.Text+import qualified Data.HashMap.Strict as HashMap++parseDocument :: Parser Document+parseDocument = Document <$> many1 parseDefinition++parseDefinition :: Parser Definition+parseDefinition = skipSpace >> (executableDefinition <|> parseFragmentDefinition)++executableDefinition :: Parser Definition+executableDefinition = do+ let query = string "query" >> pure Query+ let mutation = string "mutation" >> pure Mutation+ let subscription = string "subscription" >> pure Subscription++ (operationType, name, variableDefinitions) <- option (Query, Nothing, []) do+ operationType <- (query <|> mutation <|> subscription) <?> "OperationType"+ skipSpace+ name <- option Nothing (Just <$> parseName)+ skipSpace+ variableDefinitions <- option [] parseVariableDefinitions+ pure (operationType, name, variableDefinitions)++ selectionSet <- parseSelectionSet+ pure ExecutableDefinition { operation = OperationDefinition { operationType, name, selectionSet, variableDefinitions } }++parseFragmentDefinition :: Parser Definition+parseFragmentDefinition = do+ string "fragment"+ skipSpace+ name <- parseName+ skipSpace+ selectionSet <- parseSelectionSet+ pure (FragmentDefinition Fragment { name, selectionSet })+++parseVariableDefinitions :: Parser [VariableDefinition]+parseVariableDefinitions = do+ char '('+ skipSpace+ variableDefinitions <- parseVariableDefinition `sepBy` (char ',' >> skipSpace)+ skipSpace+ char ')'+ skipSpace+ pure variableDefinitions++parseVariableDefinition :: Parser VariableDefinition+parseVariableDefinition = do+ variableName <- parseVariableName+ skipSpace+ char ':'+ skipSpace+ variableType <- parseType+ pure VariableDefinition { variableName, variableType }++parseSelectionSet :: Parser [Selection]+parseSelectionSet = (do+ char '{'+ skipSpace+ selectionSet <- many1 parseSelection+ skipSpace+ char '}'+ skipSpace+ pure selectionSet) <?> "selectionSet"++parseSelection :: Parser Selection+parseSelection = parseField <|> parseFragmentSpread++parseField :: Parser Selection+parseField = (do+ nameOrAlias <- parseName+ skipSpace+ name' <- option Nothing do+ char ':'+ skipSpace+ Just <$> parseName++ let alias = case name' of+ Just _ -> Just nameOrAlias+ Nothing -> Nothing+ let name = case name' of+ Just name -> name+ Nothing -> nameOrAlias++ skipSpace++ arguments <- option [] parseArguments++ selectionSet <- option [] parseSelectionSet+ pure Field { alias, name, arguments, directives = [], selectionSet }+ ) <?> "field"++parseFragmentSpread :: Parser Selection+parseFragmentSpread = (do+ string "..."+ fragmentName <- parseName+ skipSpace+ pure FragmentSpread { fragmentName }+ ) <?> "FragmentSpread"++parseArguments :: Parser [Argument]+parseArguments = do+ char '('+ skipSpace+ arguments <- parseArgument `sepBy` (char ',' >> skipSpace)+ skipSpace+ char ')'+ skipSpace+ pure arguments++parseArgument :: Parser Argument+parseArgument = do+ argumentName <- parseName+ skipSpace+ char ':'+ skipSpace+ argumentValue <- parseValue+ pure Argument { argumentName, argumentValue }++parseValue :: Parser Value+parseValue = do+ let variable = Variable <$> parseVariableName+ let object = do+ char '{'+ skipSpace+ values <- parseArgument `sepBy` (char ',' >> skipSpace)+ skipSpace+ char '}'+ skipSpace++ let hashMap :: HashMap.HashMap Text Value = values+ |> map (\Argument { argumentName, argumentValue } -> (argumentName, argumentValue))+ |> HashMap.fromList+ pure (ObjectValue hashMap)+ let string = do+ char '"'+ body <- takeTill (== '\"')+ char '"'+ skipSpace+ pure (StringValue body)+ (variable <?> "Variable") <|> (object <?> "Object") <|> (string <?> "String")++parseName :: Parser Text+parseName = takeWhile1 isNameChar <?> "Name"+ where+ isNameChar :: Char -> Bool+ isNameChar !char = (char >= 'A' && char <= 'Z') || (char >= 'a' && char <= 'z') || (char == '_') || (char >= '0' && char <= '9')++parseVariableName :: Parser Text+parseVariableName = (char '$' >> parseName) <?> "Variable"++parseType :: Parser Type+parseType = do+ inner <- parseNamedType+ option inner do+ string "!"+ pure (NonNullType inner)++parseNamedType :: Parser Type+parseNamedType = NamedType <$> parseName
+ IHP/GraphQL/SchemaCompiler.hs view
@@ -0,0 +1,218 @@+module IHP.GraphQL.SchemaCompiler where++import IHP.Prelude hiding (Type)+import IHP.GraphQL.Types++import IHP.Postgres.Types+++type SqlSchema = [Statement]+type GraphQLSchema = [Definition]++sqlSchemaToGraphQLSchema :: SqlSchema -> GraphQLSchema+sqlSchemaToGraphQLSchema statements =+ [ schemaDefinition+ , queryDefinition statements+ , mutationDefinition statements+ ]+ <> customScalars+ <> recordTypes statements+ <> newRecordTypes statements+ <> patchTypes statements++schemaDefinition :: Definition+schemaDefinition =+ TypeSystemDefinition { typeSystemDefinition = SchemaDefinition+ { queryType = NamedType "Query"+ , mutationType = NamedType "Mutation"+ }+ }++customScalars :: [Definition]+customScalars =+ ["UUID", "Timestamp"]+ |> map (TypeSystemDefinition . TypeDefinition . ScalarTypeDefinition)++queryDefinition :: SqlSchema -> Definition+queryDefinition statements = TypeSystemDefinition { typeSystemDefinition = TypeDefinition typeDefinition }+ where+ typeDefinition =+ ObjectTypeDefinition+ { name = "Query"+ , implementsInterfaces = []+ , fieldDefinitions = mconcat $ map statementToQueryField statements+ }+++mutationDefinition :: SqlSchema -> Definition+mutationDefinition statements = TypeSystemDefinition { typeSystemDefinition = TypeDefinition typeDefinition }+ where+ typeDefinition =+ ObjectTypeDefinition+ { name = "Mutation"+ , implementsInterfaces = []+ , fieldDefinitions = mconcat $ map statementToMutationFields statements+ }++statementToQueryField :: Statement -> [FieldDefinition]+statementToQueryField (StatementCreateTable CreateTable { name }) = + [ manyRecordsField ]+ where+ manyRecordsField = FieldDefinition+ { description = Just ("Returns all records from the `" <> name <> "` table")+ , name = lcfirst (tableNameToControllerName name)+ , argumentsDefinition = []+ , type_+ }+ type_ = NonNullType (ListType (NonNullType (NamedType (tableNameToModelName name))))+statementToQueryField _ = []++statementToMutationFields :: Statement -> [FieldDefinition]+statementToMutationFields (StatementCreateTable CreateTable { name }) = + [ createRecord, updateRecord, deleteRecord ]+ where+ createRecord = FieldDefinition+ { description = Nothing+ , name = "create" <> tableNameToModelName name+ , argumentsDefinition =+ [ ArgumentDefinition { name = lcfirst (tableNameToModelName name), argumentType = NonNullType (NamedType ("New" <> tableNameToModelName name)), defaultValue = Nothing }+ ]+ , type_ = NonNullType (NamedType (tableNameToModelName name))+ }+ updateRecord = FieldDefinition+ { description = Nothing+ , name = "update" <> tableNameToModelName name+ , argumentsDefinition =+ [ ArgumentDefinition { name = "id", argumentType = NonNullType (NamedType "ID"), defaultValue = Nothing }+ , ArgumentDefinition { name = "patch", argumentType = NonNullType (NamedType ((tableNameToModelName name) <> "Patch")), defaultValue = Nothing }+ ]+ , type_ = NonNullType (NamedType (tableNameToModelName name))+ }+ deleteRecord = FieldDefinition+ { description = Nothing+ , name = "delete" <> tableNameToModelName name+ , argumentsDefinition =+ [ ArgumentDefinition { name = "id", argumentType = NonNullType (NamedType "ID"), defaultValue = Nothing }+ ]+ , type_ = NonNullType (NamedType (tableNameToModelName name))+ }++statementToMutationFields _ = []++recordTypes :: [Statement] -> [Definition]+recordTypes statements = mapMaybe (recordType statements) statements++recordType :: SqlSchema -> Statement -> Maybe Definition+recordType schema (StatementCreateTable table@(CreateTable { name, columns })) = + Just TypeSystemDefinition { typeSystemDefinition = TypeDefinition typeDefinition }+ where+ typeDefinition =+ ObjectTypeDefinition+ { name = tableNameToModelName name+ , implementsInterfaces = []+ , fieldDefinitions = (map (columnToRecordField table) columns) <> foreignKeyFields+ }+ foreignKeyFields =+ schema+ |> mapMaybe foreignKeyToHasManyField++ foreignKeyToHasManyField (AddConstraint { tableName = fkTable, constraint = ForeignKeyConstraint { columnName = localColumn, referenceTable }}) | referenceTable == name = + Just FieldDefinition+ { description = Nothing+ , name = lcfirst (tableNameToControllerName fkTable)+ , argumentsDefinition = []+ , type_ = NonNullType (ListType (NonNullType (NamedType (tableNameToModelName fkTable))))+ }+ foreignKeyToHasManyField _ = Nothing+recordType _ _ = Nothing++newRecordTypes :: [Statement] -> [Definition]+newRecordTypes statements = mapMaybe (newRecordType statements) statements++newRecordType :: SqlSchema -> Statement -> Maybe Definition+newRecordType schema (StatementCreateTable table@(CreateTable { name, columns })) = + Just TypeSystemDefinition { typeSystemDefinition = TypeDefinition typeDefinition }+ where+ typeDefinition =+ InputObjectTypeDefinition+ { name = "New" <> tableNameToModelName name+ , fieldDefinitions = map (columnToNewRecordField table) columns+ }+newRecordType _ _ = Nothing++patchTypes :: [Statement] -> [Definition]+patchTypes statements = mapMaybe (patchType statements) statements++patchType :: SqlSchema -> Statement -> Maybe Definition+patchType schema (StatementCreateTable table@(CreateTable { name, columns })) = + Just TypeSystemDefinition { typeSystemDefinition = TypeDefinition typeDefinition }+ where+ typeDefinition =+ InputObjectTypeDefinition+ { name = tableNameToModelName name <> "Patch"+ , fieldDefinitions = map (columnToPatchRecordField table) columns+ }+patchType _ _ = Nothing++columnToRecordField :: CreateTable -> Column -> FieldDefinition+columnToRecordField table Column { name, columnType, notNull } = + FieldDefinition+ { description = Nothing+ , name = columnNameToFieldName name+ , argumentsDefinition = []+ , type_ = + if isPrimaryKey+ then NonNullType (NamedType "ID")+ else (if notNull+ then NonNullType+ else \v -> v) $ postgresTypeToGraphQLType columnType+ }+ where+ primaryKeyColumns = table.primaryKeyConstraint.primaryKeyColumnNames+ isPrimaryKey = name `elem` primaryKeyColumns++columnToNewRecordField :: CreateTable -> Column -> FieldDefinition+columnToNewRecordField table column@(Column { defaultValue = Just _ }) = removeNonNullFromFieldDefinition (columnToRecordField table column)+ where+columnToNewRecordField table column = columnToRecordField table column++columnToPatchRecordField :: CreateTable -> Column -> FieldDefinition+columnToPatchRecordField table column = removeNonNullFromFieldDefinition (columnToRecordField table column)++removeNonNull :: Type -> Type+removeNonNull (NonNullType type_) = type_+removeNonNull type_ = type_++removeNonNullFromFieldDefinition :: FieldDefinition -> FieldDefinition+removeNonNullFromFieldDefinition fieldDefinition = fieldDefinition { type_ = removeNonNull fieldDefinition.type_ }++postgresTypeToGraphQLType :: PostgresType -> Type+postgresTypeToGraphQLType PText = NamedType "String"+postgresTypeToGraphQLType PUUID = NamedType "UUID"+postgresTypeToGraphQLType PInt = NamedType "Int"+postgresTypeToGraphQLType PSmallInt = NamedType "Int"+postgresTypeToGraphQLType PBigInt = NamedType "BigInt"+postgresTypeToGraphQLType PBoolean = NamedType "Boolean"+postgresTypeToGraphQLType PTimestamp = NamedType "Timestamp"+postgresTypeToGraphQLType PTimestampWithTimezone = NamedType "Timestamp"+postgresTypeToGraphQLType PReal = NamedType "Float"+postgresTypeToGraphQLType PDouble = NamedType "Float"+postgresTypeToGraphQLType PPoint = NamedType "Point"+postgresTypeToGraphQLType PPolygon = error "todo"+postgresTypeToGraphQLType PDate = NamedType "Date"+postgresTypeToGraphQLType PBinary = NamedType "String"+postgresTypeToGraphQLType PTime = NamedType "Time"+postgresTypeToGraphQLType (PNumeric _ _) = NamedType "Float"+postgresTypeToGraphQLType (PVaryingN _) = NamedType "String"+postgresTypeToGraphQLType (PCharacterN _) = NamedType "String"+postgresTypeToGraphQLType PSingleChar = NamedType "String"+postgresTypeToGraphQLType PSerial = NamedType "Int"+postgresTypeToGraphQLType PBigserial = NamedType "BigInt"+postgresTypeToGraphQLType PJSONB = NamedType "JSON"+postgresTypeToGraphQLType PInet = NamedType "IPv4"+postgresTypeToGraphQLType PTSVector = NamedType "String"+postgresTypeToGraphQLType (PArray type_) = ListType (postgresTypeToGraphQLType type_)+postgresTypeToGraphQLType PTrigger = error "Trigger cannot be converted to a GraphQL type"+postgresTypeToGraphQLType PEventTrigger = error "Trigger cannot be converted to a GraphQL type"+postgresTypeToGraphQLType (PInterval _) = NamedType "String"+postgresTypeToGraphQLType (PCustomType theType) = NamedType "String"
+ IHP/GraphQL/ToText.hs view
@@ -0,0 +1,88 @@+module IHP.GraphQL.ToText where++import IHP.Prelude hiding (Type)+import IHP.GraphQL.Types+import qualified Data.Text as Text++toText :: [Definition] -> Text+toText definitions =+ definitions+ |> map definitionToText+ |> Text.intercalate "\n" ++definitionToText :: Definition -> Text+definitionToText ExecutableDefinition { operation } = operationToText operation+definitionToText TypeSystemDefinition { typeSystemDefinition } = typeSystemDefinitionToText typeSystemDefinition+definitionToText TypeSystemExtension = "# type system extension (not implemented)"+definitionToText (FragmentDefinition _) = "# fragment definition (not implemented)"++operationToText :: OperationDefinition -> Text+operationToText operation = type_+ where+ type_ = case operation.operationType of+ Query -> "query"+ Mutation -> "mutation"+ Subscription -> "subscription"++typeSystemDefinitionToText :: TypeSystemDefinition -> Text+typeSystemDefinitionToText SchemaDefinition { queryType, mutationType } = [trimming|+ schema {+ query: $query+ mutation: $mutation+ }+|]+ where+ query = typeToText queryType+ mutation = typeToText mutationType++typeSystemDefinitionToText (TypeDefinition typeDefinition) = typeDefinitionToText typeDefinition+typeSystemDefinitionToText DirectiveDefinition = "# directive definition (not implemented)"++typeDefinitionToText ScalarTypeDefinition { name } = [trimming|+ scalar $name+|]+typeDefinitionToText ObjectTypeDefinition { name, implementsInterfaces, fieldDefinitions } = [trimming|+ type $name {+ $fields+ }+|]+ where+ fields = fieldDefinitions+ |> map fieldDefinitionToText+ |> Text.intercalate "\n"+typeDefinitionToText InputObjectTypeDefinition { name, fieldDefinitions } = [trimming|+ input $name {+ $fields+ }+|]+ where+ fields = fieldDefinitions+ |> map fieldDefinitionToText+ |> Text.intercalate "\n"+typeDefinitionToText InterfaceTypeDefinition = "# interface type definition (not implemented)"+typeDefinitionToText UnionTypeDefinition = "# union type definition (not implemented)"+typeDefinitionToText EnumTypeDefinition = "# enum type definition (not implemented)"++fieldDefinitionToText :: FieldDefinition -> Text+fieldDefinitionToText FieldDefinition { description, name, argumentsDefinition, type_ } =+ descriptionBlock+ <> [trimming|+ $name$arguments: $renderedType+ |]+ where+ renderedType = typeToText type_+ descriptionBlock = case description of+ Just text -> [trimming| "$text"|] <> "\n"+ Nothing -> ""+ arguments =+ case argumentsDefinition of+ [] -> ""+ argumentDefinitions -> "(" <> Text.intercalate ", " (map argumentDefinitionToText argumentDefinitions) <> ")"++typeToText :: Type -> Text+typeToText (NamedType name) = name+typeToText (ListType type_) = "[" <> typeToText type_ <> "]"+typeToText (NonNullType type_) = typeToText type_ <> "!"++argumentDefinitionToText :: ArgumentDefinition -> Text+argumentDefinitionToText ArgumentDefinition { name, argumentType } = name <> ": " <> typeToText argumentType
+ IHP/GraphQL/Types.hs view
@@ -0,0 +1,125 @@+module IHP.GraphQL.Types where++import IHP.Prelude hiding (Type)+import qualified Data.HashMap.Strict as HashMap++data GraphQLRequest = GraphQLRequest+ { query :: !Document+ , variables :: !Variables+ }++-- https://spec.graphql.org/June2018/#sec-Appendix-Grammar-Summary.Document++newtype Document = Document { definitions :: [Definition] }+ deriving (Eq, Show)++data Definition+ = ExecutableDefinition { operation :: !OperationDefinition }+ | TypeSystemDefinition { typeSystemDefinition :: !TypeSystemDefinition }+ | TypeSystemExtension+ | FragmentDefinition !Fragment+ deriving (Eq, Show)++data TypeSystemDefinition+ = SchemaDefinition+ { queryType :: !Type+ , mutationType :: !Type+ }+ | TypeDefinition !TypeDefinition+ | DirectiveDefinition+ deriving (Eq, Show)++data TypeDefinition+ = ScalarTypeDefinition { name :: !Text }+ | ObjectTypeDefinition { name :: !Text, implementsInterfaces :: [Type], fieldDefinitions :: ![FieldDefinition] }+ | InterfaceTypeDefinition+ | UnionTypeDefinition+ | EnumTypeDefinition+ | InputObjectTypeDefinition { name :: !Text, fieldDefinitions :: ![FieldDefinition] }+ deriving (Eq, Show)++data OperationDefinition+ = OperationDefinition+ { operationType :: !OperationType+ , name :: !(Maybe Text)+ , selectionSet :: ![Selection]+ , variableDefinitions :: ![VariableDefinition]+ } deriving (Eq, Show)++data FieldDefinition+ = FieldDefinition+ { description :: !(Maybe Text)+ , name :: !Text+ , argumentsDefinition :: ![ArgumentDefinition]+ , type_ :: Type+ } deriving (Eq, Show)++data ArgumentDefinition+ = ArgumentDefinition+ { name :: !Text+ , argumentType :: Type+ , defaultValue :: Maybe Value+ }+ deriving (Eq, Show)++data Selection+ = Field+ { alias :: !(Maybe Text)+ , name :: !Text+ , arguments :: ![Argument]+ , directives :: !Directives+ , selectionSet :: ![Selection]+ }+ | FragmentSpread+ { fragmentName :: !Text }+ deriving (Eq, Show)++type Directives = [Text]++data Fragment+ = Fragment+ { name :: Text+ , selectionSet :: ![Selection]+ }+ deriving (Eq, Show)++data OperationType+ = Query+ | Mutation+ | Subscription+ deriving (Eq, Show)++data VariableDefinition+ = VariableDefinition+ { variableName :: !Text+ , variableType :: !Type+ } deriving (Eq, Show)++data Argument+ = Argument+ { argumentName :: !Text+ , argumentValue :: !Value+ } deriving (Eq, Show)++-- | http://spec.graphql.org/June2018/#Value+data Value+ = Variable !Text+ | IntValue !Int+ | FloatValue !Double+ | StringValue !Text+ | BooleanValue !Bool+ | NullValue+ | EnumValue+ | ListValue+ | ObjectValue (HashMap.HashMap Text Value)+ deriving (Eq, Show)++newtype Variables+ = Variables [Argument]+ deriving (Eq, Show)++data Type+ = NamedType !Text+ | ListType !Type+ | NonNullType !Type+ deriving (Eq, Show)
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2020 digitally induced GmbH++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,5 @@+# ihp-graphql++GraphQL support for [IHP](https://ihp.digitallyinduced.com/) applications.++See the [IHP Guide](https://ihp.digitallyinduced.com/Guide/) for documentation.
+ Test/GraphQL/CompilerSpec.hs view
@@ -0,0 +1,146 @@+{-|+Module: Test.GraphQL.CompilerSpec+Copyright: (c) digitally induced GmbH, 2022+-}+module Test.GraphQL.CompilerSpec where++import Test.Hspec+import IHP.Prelude+import qualified IHP.GraphQL.Compiler as Compiler+import IHP.GraphQL.Types+import Test.GraphQL.ParserSpec (parseGQL, parseValue)+import qualified Database.PostgreSQL.Simple.Types as PG+import qualified Database.PostgreSQL.Simple.ToField as PG+import qualified Data.Text as Text+import qualified Data.ByteString.Builder++tests = do+ describe "The GraphQL Compiler" do+ it "should compile a trivial selection" do+ compileGQL "{ users { id email } }" [] `shouldBe` "SELECT to_json(_root.data) FROM ((SELECT json_build_object('users', json_agg(_users.*)) AS data FROM (SELECT users.id, users.email FROM users) AS _users)) AS _root"++ it "should compile a trivial selection with an alias" do+ compileGQL "{ users { id userEmail: email } }" [] `shouldBe` [trimming|+ SELECT to_json(_root.data) FROM ((SELECT json_build_object('users', json_agg(_users.*)) AS data FROM (SELECT users.id, users.email AS "userEmail" FROM users) AS _users)) AS _root+ |]+ it "should compile a trivial selection with a fragment spread" do+ let query = [trimming|+ query {+ users {+ id+ ...userFragment+ }+ }++ fragment userFragment { email }+ |]+ compileGQL query [] `shouldBe` [trimming|+ SELECT to_json(_root.data) FROM ((SELECT json_build_object('users', json_agg(_users.*)) AS data FROM (SELECT users.id, users.email FROM users) AS _users)) AS _root+ |]+ + it "should compile a selection set accessing multiple tables" do+ compileGQL "{ users { id } tasks { id title } }" [] `shouldBe` [trimming|+ SELECT to_json(_root.data) FROM ((SELECT json_build_object('users', json_agg(_users.*)) AS data FROM (SELECT users.id FROM users) AS _users) UNION ALL (SELECT json_build_object('tasks', json_agg(_tasks.*)) AS data FROM (SELECT tasks.id, tasks.title FROM tasks) AS _tasks)) AS _root+ |]+ it "should compile a named query" do+ compileGQL "query GetUsers { users { id } tasks { id title } }" [] `shouldBe` [trimming|+ SELECT to_json(_root.data) FROM ((SELECT json_build_object('users', json_agg(_users.*)) AS data FROM (SELECT users.id FROM users) AS _users) UNION ALL (SELECT json_build_object('tasks', json_agg(_tasks.*)) AS data FROM (SELECT tasks.id, tasks.title FROM tasks) AS _tasks)) AS _root+ |]+ it "should compile a 'user(id: $id)' selection" do+ compileGQL "{ user(id: \"dde8fd2c-4941-4262-a8e0-cc4cd40bacba\") { id } }" [] `shouldBe` [trimming|+ SELECT to_json(_root.data) FROM ((SELECT json_build_object('user', json_agg(_user.*)) AS data FROM (SELECT users.id FROM users WHERE id = 'dde8fd2c-4941-4262-a8e0-cc4cd40bacba') AS _user)) AS _root+ |]+ it "should compile a single selection with a one-to-many relationship" do+ compileGQL "{ user(id: \"40f1dbb4-403c-46fd-8062-fcf5362f2154\") { id email tasks { id title } } }" [] `shouldBe` [trimming|+ SELECT to_json(_root.data) FROM ((SELECT json_build_object('user', json_agg(_user.*)) AS data FROM (SELECT users.id, users.email, tasks FROM users LEFT JOIN LATERAL (SELECT ARRAY(SELECT to_json(_sub) FROM (SELECT tasks.id, tasks.title FROM tasks WHERE tasks.user_id = users.id) AS _sub) AS tasks) tasks ON true WHERE id = '40f1dbb4-403c-46fd-8062-fcf5362f2154') AS _user)) AS _root+ |]+ it "should compile a multi selection with a one-to-many relationship" do+ compileGQL "{ users { id email tasks { id title } } }" [] `shouldBe` [trimming|+ SELECT to_json(_root.data) FROM ((SELECT json_build_object('users', json_agg(_users.*)) AS data FROM (SELECT users.id, users.email, tasks FROM users LEFT JOIN LATERAL (SELECT ARRAY(SELECT to_json(_sub) FROM (SELECT tasks.id, tasks.title FROM tasks WHERE tasks.user_id = users.id) AS _sub) AS tasks) tasks ON true) AS _users)) AS _root+ |]+ it "should compile a create mutation" do+ let mutation = [trimming|+ mutation CreateProject($$project: Project) {+ createProject(project: $$project) {+ id title+ }+ }+ |]+ let arguments = [+ Argument+ { argumentName = "project"+ , argumentValue = parseValue [trimming|+ { title: "Hello World"+ , userId: "dc984c2f-d91c-4143-9091-400ad2333f83"+ }+ |] }+ ]+ compileGQL mutation arguments `shouldBe` [trimming|+ INSERT INTO projects (user_id, title) VALUES ('dc984c2f-d91c-4143-9091-400ad2333f83', 'Hello World') RETURNING json_build_object('id', projects.id, 'title', projects.title)+ |]+ it "should compile a delete mutation" do+ let mutation = [trimming|+ mutation DeleteProject($$projectId: ProjectId) {+ deleteProject(id: $$projectId) {+ id title+ }+ }+ |]+ let arguments = [+ Argument+ { argumentName = "projectId"+ , argumentValue = parseValue [trimming|+ "dc984c2f-d91c-4143-9091-400ad2333f83"+ |] }+ ]+ compileGQL mutation arguments `shouldBe` [trimming|+ DELETE FROM projects WHERE id = 'dc984c2f-d91c-4143-9091-400ad2333f83' RETURNING json_build_object('id', projects.id, 'title', projects.title)+ |]+ it "should compile a update mutation" do+ let mutation = [trimming|+ mutation UpdateProject($$projectId: ProjectId, $$patch: ProjectPatch) {+ updateProject(id: $$projectId, set: $$patch) {+ id title+ }+ }+ |]+ let arguments = [+ Argument+ { argumentName = "patch"+ , argumentValue = parseValue [trimming|+ { title: "Hello World"+ , userId: "dc984c2f-d91c-4143-9091-400ad2333f83"+ }+ |] }+ , Argument+ { argumentName = "projectId"+ , argumentValue = parseValue [trimming|"df1f54d5-ced6-4f65-8aea-fcd5ea6b9df1"|] }+ ]+ compileGQL mutation arguments `shouldBe` [trimming|+ UPDATE projects SET user_id = 'dc984c2f-d91c-4143-9091-400ad2333f83', title = 'Hello World' WHERE id = 'df1f54d5-ced6-4f65-8aea-fcd5ea6b9df1' RETURNING json_build_object('id', projects.id, 'title', projects.title)+ |]++compileGQL gql arguments = gql+ |> parseGQL+ |> Compiler.compileDocument (Variables arguments)+ |> map substituteParams+ |> intercalate "\n"++substituteParams :: (PG.Query, [PG.Action]) -> Text+substituteParams (PG.Query query, params) = + query+ |> cs+ |> Text.splitOn "?"+ |> \q -> zip q (params <> (repeat (PG.Plain "")))+ |> foldl' foldQuery ""+ where+ foldQuery acc (query, action) = acc <> query <> actionToText action++ actionToText (PG.Plain plain) = cs (Data.ByteString.Builder.toLazyByteString plain)+ actionToText (PG.Escape escape) = "'" <> cs escape <> "'"+ actionToText (PG.EscapeIdentifier escape) | cs escape == Text.toLower (cs escape) = cs escape+ actionToText (PG.EscapeIdentifier escape) = "\"" <> cs escape <> "\""+ actionToText (PG.EscapeByteA bytes) = cs bytes+ actionToText (PG.Many actions) = mconcat (map actionToText actions)++
+ Test/GraphQL/ParserSpec.hs view
@@ -0,0 +1,253 @@+{-|+Module: Test.GraphQL.ParserSpec+Copyright: (c) digitally induced GmbH, 2022+-}+module Test.GraphQL.ParserSpec where++import Test.Hspec+import IHP.Prelude+import qualified IHP.GraphQL.Parser as Parser+import IHP.GraphQL.Types+import qualified Data.Attoparsec.Text as Attoparsec+import Data.HashMap.Strict as HashMap++tests = do+ describe "The GraphQL Parser" do+ it "should parse a trivial selection" do+ parseGQL "{ user }" `shouldBe` Document+ { definitions =+ [ ExecutableDefinition+ { operation = OperationDefinition+ { operationType = Query+ , name = Nothing+ , variableDefinitions = []+ , selectionSet = [+ Field { alias = Nothing, name = "user", arguments = [], directives = [], selectionSet = [] }+ ] }+ }+ ]+ }++ it "should parse nested selections" do+ parseGQL "{ user { tasks { id name createdAt } } }" `shouldBe` Document+ { definitions =+ [ ExecutableDefinition+ { operation = OperationDefinition+ { operationType = Query+ , name = Nothing+ , variableDefinitions = []+ , selectionSet = [+ (field "user") { selectionSet = [+ (field "tasks") { selectionSet =+ [ field "id"+ , field "name"+ , field "createdAt"+ ] }+ ] }+ ] }+ }+ ]+ }++ it "should parse a trivial selection with an alias" do+ parseGQL "{ user { userId: id } }" `shouldBe` Document+ { definitions =+ [ ExecutableDefinition+ { operation = OperationDefinition+ { operationType = Query+ , name = Nothing+ , variableDefinitions = []+ , selectionSet = [+ Field { alias = Nothing, name = "user", arguments = [], directives = [], selectionSet = [+ (field "id") { alias = "userId" }+ ] }+ ] }+ }+ ]+ }++ it "should parse a multi selection with an alias" do+ parseGQL "{ users { id } tasks { id } }" `shouldBe` Document+ { definitions =+ [ ExecutableDefinition+ { operation = OperationDefinition+ { operationType = Query+ , name = Nothing+ , variableDefinitions = []+ , selectionSet = [+ (field "users") { selectionSet = [ field "id" ] },+ (field "tasks") { selectionSet = [ field "id" ] }+ ] }+ }+ ]+ }++ it "should parse a mutation" do+ let query = [trimming|+ mutation CreateProject($$project: Project) {+ createProject(project: $$project) {+ id title+ }+ }+ |]+ parseGQL query `shouldBe` Document+ { definitions =+ [ ExecutableDefinition+ { operation = OperationDefinition+ { operationType = Mutation+ , name = "CreateProject"+ , variableDefinitions = [VariableDefinition { variableName = "project", variableType = NamedType "Project" }]+ , selectionSet = [+ (field "createProject")+ { arguments = [Argument { argumentName = "project", argumentValue = Variable "project" }]+ , selectionSet = [ field "id", field "title" ]+ }+ ] }+ }+ ]+ }++ it "should parse a unnamed mutation" do+ let query = [trimming|+ mutation ($$project: Project) {+ createProject(project: $$project) {+ id title+ }+ }+ |]+ parseGQL query `shouldBe` Document+ { definitions =+ [ ExecutableDefinition+ { operation = OperationDefinition+ { operationType = Mutation+ , name = Nothing+ , variableDefinitions = [VariableDefinition { variableName = "project", variableType = NamedType "Project" }]+ , selectionSet = [+ (field "createProject")+ { arguments = [Argument { argumentName = "project", argumentValue = Variable "project" }]+ , selectionSet = [ field "id", field "title" ]+ }+ ] }+ }+ ]+ }+ it "should parse a mutation starting with lots of whitespace" do+ let query = cs [plain|+ mutation {+ createTask(task: {+ title: "Hello World",+ body: "hello world",+ userId: "40f1dbb4-403c-46fd-8062-fcf5362f2154"+ }) {+ id+ }+ }+ |]+ parseGQL query `shouldBe` Document+ { definitions =+ [ ExecutableDefinition+ { operation = OperationDefinition+ { operationType = Mutation+ , name = Nothing+ , variableDefinitions = []+ , selectionSet = [+ (field "createTask")+ { arguments = [+ Argument+ { argumentName = "task"+ , argumentValue = ObjectValue (HashMap.fromList+ [ ("body", StringValue "hello world")+ , ("userId", StringValue "40f1dbb4-403c-46fd-8062-fcf5362f2154")+ , ("title", StringValue "Hello World")+ ]+ ) }+ ]+ , selectionSet = [ field "id" ]+ }+ ] }+ }+ ]+ }++ it "should parse a fragment" do+ let query = cs [plain|+ fragment user {+ id email+ }+ |]+ parseGQL query `shouldBe` Document+ { definitions =+ [ FragmentDefinition (Fragment { name = "user", selectionSet = [ field "id", field "email" ] })+ ]+ }++ it "should parse a fragment spread" do+ let query = cs [plain|+ query { users { id ...userFragment } }+ fragment userFragment { email }+ |]+ parseGQL query `shouldBe` Document+ { definitions =+ [ ExecutableDefinition+ { operation = OperationDefinition+ { operationType = Query+ , name = Nothing+ , selectionSet = [ (field "users") { selectionSet = [field "id", FragmentSpread {fragmentName = "userFragment"} ] } ]+ , variableDefinitions = []+ }+ }+ , FragmentDefinition (Fragment+ { name = "userFragment"+ , selectionSet = [field "email"]+ }+ )+ ]+ }+ it "should parse a mutation with a non null type argument" do+ let query = cs [plain|+ mutation createUser ($user: NewUser!) {+ createUser (user: $user) {+ id+ email+ passwordHash+ lockedAt+ failedLoginAttempts+ tasks {+ id+ title+ body+ userId+ }+ }+ }+ |]+ parseGQL query `shouldBe` Document+ { definitions =+ [ ExecutableDefinition { operation = OperationDefinition+ { operationType = Mutation+ , name = "createUser"+ , selectionSet = [+ (field "createUser")+ { arguments = [Argument { argumentName = "user", argumentValue = Variable "user" } ]+ , selectionSet = [field "id", field "email", field "passwordHash", field "lockedAt", field "failedLoginAttempts", (field "tasks") { selectionSet = [field "id", field "title", field "body", field "userId"] }]+ }+ ]+ , variableDefinitions = [VariableDefinition {variableName = "user", variableType = NonNullType (NamedType "NewUser")}]}}]}++ describe "parseName" do+ it "should accept letters" do+ runParser Parser.parseName "id" `shouldBe` "id"++field name = Field { alias = Nothing, name, arguments = [], directives = [], selectionSet = [] }++parseGQL :: Text -> Document+parseGQL gql = runParser Parser.parseDocument gql++parseValue :: Text -> Value+parseValue expression = runParser Parser.parseValue expression++runParser parser text =+ case Attoparsec.parseOnly parser text of+ Left parserError -> error (cs $ tshow parserError)+ Right statements -> statements+
+ Test/GraphQL/SchemaCompilerSpec.hs view
@@ -0,0 +1,108 @@+{-|+Module: Test.GraphQL.SchemaCompilerSpec+Copyright: (c) digitally induced GmbH, 2022+-}+module Test.GraphQL.SchemaCompilerSpec where++import Test.Hspec+import IHP.Prelude++import qualified IHP.GraphQL.ToText as GraphQL+import qualified IHP.GraphQL.SchemaCompiler as GraphQL+import qualified Text.Megaparsec as Megaparsec+import qualified IHP.Postgres.Parser as Parser+import IHP.Postgres.Types++tests = do+ describe "IHP.GraphQL.SchemaCompiler" do+ it "should compile a basic SQL Schema to a GraphQL Schema" do+ let sqlSchema = parseSqlStatements [trimming|+ -- Your database schema. Use the Schema Designer at http://localhost:8001/ to add some tables.+ CREATE TABLE users (+ id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+ email TEXT NOT NULL,+ password_hash TEXT NOT NULL,+ locked_at TIMESTAMP WITH TIME ZONE DEFAULT NULL,+ failed_login_attempts INT DEFAULT 0 NOT NULL+ );+ CREATE TABLE tasks (+ id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,+ title TEXT NOT NULL,+ body TEXT NOT NULL,+ user_id UUID NOT NULL+ );+ CREATE POLICY "Allow access" ON tasks USING (true) WITH CHECK (true);+ ALTER TABLE tasks ENABLE ROW LEVEL SECURITY;+ CREATE INDEX tasks_user_id_index ON tasks (user_id);+ ALTER TABLE tasks ADD CONSTRAINT tasks_ref_user_id FOREIGN KEY (user_id) REFERENCES users (id) ON DELETE NO ACTION;+ |]+ let graphQLSchema = [trimming|+ schema {+ query: Query+ mutation: Mutation+ }+ type Query {+ "Returns all records from the `users` table"+ users: [User!]!+ "Returns all records from the `tasks` table"+ tasks: [Task!]!+ }+ type Mutation {+ createUser(user: NewUser!): User!+ updateUser(id: ID!, patch: UserPatch!): User!+ deleteUser(id: ID!): User!+ createTask(task: NewTask!): Task!+ updateTask(id: ID!, patch: TaskPatch!): Task!+ deleteTask(id: ID!): Task!+ }+ scalar UUID+ scalar Timestamp+ type User {+ id: ID!+ email: String!+ passwordHash: String!+ lockedAt: Timestamp+ failedLoginAttempts: Int!+ tasks: [Task!]!+ }+ type Task {+ id: ID!+ title: String!+ body: String!+ userId: UUID!+ }+ input NewUser {+ id: ID+ email: String!+ passwordHash: String!+ lockedAt: Timestamp+ failedLoginAttempts: Int+ }+ input NewTask {+ id: ID+ title: String!+ body: String!+ userId: UUID!+ }+ input UserPatch {+ id: ID+ email: String+ passwordHash: String+ lockedAt: Timestamp+ failedLoginAttempts: Int+ }+ input TaskPatch {+ id: ID+ title: String+ body: String+ userId: UUID+ }+ |]++ GraphQL.toText (GraphQL.sqlSchemaToGraphQLSchema sqlSchema) `shouldBe` graphQLSchema++parseSqlStatements :: Text -> [Statement]+parseSqlStatements sql =+ case Megaparsec.runParser Parser.parseDDL "input" sql of+ Left parserError -> error (cs $ Megaparsec.errorBundlePretty parserError) -- For better error reporting in hspec+ Right statements -> statements
+ Test/Spec.hs view
@@ -0,0 +1,14 @@+module Main where++import Prelude+import Test.Hspec++import qualified Test.GraphQL.ParserSpec+import qualified Test.GraphQL.CompilerSpec+import qualified Test.GraphQL.SchemaCompilerSpec++main :: IO ()+main = hspec do+ Test.GraphQL.ParserSpec.tests+ Test.GraphQL.CompilerSpec.tests+ Test.GraphQL.SchemaCompilerSpec.tests
+ changelog.md view
@@ -0,0 +1,9 @@+# Changelog for `ihp-graphql`++## v1.5.0++- Fix incomplete pattern matches for GHC 9.12 compatibility++## v1.3.0++- Initial release as a standalone package
+ ihp-graphql.cabal view
@@ -0,0 +1,79 @@+cabal-version: 2.2+name: ihp-graphql+version: 1.5.0+synopsis: GraphQL support for IHP+description: GraphQL support for IHP+license: MIT+license-file: LICENSE+author: digitally induced GmbH+maintainer: support@digitallyinduced.com+homepage: https://ihp.digitallyinduced.com/+bug-reports: https://github.com/digitallyinduced/ihp/issues+copyright: (c) digitally induced GmbH+category: Web, IHP+build-type: Simple+extra-source-files: README.md, changelog.md++source-repository head+ type: git+ location: https://github.com/digitallyinduced/ihp.git++common shared-properties+ default-language: GHC2021+ build-depends:+ base >= 4.17.0 && < 4.22+ , ihp+ , ihp-postgres-parser+ , unordered-containers+ , text+ , attoparsec+ , postgresql-simple+ , aeson+ , scientific+ , countable-inflections+ default-extensions:+ OverloadedStrings+ , NoImplicitPrelude+ , ImplicitParams+ , DisambiguateRecordFields+ , DuplicateRecordFields+ , OverloadedLabels+ , DataKinds+ , QuasiQuotes+ , TypeFamilies+ , PackageImports+ , RecordWildCards+ , DefaultSignatures+ , FunctionalDependencies+ , PartialTypeSignatures+ , BlockArguments+ , LambdaCase+ , TemplateHaskell+ , OverloadedRecordDot+ ghc-options: -Werror=incomplete-patterns -Werror=unused-imports -Werror=missing-fields++library+ import: shared-properties+ hs-source-dirs: .+ exposed-modules:+ IHP.GraphQL.Compiler+ , IHP.GraphQL.JSON+ , IHP.GraphQL.Parser+ , IHP.GraphQL.SchemaCompiler+ , IHP.GraphQL.ToText+ , IHP.GraphQL.Types++test-suite spec+ import: shared-properties+ type: exitcode-stdio-1.0+ other-modules:+ Test.GraphQL.CompilerSpec+ , Test.GraphQL.ParserSpec+ , Test.GraphQL.SchemaCompilerSpec+ hs-source-dirs: .+ main-is: Test/Spec.hs+ build-depends:+ hspec+ , megaparsec+ , bytestring+ , ihp-graphql