diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 38118dae1..e3c465905 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -41,5 +41,5 @@ jobs: cat default.nix mv Makefile Makefile.old echo 'GHC_OPTIONS+= -rtsopts=all\n.SHELLFLAGS := -eu -o pipefail -c\n\n'|cat - Makefile.old > Makefile - nix-shell --run "new-application Web && make build/bin/RunUnoptimizedProdServer" + nix-shell --option sandbox false --run "new-application Web && make build/bin/RunUnoptimizedProdServer" diff --git a/IHP/Controller/Redirect.hs b/IHP/Controller/Redirect.hs index 8d8754f45..4d41db7a7 100644 --- a/IHP/Controller/Redirect.hs +++ b/IHP/Controller/Redirect.hs @@ -18,6 +18,7 @@ import IHP.Controller.RequestContext import IHP.RouterSupport (HasPath (pathTo)) import IHP.FrameworkConfig import Network.HTTP.Types.Status +import qualified Network.Wai as Wai import IHP.Controller.Context import IHP.ControllerSupport @@ -43,7 +44,7 @@ redirectTo action = redirectToPath (pathTo action) -- -- Use 'redirectTo' if you want to redirect to a controller action. redirectToPath :: (?context :: ControllerContext) => Text -> IO () -redirectToPath path = redirectToUrl (fromConfig baseUrl <> path) +redirectToPath path = redirectToUrl (appHost <> path) {-# INLINABLE redirectToPath #-} -- | Redirects to a url (given as a string) @@ -65,6 +66,20 @@ redirectToUrl url = do respondAndExit redirectResponse {-# INLINABLE redirectToUrl #-} +appHost :: (?context :: ControllerContext) => Text +appHost = + let + request = ?context + |> get #requestContext + |> get #request + protocol = if Wai.isSecure request + then "https" + else "http" + in request + |> Wai.requestHeaderHost + |> \case + Just host -> protocol <> "://" <> cs host + Nothing -> fromConfig baseUrl -- | Redirects back to the last page -- diff --git a/IHP/DataSync/Controller.hs b/IHP/DataSync/Controller.hs index 4673bf525..c1e4706e5 100644 --- a/IHP/DataSync/Controller.hs +++ b/IHP/DataSync/Controller.hs @@ -32,6 +32,7 @@ import qualified Data.Pool as Pool import qualified IHP.GraphQL.Types as GraphQL import qualified IHP.GraphQL.Parser as GraphQL import qualified IHP.GraphQL.Compiler as GraphQL +import qualified IHP.GraphQL.Analysis as GraphQL import IHP.GraphQL.JSON () import qualified Data.Attoparsec.Text as Attoparsec @@ -68,6 +69,8 @@ instance ( Left parserError -> error (cs $ tshow parserError) Right statements -> statements + ensureRLSEnabledForGraphQLDocument ensureRLSEnabled document + let [(theQuery, theParams)] = GraphQL.compileDocument variables document [PG.Only graphQLResult] <- sqlQueryWithRLSAndTransactionId transactionId theQuery theParams @@ -154,6 +157,84 @@ instance ( sendJSON DidDeleteDataSubscription { subscriptionId, requestId } + handleMessage CreateGraphQLLiveQuery { requestId, gql, variables } = do + let document = case Attoparsec.parseOnly GraphQL.parseDocument gql of + Left parserError -> error (cs $ tshow parserError) + Right statements -> statements + + tablesRLS <- ensureRLSEnabledForGraphQLDocument ensureRLSEnabled document + + -- Fetch the initial data + let [(theQuery, theParams)] = GraphQL.compileDocument variables document + [PG.Only (UndecodedJSON graphQLResultText)] <- sqlQueryWithRLSAndTransactionId Nothing theQuery theParams + + let (Just graphQLResult) = Aeson.decode (cs graphQLResultText) + + -- We need to keep track of all the ids of entities we're watching to make + -- sure that we only send update notifications to clients that can actually + -- access the record (e.g. if a RLS policy denies access) + let watchedRecordIds = GraphQL.recordIds document graphQLResult + + -- Store it in IORef as an INSERT requires us to add an id + watchedRecordIdsRef <- newIORef watchedRecordIds + + -- Make sure the database triggers are there + forEach tablesRLS installTableChangeTriggers + + liveQueryId <- UUID.nextRandom + + let callback table notification = case notification of + ChangeNotifications.DidInsert { id } -> do + -- The new record could not be accessible to the current user with a RLS policy + -- E.g. it could be a new record in a 'projects' table, but the project belongs + -- to a different user, and thus the current user should not be able to see it. + -- + -- The new record could also be not part of the WHERE condition of the initial query. + -- Therefore we need to use the subscriptions WHERE condition to fetch the new record here. + -- + -- To honor the RLS policies we therefore need to fetch the record as the current user + -- If the result set is empty, we know the record is not accesible to us + [PG.Only (UndecodedJSON graphQLResultText)] <- sqlQueryWithRLSAndTransactionId Nothing theQuery theParams + let (Just graphQLResult) = Aeson.decode (cs graphQLResultText) + + case GraphQL.extractRecordById id graphQLResult of + Just newRecord -> do + -- Add the new record to 'watchedRecordIdsRef' + -- Otherwise the updates and deletes will not be dispatched to the client + modifyIORef' watchedRecordIdsRef (HashMap.adjust (Set.insert id) table) + + sendJSON LiveQueryDidInsert { liveQueryId, newRecord, table } + Nothing -> pure () + ChangeNotifications.DidUpdate { id, changeSet } -> do + -- Only send the notifcation if the deleted record was part of the initial + -- results set + isWatchingRecord <- Set.member id . HashMap.lookupDefault Set.empty table <$> readIORef watchedRecordIdsRef + when isWatchingRecord do + sendJSON LiveQueryDidUpdate { liveQueryId, id, changeSet = changesToValue changeSet } + ChangeNotifications.DidDelete { id } -> do + -- Only send the notifcation if the deleted record was part of the initial + -- results set + isWatchingRecord <- Set.member id . HashMap.lookupDefault Set.empty table <$> readIORef watchedRecordIdsRef + when isWatchingRecord do + sendJSON LiveQueryDidDelete { liveQueryId, table, id } + + let startWatchers tablesRLS = case tablesRLS of + (tableNameRLS:rest) -> do + let subscribe = PGListener.subscribeJSON (ChangeNotifications.channelName tableNameRLS) (callback (get #tableName tableNameRLS)) pgListener + let unsubscribe subscription = PGListener.unsubscribe subscription pgListener + + Exception.bracket subscribe unsubscribe (\_ -> startWatchers rest) + [] -> do + close <- MVar.newEmptyMVar + modifyIORef' ?state (\state -> state |> modify #subscriptions (HashMap.insert liveQueryId close)) + + -- sendJSON DidCreateDataSubscription { subscriptionId, requestId, result } + sendJSON DidCreateLiveQuery { liveQueryId, graphQLResult, requestId } + + MVar.takeMVar close + + startWatchers tablesRLS + handleMessage CreateRecordMessage { table, record, requestId, transactionId } = do ensureRLSEnabled table @@ -453,6 +534,13 @@ sqlExecWithRLSAndTransactionId :: ) => Maybe UUID -> PG.Query -> parameters -> IO Int64 sqlExecWithRLSAndTransactionId transactionId theQuery theParams = runInModelContextWithTransaction (sqlExecWithRLS theQuery theParams) transactionId +ensureRLSEnabledForGraphQLDocument :: _ -> GraphQL.Document -> IO [TableWithRLS] +ensureRLSEnabledForGraphQLDocument ensureRLSEnabled document = do + let tables = document + |> GraphQL.tablesUsedInDocument + |> Set.toList + mapM ensureRLSEnabled tables + $(deriveFromJSON defaultOptions 'DataSyncQuery) $(deriveToJSON defaultOptions 'DataSyncResult) diff --git a/IHP/DataSync/REST/Controller.hs b/IHP/DataSync/REST/Controller.hs index f16ef5196..4a194ca11 100644 --- a/IHP/DataSync/REST/Controller.hs +++ b/IHP/DataSync/REST/Controller.hs @@ -28,7 +28,10 @@ import qualified Data.Aeson.Encoding.Internal as Aeson import qualified IHP.GraphQL.Types as GraphQL import qualified IHP.GraphQL.Parser as GraphQL import qualified IHP.GraphQL.Compiler as GraphQL +import qualified IHP.GraphQL.SchemaCompiler as GraphQL import IHP.GraphQL.JSON () +import qualified IHP.GraphQL.Resolver as GraphQL +import qualified IHP.IDE.SchemaDesigner.Parser as SchemaDesigner import qualified Data.Attoparsec.Text as Attoparsec instance ( @@ -156,14 +159,17 @@ instance ( action GraphQLQueryAction = do graphQLRequest :: GraphQL.GraphQLRequest <- case fromJSON requestBodyJSON of - Error errorMessage -> error (cs errorMessage) + Error errorMessage -> do + renderJson GraphQL.GraphQLErrorResponse { errors = [ cs errorMessage ] } + pure undefined -- Unreachable Data.Aeson.Success value -> pure value - let [(theQuery, theParams)] = GraphQL.compileDocument (get #variables graphQLRequest) (get #query graphQLRequest) - - [PG.Only graphQLResult] <- sqlQueryWithRLS theQuery theParams - - renderJson (graphQLResult :: UndecodedJSON) + (Right sqlSchema) <- SchemaDesigner.parseSchemaSql + let schema = GraphQL.sqlSchemaToGraphQLSchema sqlSchema + result <- handleGraphQLError (GraphQL.resolve schema sqlQueryWithRLS graphQLRequest) + case result of + (Left error) -> renderJson error + (Right graphQLResult) -> renderJson graphQLResult buildDynamicQueryFromRequest table = DynamicSQLQuery { table @@ -254,3 +260,12 @@ instance ToJSON GraphQLResult where instance ToJSON UndecodedJSON where toJSON (UndecodedJSON _) = error "Not implemented" toEncoding (UndecodedJSON json) = Aeson.unsafeToEncoding (ByteString.byteString json) + +handleGraphQLError runGraphQLHandler = do + result <- Exception.try runGraphQLHandler + pure case result of + Left (exception :: SomeException) -> + case Exception.fromException exception of + Just (exception :: EnhancedSqlError) -> Left GraphQL.GraphQLErrorResponse { errors = [ cs $ get #sqlErrorMsg (get #sqlError exception) ] } + Nothing -> Left GraphQL.GraphQLErrorResponse { errors = [ tshow exception ] } + Right result -> Right result diff --git a/IHP/DataSync/RowLevelSecurity.hs b/IHP/DataSync/RowLevelSecurity.hs index 77bbeb6ef..91df00f5b 100644 --- a/IHP/DataSync/RowLevelSecurity.hs +++ b/IHP/DataSync/RowLevelSecurity.hs @@ -5,6 +5,7 @@ module IHP.DataSync.RowLevelSecurity , makeCachedEnsureRLSEnabled , sqlQueryWithRLS , sqlExecWithRLS +, sqlQueryWithRLS' ) where @@ -33,11 +34,21 @@ sqlQueryWithRLS :: , PG.ToField userId , FromRow result ) => PG.Query -> parameters -> IO [result] -sqlQueryWithRLS query parameters = sqlQuery queryWithRLS parametersWithRLS - where - (queryWithRLS, parametersWithRLS) = wrapStatementWithRLS query parameters +sqlQueryWithRLS query parameters = sqlQueryWithRLS' (get #id <$> currentUserOrNothing) query parameters {-# INLINE sqlQueryWithRLS #-} +sqlQueryWithRLS' :: + ( ?modelContext :: ModelContext + , PG.ToRow parameters + , PG.ToField userId + , FromRow result + , ?context :: ControllerContext + ) => Maybe userId -> PG.Query -> parameters -> IO [result] +sqlQueryWithRLS' userId query parameters = sqlQuery queryWithRLS parametersWithRLS + where + (queryWithRLS, parametersWithRLS) = wrapStatementWithRLS userId query parameters +{-# INLINE sqlQueryWithRLS' #-} + sqlExecWithRLS :: ( ?modelContext :: ModelContext , PG.ToRow parameters @@ -52,27 +63,19 @@ sqlExecWithRLS :: ) => PG.Query -> parameters -> IO Int64 sqlExecWithRLS query parameters = sqlExec queryWithRLS parametersWithRLS where - (queryWithRLS, parametersWithRLS) = wrapStatementWithRLS query parameters + (queryWithRLS, parametersWithRLS) = wrapStatementWithRLS (get #id <$> currentUserOrNothing) query parameters {-# INLINE sqlExecWithRLS #-} wrapStatementWithRLS :: ( ?modelContext :: ModelContext , PG.ToRow parameters , ?context :: ControllerContext - , userId ~ Id CurrentUserRecord - , Show (PrimaryKey (GetTableName CurrentUserRecord)) - , HasNewSessionUrl CurrentUserRecord - , Typeable CurrentUserRecord - , ?context :: ControllerContext - , HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord)) , PG.ToField userId - ) => PG.Query -> parameters -> (PG.Query, [PG.Action]) -wrapStatementWithRLS query parameters = (queryWithRLS, parametersWithRLS) + ) => Maybe userId -> PG.Query -> parameters -> (PG.Query, [PG.Action]) +wrapStatementWithRLS maybeUserId query parameters = (queryWithRLS, parametersWithRLS) where queryWithRLS = "SET LOCAL ROLE ?; SET LOCAL rls.ihp_user_id = ?; " <> query <> ";" - maybeUserId = get #id <$> currentUserOrNothing - -- When the user is not logged in and maybeUserId is Nothing, we cannot -- just pass @NULL@ to postgres. The @SET LOCAL@ values can only be strings. -- diff --git a/IHP/DataSync/Types.hs b/IHP/DataSync/Types.hs index 0a0652ff4..814600991 100644 --- a/IHP/DataSync/Types.hs +++ b/IHP/DataSync/Types.hs @@ -9,7 +9,7 @@ import qualified IHP.PGListener as PGListener import qualified Database.PostgreSQL.Simple as PG import Control.Concurrent.MVar as MVar import qualified IHP.GraphQL.Types as GraphQL - +import qualified Data.Aeson as Aeson data DataSyncMessage = DataSyncQuery { query :: !DynamicSQLQuery, requestId :: !Int, transactionId :: !(Maybe UUID) } @@ -25,6 +25,8 @@ data DataSyncMessage | StartTransaction { requestId :: !Int } | RollbackTransaction { requestId :: !Int, id :: !UUID } | CommitTransaction { requestId :: !Int, id :: !UUID } + | CreateGraphQLLiveQuery { gql :: !Text, requestId :: !Int, variables :: !GraphQL.Variables } + | DeleteGraphQLLiveQuery { liveQueryId :: !UUID, requestId :: !Int } deriving (Eq, Show) data DataSyncResponse @@ -45,6 +47,11 @@ data DataSyncResponse | DidStartTransaction { requestId :: !Int, transactionId :: !UUID } | DidRollbackTransaction { requestId :: !Int, transactionId :: !UUID } | DidCommitTransaction { requestId :: !Int, transactionId :: !UUID } + | DidCreateLiveQuery { requestId :: !Int, liveQueryId :: !UUID, graphQLResult :: !Aeson.Value } + | DidDeleteLiveQuery { requestId :: !Int, liveQueryId :: !UUID } + | LiveQueryDidInsert { liveQueryId :: !UUID, newRecord :: !Aeson.Value, table :: !Text } + | LiveQueryDidUpdate { liveQueryId :: !UUID, id :: UUID, changeSet :: !Value } + | LiveQueryDidDelete { liveQueryId :: !UUID, id :: !UUID, table :: !Text } data GraphQLResult = GraphQLResult { graphQLResult :: !UndecodedJSON, requestId :: !Int } diff --git a/IHP/GraphQL/Analysis.hs b/IHP/GraphQL/Analysis.hs new file mode 100644 index 000000000..3c942660d --- /dev/null +++ b/IHP/GraphQL/Analysis.hs @@ -0,0 +1,226 @@ +module IHP.GraphQL.Analysis where + +import IHP.Prelude +import IHP.GraphQL.Types + +import Data.Set (Set) +import qualified Data.Set as Set +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Internal as Aeson +import Data.Aeson ((.:)) +import qualified Data.Vector as Vector +import qualified Data.UUID as UUID +import qualified Data.List as List +import qualified Data.Text as Text + +type TableName = Text + +-- | Returns the database tables used by a GraphQL query +tablesUsedInDocument :: Document -> Set TableName +tablesUsedInDocument Document { definitions } = mconcat (map tablesUsedInDefinition definitions) + where + tablesUsedInDefinition :: Definition -> Set Text + tablesUsedInDefinition ExecutableDefinition { operation } = tablesUsedInOperation operation + + tablesUsedInOperation :: OperationDefinition -> Set Text + tablesUsedInOperation OperationDefinition { selectionSet, operationType } = tablesUsedInSelectionSet operationType selectionSet + + tablesUsedInSelectionSet :: OperationType -> [Selection] -> Set Text + tablesUsedInSelectionSet operationType selectionSet = mconcat (map (tablesUsedInSelection operationType) selectionSet) + + tablesUsedInSelection :: OperationType -> Selection -> Set Text + tablesUsedInSelection _ Field { selectionSet = [] } = Set.empty + tablesUsedInSelection operationType Field { name, selectionSet, arguments } = Set.singleton normalizedName <> tablesUsedInSelectionSet Query selectionSet + where + -- `createTask` => tasks + -- `deleteTask` => tasks + -- `updateTask` => tasks + normalizedName = case operationType of + Mutation -> + case Text.stripPrefix "create" name of + Just suffix -> modelNameToTableName suffix + Nothing -> case Text.stripPrefix "delete" name of + Just suffix -> modelNameToTableName suffix + Nothing -> case Text.stripPrefix "update" name of + Just suffix -> modelNameToTableName suffix + Nothing -> name + _ -> case selectionSet of + [] -> name + _ -> pluralize name -- `project(id: $projectId)` => projects + + +recordIds :: Document -> Aeson.Value -> HashMap TableName (Set UUID) +recordIds Document { definitions } result = mconcat (map recordIdsInDefinition definitions) + where + recordIdsInDefinition :: Definition -> HashMap TableName (Set UUID) + recordIdsInDefinition ExecutableDefinition { operation } = recordIdsInOperation operation + + recordIdsInOperation :: OperationDefinition -> HashMap TableName (Set UUID) + recordIdsInOperation OperationDefinition { selectionSet } = recordIdsInSelectionSet selectionSet result + + recordIdsInSelectionSet :: [Selection] -> Aeson.Value -> HashMap TableName (Set UUID) + recordIdsInSelectionSet selectionSet result = mconcat (map (recordIdsInSelection result) selectionSet) + + recordIdsInSelection :: Aeson.Value -> Selection -> HashMap TableName (Set UUID) + recordIdsInSelection result Field { selectionSet = [] } = HashMap.empty + recordIdsInSelection result Field { name, alias, selectionSet } = mconcat $ + (HashMap.singleton tableName selectionIds):(map (recordIdsInSelection selectedResult) childNodes) + where + (selectionIds, tableName) = selectionIdsAndName + + aliasOrName :: Text + aliasOrName = fromMaybe name alias + + childNodes = selectionSet + |> filter selectionIsNode + + selectedResult :: Aeson.Value + selectedResult = case result of + Aeson.Object hashMap -> hashMap + |> HashMap.lookup aliasOrName + |> \case + Just result -> result + Nothing -> error ("Could not find " <> tshow aliasOrName <> " in result set") + Aeson.Array vector -> vector + |> Vector.toList + |> map (\case + Aeson.Object hashMap -> hashMap + |> HashMap.lookup aliasOrName + |> \case + Just (Aeson.Array result) -> result + Nothing -> error ("Could not find " <> tshow aliasOrName <> " in result set") + otherwise -> error ("selectedResult -> array: Object expxected") + ) + |> map Vector.toList + |> concat + |> Vector.fromList + |> Aeson.Array + otherwise -> error ("selectedResult at " <> name <> ": Expected an object here, got: " <> tshow otherwise) + + selectionIdsAndName :: (Set UUID, Text) + selectionIdsAndName = case selectedResult of + Aeson.Array vector -> + vector + |> Vector.toList + |> map (\case + Aeson.Object record -> extractId record + otherwise -> error ("selectionIds: unexpected " <> tshow selectedResult) + ) + |> Set.fromList + |> \ids -> (ids, name) + Aeson.Object hashMap -> (Set.singleton (extractId hashMap), pluralize name) + _ -> error "unexpected object here" + + extractId :: HashMap Text Aeson.Value -> UUID + extractId record = record + |> HashMap.lookup "id" + |> \case + Just (Aeson.String string) -> + case UUID.fromText string of + Just uuid -> uuid + Nothing -> error "Failed to parse UUID" + Just otherwise -> error "Expected 'id' field to be a string" + Nothing -> error "Could not find 'id' field for record" + +selectionIsNode :: Selection -> Bool +selectionIsNode Field { selectionSet = [] } = False +selectionIsNode otherwise = True + +extractRecordById :: UUID -> Aeson.Value -> Maybe Aeson.Value +extractRecordById id result = + case result of + record@(Aeson.Object hashMap) -> + let traverseObjectKeys = + hashMap + |> HashMap.elems + |> mapMaybe (extractRecordById id) + |> headMay + in case HashMap.lookup "id" hashMap of + Just (Aeson.String idString) -> + case UUID.fromText idString of + Just uuid -> if uuid == id + then Just record + else traverseObjectKeys + Nothing -> error "Failed to parse UUID" + otherwise -> traverseObjectKeys + Aeson.Array vector -> + vector + |> Vector.toList + |> mapMaybe (extractRecordById id) + |> headMay + otherwise -> Nothing + +isSubscriptionDocument :: Document -> Bool +isSubscriptionDocument Document { definitions } = foldl' (&&) True (map isSubscriptionDefinition definitions) + where + isSubscriptionDefinition ExecutableDefinition { operation = OperationDefinition { operationType } } = operationType == Subscription + +newtype Path = Path [Text] + deriving (Eq, Show) + +nodePathsForTable :: Text -> Document -> [Path] +nodePathsForTable tableName Document { definitions } = reversePath <$> mconcat (map nodePathsForTableDefinition definitions) + where + -- e.g. "users" or "userProjects" + targetSelectionName = lcfirst $ tableNameToControllerName tableName + + reversePath :: Path -> Path + reversePath (Path path) = (Path (reverse path)) + + nodePathsForTableDefinition :: Definition -> [Path] + nodePathsForTableDefinition ExecutableDefinition { operation } = nodePathsForTableOperation operation + + nodePathsForTableOperation :: OperationDefinition -> [Path] + nodePathsForTableOperation OperationDefinition { selectionSet } = nodePathsForTableSelectionSet [] selectionSet + + nodePathsForTableSelectionSet :: [Text] -> [Selection] -> [Path] + nodePathsForTableSelectionSet path selectionSet = mconcat (map (nodePathsForTableSelection path) selectionSet) + + nodePathsForTableSelection :: [Text] -> Selection -> [Path] + nodePathsForTableSelection path Field { selectionSet = [] } = [] + nodePathsForTableSelection path Field { name, alias, selectionSet } = + let + nameOrAlias = (fromMaybe name alias) + cur = Path (nameOrAlias:path) + rec = nodePathsForTableSelectionSet (nameOrAlias:path) selectionSet + in + if name == targetSelectionName + then cur:rec + else rec + +applyFunctionAtNode :: (Aeson.Value -> Aeson.Value) -> Path -> Aeson.Value -> Aeson.Value +applyFunctionAtNode function (Path path) json = applyFunctionAtNode' function path json + where + applyFunctionAtNode' function [] value = function value + applyFunctionAtNode' function (curPath:restPath) (Aeson.Object hashMap) = Aeson.Object (HashMap.adjust (applyFunctionAtNode' function restPath) curPath hashMap) + applyFunctionAtNode' function path (Aeson.Array vector) = Aeson.Array (Vector.map (applyFunctionAtNode' function path) vector) + +documentIsExecutable :: Document -> Bool +documentIsExecutable Document { definitions } = isJust (find isExecutableDefinition definitions) + +isExecutableDefinition :: Definition -> Bool +isExecutableDefinition ExecutableDefinition {} = True +isExecutableDefinition _ = False + +splitDocumentIntoResolvableUnits :: Document -> [(Resolver, Document)] +splitDocumentIntoResolvableUnits Document { definitions } = removeEmptyResolvers $ split [] [] definitions + where + isPostgresSelection Field { name = "__schema" } = False + isPostgresSelection otherwise = True + + removeEmptyResolvers :: [(Resolver, Document)] -> [(Resolver, Document)] + removeEmptyResolvers documentsWithResolver = filter (\(resolver, document) -> documentIsExecutable document) documentsWithResolver + + split :: [Definition] -> [Definition] -> [Definition] -> [(Resolver, Document)] + split postgresDefinitions introspectionDefinitions (ed@(ExecutableDefinition { operation = od@(OperationDefinition { selectionSet }) }):rest) = + case List.partition isPostgresSelection selectionSet of + (postgresSelection, []) -> split (postgresDefinitions <> [ed]) introspectionDefinitions rest + ([], introspectionSelection) -> split postgresDefinitions (introspectionDefinitions <> [ed]) rest + (postgresSelection, introspectionSelection) -> split (postgresDefinitions <> [ ExecutableDefinition { operation = od { selectionSet = postgresSelection } } ]) (introspectionDefinitions <> [ ExecutableDefinition { operation = od { selectionSet = introspectionSelection } } ]) rest + split postgresDefinitions introspectionDefinitions (x:xs) = + if isExecutableDefinition x + then split (postgresDefinitions <> [x]) introspectionDefinitions xs + else split (postgresDefinitions <> [x]) (introspectionDefinitions <> [x]) xs -- E.g. fragments need to be in both queries + split postgresDefinitions introspectionDefinitions [] = [(PostgresResolver, Document postgresDefinitions), (IntrospectionResolver, Document introspectionDefinitions)] \ No newline at end of file diff --git a/IHP/GraphQL/Compiler.hs b/IHP/GraphQL/Compiler.hs index 329e45751..24b39f937 100644 --- a/IHP/GraphQL/Compiler.hs +++ b/IHP/GraphQL/Compiler.hs @@ -2,12 +2,14 @@ module IHP.GraphQL.Compiler where import IHP.Prelude import IHP.GraphQL.Types +import qualified IHP.GraphQL.Introspection as Introspection 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 qualified Data.List as List data SqlQuery = SqlQuery { query :: Text, params :: [PG.Action]} @@ -16,31 +18,44 @@ 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 } } | operationType == Query || operationType == Subscription -> + [ unpackQueryPart (compileDefinition document definition arguments) ] ExecutableDefinition { operation = OperationDefinition { operationType = Mutation } } -> - map unpackQueryPart $ compileMutationDefinition definition arguments + map unpackQueryPart $ compileMutationDefinition document definition arguments compileDefinition :: Document -> Definition -> [Argument] -> QueryPart -compileDefinition document ExecutableDefinition { operation = OperationDefinition { operationType = Query, selectionSet } } variables = - selectionSet - |> map (compileSelection document variables) - |> unionAll +compileDefinition document ExecutableDefinition { operation = OperationDefinition { operationType, selectionSet } } variables | operationType == Query || operationType == Subscription = + "SELECT json_build_object(" <> commaSep aggregations <> ")" + where + aggregations = map (compileSelection document variables) selectionSet -compileMutationDefinition :: Definition -> [Argument] -> [QueryPart] -compileMutationDefinition ExecutableDefinition { operation = OperationDefinition { operationType = Mutation, selectionSet } } arguments = +compileMutationDefinition :: Document -> Definition -> [Argument] -> [QueryPart] +compileMutationDefinition document ExecutableDefinition { operation = OperationDefinition { operationType = Mutation, selectionSet } } arguments = selectionSet - |> map (compileMutationSelection arguments) + |> map ((compileMutationSelection document) arguments) compileSelection :: Document -> [Argument] -> Selection -> QueryPart 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) ]) + aggregation where + query = + "(SELECT " + <> selectQueryPieces document tableName field + <> (" FROM ?" |> withParams [PG.toField (PG.Identifier tableName)]) + <> joins document variables tableName field + <> where_ + <> (") AS ?" |> withParams [ PG.toField (PG.Identifier subqueryId) ]) + + -- | Builds a tuple as used in `json_build_object('users', json_agg(_users), 'tasks', json_agg(_tasks))` + aggregation = ( + if isSingleResult + then + (("?, (SELECT coalesce(row_to_json(?), '[]'::json) FROM " |> withParams [PG.toField nameOrAlias, PG.toField (PG.Identifier subqueryId)]) <> query <> ")") + else + (("?, (SELECT coalesce(json_agg(row_to_json(?)), '[]'::json) FROM " |> withParams [PG.toField nameOrAlias, PG.toField (PG.Identifier subqueryId)]) <> query <> ")")) + + isSingleResult = isJust idArgument + subqueryId = "_" <> fieldName nameOrAlias = fromMaybe fieldName alias @@ -58,79 +73,115 @@ compileSelection document variables field@(Field { alias, name = fieldName, argu [Argument { argumentName = "id", argumentValue }] -> Just argumentValue _ -> Nothing - +joins :: Document -> [Argument] -> Text -> Selection -> QueryPart +joins document variables tableName field = field + |> get #selectionSet + |> filter isJoinField + |> map (fieldToJoin document variables tableName) + |> \case + [] -> "" + joins -> " " <> spaceSep joins + where isJoinField :: Selection -> Bool isJoinField Field { selectionSet } = not (null selectionSet) isJoinField FragmentSpread {} = False -- TODO: Also support fragment spreads in joined tables - joins :: QueryPart - joins = field - |> get #selectionSet - |> filter isJoinField - |> map (fieldToJoin document tableName) - |> \case - [] -> "" - joins -> " " <> spaceSep joins -selectQueryPieces :: Document -> PG.Action -> Selection -> QueryPart -selectQueryPieces document tableName field = field +selectQueryPieces :: Document -> Text -> Selection -> QueryPart +selectQueryPieces document tableName field = + selectFields document tableName field + |> map (\(left, right, isAlias) -> if isAlias + then left <> " AS ?" |> withParams [PG.toField (PG.Identifier right)] + else left + ) + |> commaSep + +returnQueryPieces :: Document -> Text -> Selection -> QueryPart +returnQueryPieces document tableName field = + selectFields document tableName field + |> map (\(left, right, isAlias) -> ("?, " |> withParams [PG.toField right]) <> left ) + |> commaSep + +selectFields :: Document -> Text -> Selection -> [(QueryPart, Text, Bool)] +selectFields document tableName field = + field |> get #selectionSet |> map compileSelection |> mconcat - |> commaSep where + qualified :: Selection -> QueryPart qualified field = if isEmpty (get #selectionSet field) - then "?." |> withParams [tableName] + then "?." |> withParams [PG.toField (PG.Identifier tableName)] else "" - compileSelection :: Selection -> [QueryPart] + compileSelection :: Selection -> [(QueryPart, Text, Bool)] 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 }) = + compileField :: Selection -> (QueryPart, Text, Bool) + compileField field@(Field { alias, name = "__typename" }) = + ( "?" |> withParams [ PG.toField typeName ] + , fromMaybe "__typename" alias + , alias /= "__typename" + ) + where + typeName = tableNameToModelName tableName + compileField field@(Field { alias = Just alias, name }) = + ( qualified field <> ("?" |> withParams [ PG.toField (PG.Identifier (fieldNameToColumnName name)) ]) + , alias + , True + ) + 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)) ] + ( qualified field <> ("?" |> withParams [ PG.toField (PG.Identifier (fieldNameToColumnName name)) ]) + , name + , columnName /= name + ) - compileFragmentSpread :: Selection -> [QueryPart] + compileFragmentSpread :: Selection -> [(QueryPart, Text, Bool)] compileFragmentSpread FragmentSpread { fragmentName } = fragment |> get #selectionSet |> map compileSelection |> mconcat where - fragment :: Fragment - fragment = document - |> get #definitions - |> find (\case - FragmentDefinition (Fragment { name }) -> name == fragmentName - otherwise -> False - ) - |> fromMaybe (error $ "Could not find fragment named " <> fragmentName) - |> \case - FragmentDefinition fragment -> fragment - -fieldToJoin :: Document -> Text -> Selection -> QueryPart -fieldToJoin document rootTableName field@(Field { name }) = + fragment = findFragmentByName document fragmentName + +fieldToJoin :: Document -> [Argument] -> Text -> Selection -> QueryPart +fieldToJoin document variables rootTableName field@(Field { name }) = "LEFT JOIN LATERAL (" - <> "SELECT ARRAY(" - <> "SELECT to_json(_sub) FROM (" + <> when isHasMany "SELECT ARRAY(" + <> when isHasMany "SELECT to_json(_sub) FROM (" <> "SELECT " - <> selectQueryPieces document foreignTable field + <> selectQueryPieces document foreignTableName field <> (" FROM ?" |> withParams [foreignTable]) - <> (" WHERE ?.? = ?.?" |> withParams [foreignTable, foreignTableForeignKey, rootTable, rootTablePrimaryKey]) - <> ") AS _sub" - <> (") AS ?" |> withParams [aliasOrName]) + <> joins document variables rootTableName field + <> (" WHERE ?.? = ?.?" |> withParams conditionParams) + <> when isHasMany ") AS _sub" + <> when isHasMany (") AS ?" |> withParams [aliasOrName]) <> (") ? ON true" |> withParams [aliasOrName]) where - foreignTable = PG.toField (PG.Identifier name) + isHasOne :: Bool + isHasOne = singularize name == name -- Is it a singular name, like `user` instead of `users`? + + isHasMany = not isHasOne + + conditionParams = if isHasMany + then [foreignTable, foreignTableForeignKey, rootTable, rootTablePrimaryKey] + else [foreignTable, PG.toField (PG.Identifier "id"), rootTable, PG.toField (PG.Identifier $ (fieldNameToColumnName name) <> "_id" )] + + when condition then_ = if condition then then_ else "" + + foreignTable = PG.toField (PG.Identifier foreignTableName) + foreignTableName = + if isHasOne + then pluralize name + else name + foreignTableForeignKey = PG.toField (PG.Identifier foreignTableForeignKeyName) foreignTableForeignKeyName = rootTableName |> singularize @@ -143,19 +194,19 @@ fieldToJoin document rootTableName field@(Field { name }) = Just alias -> alias Nothing -> get #name field -compileMutationSelection :: [Argument] -> Selection -> QueryPart -compileMutationSelection queryArguments field@(Field { alias, name = fieldName, arguments, selectionSet }) = fromMaybe (error ("Invalid mutation: " <> tshow fieldName)) do +compileMutationSelection :: Document -> [Argument] -> Selection -> QueryPart +compileMutationSelection document 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 + pure $ compileSelectionToInsertStatement document queryArguments field modelName let delete = do modelName <- Text.stripPrefix "delete" fieldName - pure $ compileSelectionToDeleteStatement queryArguments field modelName + pure $ compileSelectionToDeleteStatement document queryArguments field modelName let update = do modelName <- Text.stripPrefix "update" fieldName - pure $ compileSelectionToUpdateStatement queryArguments field modelName + pure $ compileSelectionToUpdateStatement document queryArguments field modelName create <|> delete <|> update @@ -182,8 +233,8 @@ compileMutationSelection queryArguments field@(Field { alias, name = fieldName, -- > 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 field@(Field { alias, name = fieldName, arguments, selectionSet }) modelName = +compileSelectionToInsertStatement :: Document -> [Argument] -> Selection -> Text -> QueryPart +compileSelectionToInsertStatement document 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 @@ -204,10 +255,7 @@ compileSelectionToInsertStatement queryArguments field@(Field { alias, name = fi |> unzip returning :: QueryPart - returning = "json_build_object(" <> returningArgs <> ")" - returningArgs = selectionSet - |> map (\Field { name = fieldName } -> "?, ?.?" |> withParams [PG.toField (fieldNameToColumnName fieldName), PG.toField (PG.Identifier tableName), PG.toField (PG.Identifier (fieldNameToColumnName fieldName))]) - |> commaSep + returning = ("json_build_object(?, json_build_object(" |> withParams [PG.toField (nameOrAlias field) ]) <> returnQueryPieces document tableName field <> "))" -- | Turns a @update..@ mutation into a UPDATE SQL query -- @@ -234,8 +282,8 @@ compileSelectionToInsertStatement queryArguments field@(Field { alias, name = fi -- > WHERE id = 'df1f54d5-ced6-4f65-8aea-fcd5ea6b9df1' -- > RETURNING json_build_object('id', projects.id, 'title', projects.title) -- -compileSelectionToUpdateStatement :: [Argument] -> Selection -> Text -> QueryPart -compileSelectionToUpdateStatement queryArguments field@(Field { alias, name = fieldName, arguments, selectionSet }) modelName = +compileSelectionToUpdateStatement :: Document -> [Argument] -> Selection -> Text -> QueryPart +compileSelectionToUpdateStatement document 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 @@ -258,10 +306,7 @@ compileSelectionToUpdateStatement queryArguments field@(Field { alias, name = fi |> map (\(fieldName, value) -> ("? = ?" |> withParams [PG.toField (PG.Identifier (fieldNameToColumnName fieldName)), valueToSQL value])) returning :: QueryPart - returning = "json_build_object(" <> returningArgs <> ")" - returningArgs = selectionSet - |> map (\Field { name = fieldName } -> "?, ?.?" |> withParams [PG.toField (fieldNameToColumnName fieldName), PG.toField (PG.Identifier tableName), PG.toField (PG.Identifier (fieldNameToColumnName fieldName))]) - |> commaSep + returning = ("json_build_object(?, json_build_object(" |> withParams [PG.toField (nameOrAlias field) ]) <> returnQueryPieces document tableName field <> "))" -- | Turns a @delete..@ mutation into a DELETE SQL query -- @@ -283,8 +328,8 @@ compileSelectionToUpdateStatement queryArguments field@(Field { alias, name = fi -- > 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 field@(Field { alias, name = fieldName, arguments, selectionSet }) modelName = +compileSelectionToDeleteStatement :: Document -> [Argument] -> Selection -> Text -> QueryPart +compileSelectionToDeleteStatement document 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 @@ -294,10 +339,7 @@ compileSelectionToDeleteStatement queryArguments field@(Field { alias, name = fi Nothing -> error $ "Expected first argument to " <> fieldName <> " to be an ID, got no arguments" returning :: QueryPart - returning = "json_build_object(" <> returningArgs <> ")" - returningArgs = selectionSet - |> map (\Field { name = fieldName } -> "?, ?.?" |> withParams [PG.toField (fieldNameToColumnName fieldName), PG.toField (PG.Identifier tableName), PG.toField (PG.Identifier (fieldNameToColumnName fieldName))]) - |> commaSep + returning = ("json_build_object(?, json_build_object(" |> withParams [PG.toField (nameOrAlias field) ]) <> returnQueryPieces document tableName field <> "))" valueToSQL :: Value -> PG.Action valueToSQL (IntValue int) = PG.toField int @@ -313,11 +355,58 @@ resolveVariables (Variable varName) arguments = Nothing -> error ("Could not resolve variable " <> varName) resolveVariables otherwise _ = otherwise +compileIntrospectionSelection :: GraphQLSchema -> Document -> [Argument] -> Selection -> (Maybe QueryPart, QueryPart) +compileIntrospectionSelection schema document variables field@(Field { name, selectionSet }) = (Nothing, aggregation) + where + + aggregation = ("?, json_build_object(" |> withParams [PG.toField (nameOrAlias field)]) <> buildSchemaSelection <> ")" + + buildSchemaSelection = commaSep (map (compileSchemaSelection (Introspection.introspectionGraph schema)) selectionSet) + + compileSchemaSelection :: StaticGraph -> Selection -> QueryPart + compileSchemaSelection graph field@(Field { name, selectionSet = [] }) = + let + targetLeaf :: Value + targetLeaf = graph + |> (\case + ObjectNode { objectValues } -> objectValues + otherwise -> error $ "expected object node, got " <> tshow otherwise + ) + |> HashMap.lookup name + |> \case + Just (Leaf value) -> value + otherwise -> error $ "expected leaf node at " <> name <> ", got " <> tshow otherwise <> " in graph " <> tshow graph + in + "?, ?" |> withParams [PG.toField (nameOrAlias field), PG.toField targetLeaf] + compileSchemaSelection graph field@(Field { name, selectionSet }) = + let + targetNode :: StaticGraph + targetNode = graph + |> (\case + ObjectNode { objectValues } -> objectValues + otherwise -> error $ "expected object node, got " <> tshow otherwise + ) + |> HashMap.lookup name + |> fromMaybe (error $ "Could not find node " <> name) + in + case targetNode of + ObjectNode {} -> ("?, json_build_object(" |> withParams [PG.toField (nameOrAlias field)]) <> commaSep (map (compileSchemaSelection targetNode) selectionSet) <> ")" + ArrayNode { arrayElements } -> ("?, json_build_object(" |> withParams [PG.toField (nameOrAlias field)]) <> commaSep (map (\targetNode -> commaSep (map (compileSchemaSelection targetNode) selectionSet)) arrayElements) <> ")" + Leaf { value = NullValue } -> "?, null" |> withParams [PG.toField (nameOrAlias field)] + otherwise -> error $ "Expected object or array, got " <> tshow otherwise <> " while trying to access " <> name + compileSchemaSelection graph FragmentSpread { fragmentName } = + let + fragment = findFragmentByName document fragmentName + selectionSet = get #selectionSet fragment + in + commaSep (map (compileSchemaSelection graph) selectionSet) + + unionAll :: [QueryPart] -> QueryPart unionAll list = foldl' (\a b -> if get #sql a == "" then b else a <> " UNION ALL " <> b) "" list commaSep :: [QueryPart] -> QueryPart -commaSep list = foldl' (\a b -> if get #sql a == "" then b else a <> ", " <> b) "" list +commaSep list = foldl' (\a b -> if get #sql a == "" then b else (a <> ", " <> b)) "" list spaceSep :: [QueryPart] -> QueryPart spaceSep list = foldl' (\a b -> if get #sql a == "" then b else a <> " " <> b) "" list @@ -334,4 +423,29 @@ unpackQueryPart :: QueryPart -> (PG.Query, [PG.Action]) unpackQueryPart QueryPart { sql, params } = (sql, params) withParams :: [PG.Action] -> QueryPart -> QueryPart -withParams params queryPart = queryPart { params = (get #params queryPart) <> params } \ No newline at end of file +withParams params queryPart = queryPart { params = (get #params queryPart) <> params } + +nameOrAlias :: Selection -> Text +nameOrAlias field = fromMaybe (get #name field) (get #alias field) + +findFragmentByName :: Document -> Text -> Fragment +findFragmentByName document name = + let + allFragmentNames = document + |> get #definitions + |> mapMaybe (\case FragmentDefinition (Fragment { name }) -> Just name; _ -> Nothing) + couldNotFindFragmentErrorMessage = "Could not find fragment named " <> name <> ". These fragments are defined: " <> Text.intercalate ", " allFragmentNames + in + document + |> get #definitions + |> find (\case + FragmentDefinition (Fragment { name = fragmentName }) -> name == fragmentName + otherwise -> False + ) + |> fromMaybe (error couldNotFindFragmentErrorMessage) + |> \case + FragmentDefinition fragment -> fragment + +instance PG.ToField Value where + toField (StringValue string) = PG.toField string + toField NullValue = PG.toField (Nothing :: Maybe Int) \ No newline at end of file diff --git a/IHP/GraphQL/GraphQLWS.hs b/IHP/GraphQL/GraphQLWS.hs new file mode 100644 index 000000000..65cd250a4 --- /dev/null +++ b/IHP/GraphQL/GraphQLWS.hs @@ -0,0 +1,362 @@ +{-| +Module: IHP.GraphQL.GraphQLWS +Description: Implements a WebSocket server for graphql-ws as described in https://github.com/enisdenjo/graphql-ws/blob/master/PROTOCOL.md +Copyright: (c) digitally induced GmbH, 2020 +-} +module IHP.GraphQL.GraphQLWS where + +import IHP.Prelude +import IHP.GraphQL.Types +import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec + +import IHP.ApplicationContext (ApplicationContext) +import qualified IHP.ApplicationContext as ApplicationContext +import IHP.ControllerPrelude hiding (Error) +import Network.Wai +import qualified Network.Wai.Handler.WebSockets as WebSockets +import qualified Network.WebSockets as WebSockets +import qualified IHP.WebSocket as WebSockets +import qualified Network.HTTP.Types as HTTP +import qualified IHP.Controller.Context as Context +import qualified IHP.Controller.RequestContext +import qualified IHP.Log as Log +import qualified Control.Exception as Exception + +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Encoding.Internal as Aeson + +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Control.Concurrent.MVar as MVar + +import qualified Database.PostgreSQL.Simple as PG + +import qualified IHP.GraphQL.Types as GraphQL +import qualified IHP.GraphQL.Parser as GraphQL +import qualified IHP.GraphQL.Compiler as GraphQL +import qualified IHP.GraphQL.Analysis as GraphQL +import qualified IHP.GraphQL.Patch as GraphQL +import IHP.GraphQL.JSON () +import qualified Data.Attoparsec.Text as AttoparsecText +import IHP.DataSync.RowLevelSecurity +import IHP.DataSync.DynamicQuery +import IHP.DataSync.REST.Controller () +import IHP.DataSync.Controller (changesToValue) +import qualified IHP.DataSync.ChangeNotifications as ChangeNotifications +import Data.Set (Set) +import qualified Data.Set as Set +import qualified IHP.PGListener as PGListener +import qualified Web.JWT as JWT +import qualified Data.UUID as UUID + +-- | Cannot be implemented natively in IHP as we need to accept the @graphql-transport-ws@ sub protocol +routeGraphQLWS :: + ( ?application :: application + , ?applicationContext :: ApplicationContext + , ?context :: RequestContext + ) => Attoparsec.Parser (IO ResponseReceived) +routeGraphQLWS = do + Attoparsec.string "/api/graphql-ws" + Attoparsec.endOfInput + + let ?modelContext = ApplicationContext.modelContext ?applicationContext + let ?requestContext = ?context + let respond = ?context |> get #respond + let request = ?context |> get #request + let acceptRequest = WebSockets.AcceptRequest { acceptSubprotocol = "graphql-transport-ws", acceptHeaders = [] } + + let handleConnection pendingConnection = do + connection <- WebSockets.acceptRequestWith pendingConnection acceptRequest + + controllerContext <- Context.newControllerContext + let ?context = controllerContext + + WebSockets.startWSApp @GraphQLWSApp connection + + pure $ request + |> WebSockets.websocketsApp WebSockets.defaultConnectionOptions handleConnection + |> \case + Just response -> respond response + Nothing -> respond $ responseLBS HTTP.status400 [(HTTP.hContentType, "text/plain")] "This endpoint is only available via a WebSocket" + +data GraphQLWSApp = GraphQLWSApp + { subscriptions :: !(HashMap UUID (MVar.MVar ())) + , asyncs :: ![Async ()] + } + +-- | Messages according to https://github.com/enisdenjo/graphql-ws/blob/master/PROTOCOL.md +data Message + = ConnectionInit { connectionInitPayload :: HashMap Text Aeson.Value } -- ^ Direction: Client -> Server + | ConnectionAck -- ^ Direction: Server -> Client + | Ping -- ^ Direction: bidirectional + | Pong -- ^ Direction: bidirectional + | Subscribe + { id :: !UUID + , operationName :: !(Maybe Text) + , query :: !Text + , variables :: !(Maybe GraphQL.Variables) + , extensions :: !(Maybe Aeson.Value) + } -- ^ Direction: Client -> Server + | Next { id :: !UUID, nextPayload :: UndecodedJSON } -- ^ Direction: Server -> Client + | Error { id :: !UUID, errorPayload :: [Text] } -- ^ Direction: Server -> Client + | Complete { id :: !UUID } -- ^ Direction: bidirectional + deriving (Show) + +instance WSApp GraphQLWSApp where + initialState = GraphQLWSApp { subscriptions = HashMap.empty, asyncs = [] } + + run = do + userIdVar <- newIORef Nothing + ensureRLSEnabled <- makeCachedEnsureRLSEnabled + installTableChangeTriggers <- ChangeNotifications.makeCachedInstallTableChangeTriggers + let pgListener = ?applicationContext |> get #pgListener + + forever do + message <- Aeson.eitherDecodeStrict' <$> receiveData @ByteString + + case message of + Right decodedMessage -> do + Exception.mask \restore -> do + -- Handle the messages in an async way + -- This increases throughput as multiple queries can be fetched + -- in parallel + handlerProcess <- async $ restore do + result <- Exception.try (handleMessage userIdVar ensureRLSEnabled installTableChangeTriggers pgListener decodedMessage) + + case result of + Left (e :: Exception.SomeException) -> do + let errorMessage = case fromException e of + Just (enhancedSqlError :: EnhancedSqlError) -> cs (get #sqlErrorMsg (get #sqlError enhancedSqlError)) + Nothing -> cs (displayException e) + Log.error (tshow e) + error errorMessage + Right result -> pure () + + modifyIORef' ?state (\state -> state |> modify #asyncs (handlerProcess:)) + pure () + Left errorMessage -> error ("Invalid message: " <> cs errorMessage) + + onClose = cleanupAllSubscriptions + +cleanupAllSubscriptions :: _ => (?state :: IORef GraphQLWSApp, ?applicationContext :: ApplicationContext) => IO () +cleanupAllSubscriptions = do + state <- getState + + case state of + GraphQLWSApp { asyncs } -> forEach asyncs uninterruptibleCancel + _ -> pure () + +handleMessage :: (?state :: IORef GraphQLWSApp, ?connection :: WebSockets.Connection, ?modelContext :: ModelContext, ?context :: ControllerContext) => IORef (Maybe UUID) -> _ -> _ -> _ -> Message -> IO () +handleMessage userIdVar _ _ _ Ping = sendJSON Pong +handleMessage userIdVar _ _ _ ConnectionInit { connectionInitPayload } = do + initAuth userIdVar connectionInitPayload + sendJSON ConnectionAck +handleMessage userIdVar ensureRLSEnabled installTableChangeTriggers pgListener Subscribe { id, operationName, query, variables, extensions } = + let + subscriptionId = id + handleEnhancedSqlError (exception :: EnhancedSqlError) = sendJSON Error { id = id, errorPayload = [ cs $ get #sqlErrorMsg (get #sqlError exception) ] } + handleSomeException (exception :: SomeException) = sendJSON Error { id = id, errorPayload = [ tshow exception ] } + + handleError :: IO () -> IO () + handleError inner = (inner `Exception.catch` handleEnhancedSqlError) `catch` handleSomeException + in handleError do + let document = case AttoparsecText.parseOnly GraphQL.parseDocument query of + Left parserError -> error (cs $ tshow parserError) + Right statements -> statements + + tablesRLS <- ensureRLSEnabledForGraphQLDocument ensureRLSEnabled document + + let emptyVariables = GraphQL.Variables [] + let [(theQuery, theParams)] = GraphQL.compileDocument (fromMaybe emptyVariables variables) document + + userId <- readIORef userIdVar + [PG.Only (graphQLResult :: UndecodedJSON)] <- sqlQueryWithRLS' userId theQuery theParams + + if GraphQL.isSubscriptionDocument document + then do + ensureBelowSubscriptionsLimit + + let (UndecodedJSON graphQLResultText) = graphQLResult + let (Just decodedGraphQLResult) = Aeson.decode (cs graphQLResultText) + + -- We keep an in-memory version of the result to apply db changes to + graphVar <- newIORef decodedGraphQLResult + + -- We need to keep track of all the ids of entities we're watching to make + -- sure that we only send update notifications to clients that can actually + -- access the record (e.g. if a RLS policy denies access) + let watchedRecordIds = GraphQL.recordIds document decodedGraphQLResult + + -- Store it in IORef as an INSERT requires us to add an id + watchedRecordIdsRef <- newIORef watchedRecordIds + + -- Make sure the database triggers are there + forEach tablesRLS installTableChangeTriggers + + let callback table notification = case notification of + ChangeNotifications.DidInsert { id } -> do + -- The new record could not be accessible to the current user with a RLS policy + -- E.g. it could be a new record in a 'projects' table, but the project belongs + -- to a different user, and thus the current user should not be able to see it. + -- + -- The new record could also be not part of the WHERE condition of the initial query. + -- Therefore we need to use the subscriptions WHERE condition to fetch the new record here. + -- + -- To honor the RLS policies we therefore need to fetch the record as the current user + -- If the result set is empty, we know the record is not accesible to us + [PG.Only (UndecodedJSON graphQLResultText)] <- sqlQueryWithRLS' userId theQuery theParams + let (Just graphQLResult) = Aeson.decode (cs graphQLResultText) + + case GraphQL.extractRecordById id graphQLResult of + Just (Aeson.Object newRecord) -> do + -- Add the new record to 'watchedRecordIdsRef' + -- Otherwise the updates and deletes will not be dispatched to the client + modifyIORef' watchedRecordIdsRef (HashMap.adjust (Set.insert id) table) + + modifyIORef' graphVar (GraphQL.insertRecord table id newRecord document) + + nextPayload <- UndecodedJSON . cs .Aeson.encode <$> readIORef graphVar + sendJSON Next { id = subscriptionId, nextPayload } + _ -> pure () + ChangeNotifications.DidUpdate { id, changeSet } -> do + -- Only send the notifcation if the deleted record was part of the initial + -- results set + isWatchingRecord <- Set.member id . HashMap.lookupDefault Set.empty table <$> readIORef watchedRecordIdsRef + when isWatchingRecord do + let (Aeson.Object patch) = changesToValue changeSet + modifyIORef' graphVar (GraphQL.updateRecord table id patch document) + + nextPayload <- UndecodedJSON . cs . Aeson.encode <$> readIORef graphVar + sendJSON Next { id = subscriptionId, nextPayload } + ChangeNotifications.DidDelete { id } -> do + -- Only send the notifcation if the deleted record was part of the initial + -- results set + isWatchingRecord <- Set.member id . HashMap.lookupDefault Set.empty table <$> readIORef watchedRecordIdsRef + when isWatchingRecord do + modifyIORef' graphVar (GraphQL.deleteRecord table id document) + nextPayload <- UndecodedJSON . cs . Aeson.encode <$> readIORef graphVar + sendJSON Next { id = subscriptionId, nextPayload } + + let startWatchers tablesRLS = case tablesRLS of + (tableNameRLS:rest) -> do + let subscribe = PGListener.subscribeJSON (ChangeNotifications.channelName tableNameRLS) (callback (get #tableName tableNameRLS)) pgListener + let unsubscribe subscription = PGListener.unsubscribe subscription pgListener + + Exception.bracket subscribe unsubscribe (\_ -> startWatchers rest) + [] -> do + close <- MVar.newEmptyMVar + modifyIORef' ?state (\state -> state |> modify #subscriptions (HashMap.insert id close)) + + sendJSON Next { id, nextPayload = graphQLResult } + + MVar.takeMVar close + + startWatchers tablesRLS + else do + sendJSON Next { id, nextPayload = graphQLResult } + sendJSON Complete { id } + + pure () +handleMessage _ _ _ _ message = do + putStrLn (tshow message) + +instance FromJSON Message where + parseJSON = withObject "Message" $ \v -> do + type_ :: Text <- v .: "type" + + case type_ of + "connection_init" -> do + payload <- v .: "payload" + pure ConnectionInit { connectionInitPayload = payload } + "ping" -> pure Ping + "pong" -> pure Pong + "subscribe" -> do + id <- v .: "id" + payload <- v .: "payload" + operationName <- payload .:? "operationName" + query <- payload .: "query" + variables <- payload .:? "variables" + extensions <- payload .:? "extensions" + pure Subscribe { id, operationName, query, variables, extensions } + "complete" -> do + id <- v .: "id" + pure Complete { id } + type_ -> fail "Invalid type" + +instance ToJSON Message where + toJSON ConnectionAck = object [ "type" .= ("connection_ack" :: Text) ] + toJSON Ping = object [ "type" .= ("ping" :: Text) ] + toJSON Pong = object [ "type" .= ("pong" :: Text) ] + toJSON Next { id, nextPayload } = object [ "type" .= ("next" :: Text), "id" .= id, "payload" .= nextPayload ] + toJSON Error { id, errorPayload } = object [ "type" .= ("error" :: Text), "id" .= id, "payload" .= errorPayload ] + toJSON Complete { id } = object [ "type" .= ("complete" :: Text), "id" .= id ] + + toEncoding ConnectionAck = Aeson.unsafeToEncoding "{\"type\":\"connection_ack\"}" + toEncoding Ping = Aeson.unsafeToEncoding "{\"type\":\"ping\"}" + toEncoding Pong = Aeson.unsafeToEncoding "{\"type\":\"pong\"}" + toEncoding Next { id, nextPayload } = Aeson.econcat + [ Aeson.unsafeToEncoding "{\"type\":\"next\",\"id\":" + , Aeson.toEncoding id + , Aeson.unsafeToEncoding ",\"payload\":{\"data\":" + , toEncoding nextPayload + , Aeson.unsafeToEncoding "}}" + ] + toEncoding Error { id, errorPayload } = Aeson.econcat + [ Aeson.unsafeToEncoding "{\"type\":\"error\",\"id\":" + , Aeson.toEncoding id + , Aeson.unsafeToEncoding ",\"payload\":{\"data\":" + , toEncoding errorPayload + , Aeson.unsafeToEncoding "}}" + ] + toEncoding Complete { id } = Aeson.econcat + [ Aeson.unsafeToEncoding "{\"type\":\"complete\",\"id\":" + , Aeson.toEncoding id + , Aeson.unsafeToEncoding "}" + ] + + +instance SetField "subscriptions" GraphQLWSApp (HashMap UUID (MVar.MVar ())) where + setField subscriptions record = record { subscriptions } + +instance SetField "asyncs" GraphQLWSApp [Async ()] where + setField asyncs record = record { asyncs } + +ensureRLSEnabledForGraphQLDocument :: _ -> GraphQL.Document -> IO [TableWithRLS] +ensureRLSEnabledForGraphQLDocument ensureRLSEnabled document = do + let tables = document + |> GraphQL.tablesUsedInDocument + |> Set.toList + mapM ensureRLSEnabled tables + +ensureBelowSubscriptionsLimit :: (?state :: IORef GraphQLWSApp, ?context :: ControllerContext) => IO () +ensureBelowSubscriptionsLimit = do + subscriptions <- get #subscriptions <$> readIORef ?state + let subscriptionsCount = HashMap.size subscriptions + when (subscriptionsCount >= maxSubscriptionsPerConnection) do + error ("You've reached the subscriptions limit of " <> tshow maxSubscriptionsPerConnection <> " subscriptions") + +maxSubscriptionsPerConnection :: _ => Int +maxSubscriptionsPerConnection = + case getAppConfig @DataSyncMaxSubscriptionsPerConnection of + DataSyncMaxSubscriptionsPerConnection value -> value + +initAuth userIdVar options = do + let jwt = HashMap.lookup "jwt" options + case jwt of + Just (Aeson.String jwt) -> loginWithJWT userIdVar jwt + otherwise -> pure () + +loginWithJWT userIdVar jwt = do + let signature = JWT.decodeAndVerifySignature (getAppConfig @JWT.Signer) jwt + + case signature of + Just jwt -> do + let userId = jwt + |> JWT.claims + |> JWT.sub + |> fromMaybe (error "JWT missing sub") + |> JWT.stringOrURIToText + |> UUID.fromText + + writeIORef userIdVar userId + Nothing -> error "Invalid signature" \ No newline at end of file diff --git a/IHP/GraphQL/Introspection.hs b/IHP/GraphQL/Introspection.hs new file mode 100644 index 000000000..ca02a6f47 --- /dev/null +++ b/IHP/GraphQL/Introspection.hs @@ -0,0 +1,159 @@ +module IHP.GraphQL.Introspection where + +import IHP.Prelude +import IHP.GraphQL.Types +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Text as Text + +resolveStaticGraph :: StaticGraph -> Document -> StaticGraph +resolveStaticGraph graph document@(Document { definitions = (ExecutableDefinition { operation = OperationDefinition { selectionSet } }:rest) }) = mergeManyNodes $ map (makeSubGraph graph) selectionSet + where + nameOrAlias :: Selection -> Text + nameOrAlias field = fromMaybe (get #name field) (get #alias field) + + findFragmentByName :: Document -> Text -> Fragment + findFragmentByName document name = + let + allFragmentNames = document + |> get #definitions + |> mapMaybe (\case FragmentDefinition (Fragment { name }) -> Just name; _ -> Nothing) + couldNotFindFragmentErrorMessage = "Could not find fragment named " <> name <> ". These fragments are defined: " <> Text.intercalate ", " allFragmentNames + in + document + |> get #definitions + |> find (\case + FragmentDefinition (Fragment { name = fragmentName }) -> name == fragmentName + otherwise -> False + ) + |> fromMaybe (error couldNotFindFragmentErrorMessage) + |> \case + FragmentDefinition fragment -> fragment + + makeSubGraph :: StaticGraph -> Selection -> StaticGraph + makeSubGraph graph field@(Field { name, selectionSet = [] }) = + let + targetLeaf = graph + |> (\case + ObjectNode { objectValues } -> objectValues + otherwise -> error $ "expected object node, got " <> tshow otherwise + ) + |> HashMap.lookup name + |> \case + Just leaf@(Leaf value) -> leaf + otherwise -> error $ "expected leaf node at " <> name <> ", got " <> tshow otherwise <> " in graph " <> tshow graph + in + ObjectNode { objectValues = HashMap.singleton (nameOrAlias field) targetLeaf } + makeSubGraph graph field@(Field { name, selectionSet }) = + let + targetNode :: StaticGraph + targetNode = graph + |> (\case + ObjectNode { objectValues } -> objectValues + otherwise -> error $ "expected object node, got " <> tshow otherwise + ) + |> HashMap.lookup name + |> fromMaybe (error $ "Could not find node " <> name) + in + case targetNode of + ObjectNode {} -> + ObjectNode { objectValues = HashMap.singleton (nameOrAlias field) (mergeManyNodes $ map (makeSubGraph targetNode) selectionSet) } + ArrayNode { arrayElements } -> + ObjectNode { objectValues = HashMap.singleton (nameOrAlias field) (ArrayNode (map (\targetNode -> mergeManyNodes $ map (makeSubGraph targetNode) selectionSet) arrayElements)) } + Leaf { value = NullValue } -> ObjectNode { objectValues = HashMap.singleton (nameOrAlias field) (Leaf NullValue) } + otherwise -> error $ "Expected object or array, got " <> tshow otherwise <> " while trying to access " <> name + makeSubGraph graph FragmentSpread { fragmentName } = + let + fragment = findFragmentByName document fragmentName + selectionSet = get #selectionSet fragment + in + mergeManyNodes (map (makeSubGraph graph) selectionSet) + +mergeNodes (ObjectNode { objectValues = a }) (ObjectNode { objectValues = b }) = ObjectNode { objectValues = HashMap.union b a } +mergeManyNodes = foldl' mergeNodes (ObjectNode HashMap.empty) + +introspectionGraph :: [Definition] -> StaticGraph +introspectionGraph definitions = + object + [ ("__schema", object + [ ("queryType", object [ ("name", Leaf (StringValue "Query")) ]) + , ("mutationType", object [ ("name", Leaf (StringValue "Mutation")) ] ) + , ("subscriptionType", object [ ("name", Leaf (StringValue "Subscription")) ] ) + , ("types", types definitions) + , ("directives", ArrayNode []) + ] + ) + ] + +types definitions = ArrayNode (mapMaybe introspectType definitions) + where + introspectType TypeSystemDefinition { typeSystemDefinition = TypeDefinition ObjectTypeDefinition { name, fieldDefinitions } } = + Just $ object + [ ("kind", Leaf (StringValue "OBJECT")) + , ("name", Leaf (StringValue name)) + , ("description", Leaf (StringValue "")) + , ("fields", ArrayNode (map introspectFieldDefinition fieldDefinitions)) + , ("inputFields", Leaf NullValue) + , ("interfaces", ArrayNode []) + , ("enumValues", Leaf NullValue) + , ("possibleTypes", Leaf NullValue) + ] + introspectType TypeSystemDefinition { typeSystemDefinition = TypeDefinition InputObjectTypeDefinition { name, fieldDefinitions } } = + Just $ object + [ ("kind", Leaf (StringValue "INPUT_OBJECT")) + , ("name", Leaf (StringValue name)) + , ("description", Leaf (StringValue "")) + , ("fields", Leaf NullValue) + , ("inputFields", ArrayNode (map introspectInputFieldDefinition fieldDefinitions)) + , ("interfaces", Leaf NullValue) + , ("enumValues", Leaf NullValue) + , ("possibleTypes", Leaf NullValue) + ] + introspectType _ = Nothing + +introspectInputFieldDefinition FieldDefinition { description, name, argumentsDefinition, type_ } = + object + [ ("name", Leaf (StringValue name)) + , ("description", Leaf (maybe NullValue StringValue description)) + , ("type", introspectType type_) + , ("defaultValue", Leaf NullValue) + ] + +introspectFieldDefinition FieldDefinition { description, name, argumentsDefinition, type_ } = + object + [ ("name", Leaf (StringValue name)) + , ("description", Leaf (maybe NullValue StringValue description)) + , ("args", ArrayNode (map introspectArgumentDefinition argumentsDefinition )) + , ("type", introspectType type_) + , ("isDeprecated", Leaf NullValue) + , ("deprecationReason", Leaf NullValue) + ] + +introspectArgumentDefinition ArgumentDefinition { name, argumentType, defaultValue } = + object + [ ("name", Leaf (StringValue name)) + , ("description", Leaf NullValue) + , ("type", introspectType argumentType) + , ("defaultValue", Leaf (fromMaybe NullValue defaultValue)) + ] + +introspectType :: Type -> StaticGraph +introspectType (NamedType name) = + object + [ ("kind", Leaf (StringValue "OBJECT")) + , ("name", Leaf (StringValue name)) + , ("ofType", Leaf NullValue) + ] +introspectType (ListType inner) = + object + [ ("kind", Leaf (StringValue "LIST")) + , ("name", Leaf NullValue) + , ("ofType", introspectType inner) + ] +introspectType (NonNullType inner) = + object + [ ("kind", Leaf (StringValue "NON_NULL")) + , ("name", Leaf NullValue) + , ("ofType", introspectType inner) + ] + +object values = ObjectNode (HashMap.fromList values) \ No newline at end of file diff --git a/IHP/GraphQL/JSON.hs b/IHP/GraphQL/JSON.hs index 7d6b3e9cf..cd4de9d81 100644 --- a/IHP/GraphQL/JSON.hs +++ b/IHP/GraphQL/JSON.hs @@ -4,7 +4,7 @@ import IHP.Prelude import qualified IHP.GraphQL.Types as GraphQL import qualified IHP.GraphQL.Parser as GraphQL import qualified Data.Aeson as Aeson -import Data.Aeson ((.:)) +import Data.Aeson ((.:), (.=)) import qualified Data.HashMap.Strict as HashMap import qualified Data.Attoparsec.Text as Attoparsec @@ -33,3 +33,11 @@ aesonValueToGraphQLValue (Aeson.String text) = GraphQL.StringValue text aesonValueToGraphQLValue (Aeson.Bool bool) = GraphQL.BooleanValue bool aesonValueToGraphQLValue (Aeson.Object hashMap) = GraphQL.ObjectValue (HashMap.map aesonValueToGraphQLValue hashMap) aesonValueToGraphQLValue Aeson.Null = GraphQL.NullValue + +instance Aeson.ToJSON GraphQL.GraphQLErrorResponse where + toJSON GraphQL.GraphQLErrorResponse { errors } = Aeson.object + [ "data" .= Aeson.Null + , "errors" .= map errorToObj errors + ] + where + errorToObj text = Aeson.object [ "message" .= text ] diff --git a/IHP/GraphQL/Parser.hs b/IHP/GraphQL/Parser.hs index 9be5432c3..d4cae64c2 100644 --- a/IHP/GraphQL/Parser.hs +++ b/IHP/GraphQL/Parser.hs @@ -12,7 +12,7 @@ import Data.Attoparsec.Text import qualified Data.HashMap.Strict as HashMap parseDocument :: Parser Document -parseDocument = Document <$> many1 parseDefinition +parseDocument = Document <$> (manyTill parseDefinition endOfInput) parseDefinition :: Parser Definition parseDefinition = skipSpace >> (executableDefinition <|> parseFragmentDefinition) @@ -40,7 +40,13 @@ parseFragmentDefinition = do skipSpace name <- parseName skipSpace - selectionSet <- parseSelectionSet + on <- option Nothing do + string "on" + skipSpace + type_ <- parseType + skipSpace + pure (Just type_) + selectionSet <- parseSelectionSet ("fragment " <> cs name) pure (FragmentDefinition Fragment { name, selectionSet }) @@ -125,6 +131,7 @@ parseArgument = do char ':' skipSpace argumentValue <- parseValue + skipSpace pure Argument { argumentName, argumentValue } parseValue :: Parser Value @@ -142,13 +149,21 @@ parseValue = do |> map (\Argument { argumentName, argumentValue } -> (argumentName, argumentValue)) |> HashMap.fromList pure (ObjectValue hashMap) - let string = do + let true = do + string "true" + skipSpace + pure $ BooleanValue True + let false = do + string "false" + skipSpace + pure $ BooleanValue False + let stringLit = do char '"' body <- takeTill (== '\"') char '"' skipSpace pure (StringValue body) - (variable "Variable") <|> (object "Object") <|> (string "String") + (variable "Variable") <|> (object "Object") <|> (stringLit "String") <|> true <|> false parseName :: Parser Text parseName = takeWhile1 isNameChar "Name" diff --git a/IHP/GraphQL/Patch.hs b/IHP/GraphQL/Patch.hs new file mode 100644 index 000000000..48a2bf2dd --- /dev/null +++ b/IHP/GraphQL/Patch.hs @@ -0,0 +1,40 @@ +module IHP.GraphQL.Patch where + +import IHP.Prelude +import IHP.GraphQL.Types +import IHP.GraphQL.Analysis +import qualified Data.Aeson as Aeson +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Vector as Vector +import qualified Data.UUID as UUID + +insertRecord :: Text -> UUID -> HashMap Text Aeson.Value -> Document -> Aeson.Value -> Aeson.Value +insertRecord tableName id object document result = foldl' (\json path -> applyFunctionAtNode insertRecordsAtNode path json) result paths + where + paths = nodePathsForTable tableName document + insertRecordsAtNode (Aeson.Array vector) = Aeson.Array (Vector.snoc vector (Aeson.Object object)) + +updateRecord :: Text -> UUID -> HashMap Text Aeson.Value -> Document -> Aeson.Value -> Aeson.Value +updateRecord tableName id patch document result = foldl' (\json path -> applyFunctionAtNode updateRecordsAtNode path json) result paths + where + paths = nodePathsForTable tableName document + updateRecordsAtNode (Aeson.Array vector) = Aeson.Array (Vector.map updateRecordAtNode vector) + updateRecordAtNode value@(Aeson.Object hashMap) = + if isRecordIdEq id value + then Aeson.Object (HashMap.union patch hashMap) + else value + +deleteRecord :: Text -> UUID -> Document -> Aeson.Value -> Aeson.Value +deleteRecord tableName id document result = foldl' (\json path -> applyFunctionAtNode deleteRecordAtNode path json) result paths + where + paths = nodePathsForTable tableName document + deleteRecordAtNode (Aeson.Array vector) = Aeson.Array (Vector.filter (not . isRecordIdEq id) vector) + +isRecordIdEq :: UUID -> Aeson.Value -> Bool +isRecordIdEq id (Aeson.Object hashMap) = + case HashMap.lookup "id" hashMap of + Just (Aeson.String uuid) -> + case UUID.fromText uuid of + Just uuid -> uuid == id + Nothing -> False + otherwise -> False \ No newline at end of file diff --git a/IHP/GraphQL/Resolver.hs b/IHP/GraphQL/Resolver.hs new file mode 100644 index 000000000..2c9c781db --- /dev/null +++ b/IHP/GraphQL/Resolver.hs @@ -0,0 +1,54 @@ +module IHP.GraphQL.Resolver where + +import IHP.Prelude +import IHP.GraphQL.Types +import qualified IHP.GraphQL.Introspection as Introspection +import qualified IHP.GraphQL.Analysis as Analysis +import qualified IHP.GraphQL.Compiler as Compiler +import IHP.DataSync.DynamicQuery (UndecodedJSON (UndecodedJSON)) +import qualified Data.Aeson as Aeson +import qualified Data.Vector as Vector +import qualified Data.HashMap.Strict as HashMap +import qualified Database.PostgreSQL.Simple as PG + +resolve schema sqlQueryWithRLS graphQLRequest = do + let rootQuery = get #query graphQLRequest + let variables = get #variables graphQLRequest + + rootQuery + |> Analysis.splitDocumentIntoResolvableUnits + |> \case + -- Avoid decoding the JSON in the common fast-path with a single resolver + [(PostgresResolver, document)] -> resolvePostgres sqlQueryWithRLS variables document + multipleResolvers -> do + results <- forM multipleResolvers \(resolver, document) -> do + case resolver of + PostgresResolver -> undecodedJSONToAesonValue <$> (resolvePostgres sqlQueryWithRLS variables document) + IntrospectionResolver -> pure $ staticGraphToAesonValue (resolveIntrospection schema document) + let mergedResult = (foldl1 mergeAeson results) + pure $ UndecodedJSON (cs $ Aeson.encode mergedResult) + +resolvePostgres sqlQueryWithRLS variables document = do + let [(theQuery, theParams)] = Compiler.compileDocument variables document + result <- sqlQueryWithRLS theQuery theParams + case result of + [PG.Only graphQLResult] -> pure graphQLResult + otherwise -> error "resolvePostgres: Unexpected result" + +resolveIntrospection schema document = Introspection.resolveStaticGraph (Introspection.introspectionGraph schema) document + +undecodedJSONToAesonValue :: UndecodedJSON -> Aeson.Value +undecodedJSONToAesonValue (UndecodedJSON json) = case Aeson.decode (cs json) of + Just result -> result + Nothing -> error "undecodedJSONToAesonValue: Failed to decode postgres result" + +staticGraphToAesonValue :: StaticGraph -> Aeson.Value +staticGraphToAesonValue ObjectNode { objectValues } = Aeson.Object (HashMap.map staticGraphToAesonValue objectValues) +staticGraphToAesonValue ArrayNode { arrayElements } = Aeson.Array (Vector.fromList $ map staticGraphToAesonValue arrayElements) +staticGraphToAesonValue Leaf { value } = valueToAeson value + where + valueToAeson (StringValue string) = Aeson.toJSON string + valueToAeson (BooleanValue boolean) = Aeson.toJSON boolean + valueToAeson NullValue = Aeson.Null + +mergeAeson (Aeson.Object a) (Aeson.Object b) = Aeson.Object (HashMap.union b a) \ No newline at end of file diff --git a/IHP/GraphQL/SchemaCompiler.hs b/IHP/GraphQL/SchemaCompiler.hs index f425c9c45..7662d359b 100644 --- a/IHP/GraphQL/SchemaCompiler.hs +++ b/IHP/GraphQL/SchemaCompiler.hs @@ -7,7 +7,6 @@ import IHP.IDE.SchemaDesigner.Types type SqlSchema = [Statement] -type GraphQLSchema = [Definition] sqlSchemaToGraphQLSchema :: SqlSchema -> GraphQLSchema sqlSchemaToGraphQLSchema statements = @@ -56,15 +55,22 @@ mutationDefinition statements = TypeSystemDefinition { typeSystemDefinition = Ty statementToQueryField :: Statement -> [FieldDefinition] statementToQueryField (StatementCreateTable CreateTable { name }) = - [ manyRecordsField ] + [ manyRecordsField, singleRecordField ] 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)))) + } + singleRecordField = FieldDefinition + { description = Just ("Returns a single record from the `" <> name <> "` table") + , name = lcfirst (tableNameToModelName name) + , argumentsDefinition = [ + ArgumentDefinition { name = "id", argumentType = NonNullType (NamedType "UUID"), defaultValue = Nothing } + ] + , type_ = NonNullType (NamedType (tableNameToModelName name)) } - type_ = NonNullType (ListType (NonNullType (NamedType (tableNameToModelName name)))) statementToQueryField _ = [] statementToMutationFields :: Statement -> [FieldDefinition] diff --git a/IHP/GraphQL/Types.hs b/IHP/GraphQL/Types.hs index 16d23022a..ba5568295 100644 --- a/IHP/GraphQL/Types.hs +++ b/IHP/GraphQL/Types.hs @@ -8,6 +8,22 @@ data GraphQLRequest = GraphQLRequest , variables :: !Variables } +type GraphQLSchema = [Definition] + +-- An error response that renders to JSON like this: +-- +-- > { +-- > "data": null, +-- > "errors": [ +-- > { "message": "error 1" } +-- > ] +-- > } +-- +-- We don't support partial responses, so @data@ will always be @null@ in an error case +data GraphQLErrorResponse = GraphQLErrorResponse + { errors :: ![Text] + } + -- https://spec.graphql.org/June2018/#sec-Appendix-Grammar-Summary.Document newtype Document = Document { definitions :: [Definition] } @@ -122,4 +138,15 @@ data Type = NamedType !Text | ListType !Type | NonNullType !Type + deriving (Eq, Show) + +data StaticGraph + = ObjectNode { objectValues :: !(HashMap Text StaticGraph) } + | ArrayNode { arrayElements :: ![StaticGraph] } + | Leaf { value :: !Value } + deriving (Eq, Show) + +data Resolver + = PostgresResolver + | IntrospectionResolver deriving (Eq, Show) \ No newline at end of file diff --git a/IHP/IDE/CodeGen/MigrationGenerator.hs b/IHP/IDE/CodeGen/MigrationGenerator.hs index 66f52f1cf..f46c799bb 100644 --- a/IHP/IDE/CodeGen/MigrationGenerator.hs +++ b/IHP/IDE/CodeGen/MigrationGenerator.hs @@ -23,8 +23,8 @@ import IHP.IDE.SchemaDesigner.Compiler (compileSql) import IHP.IDE.CodeGen.Types import qualified IHP.LibDir as LibDir -buildPlan :: Text -> Maybe Text -> IO (Int, [GeneratorAction]) -buildPlan description sqlStatements = do +buildPlan :: ByteString -> Text -> Maybe Text -> IO (Int, [GeneratorAction]) +buildPlan databaseUrl description sqlStatements = do revision <- round <$> POSIX.getPOSIXTime let slug = NameSupport.toSlug description let migrationFile = tshow revision <> (if isEmpty slug then "" else "-" <> slug) <> ".sql" @@ -32,7 +32,7 @@ buildPlan description sqlStatements = do migrationSql <- case sqlStatements of Just sql -> pure sql Nothing -> do - appDiff <- diffAppDatabase + appDiff <- diffAppDatabase databaseUrl pure $ if isEmpty appDiff then "-- Write your SQL migration code in here\n" else compileSql appDiff @@ -41,10 +41,10 @@ buildPlan description sqlStatements = do , CreateFile { filePath = "Application/Migration/" <> migrationFile, fileContent = migrationSql } ]) -diffAppDatabase = do +diffAppDatabase databaseUrl = do (Right schemaSql) <- Parser.parseSchemaSql (Right ihpSchemaSql) <- parseIHPSchema - actualSchema <- getAppDBSchema + actualSchema <- getAppDBSchema databaseUrl let targetSchema = ihpSchemaSql <> schemaSql @@ -310,9 +310,9 @@ migrateEnum CreateEnumType { name, values = targetValues } CreateEnumType { valu addValue :: Text -> Statement addValue value = AddValueToEnumType { enumName = name, newValue = value, ifNotExists = True } -getAppDBSchema :: IO [Statement] -getAppDBSchema = do - sql <- dumpAppDatabaseSchema +getAppDBSchema :: ByteString -> IO [Statement] +getAppDBSchema databaseUrl = do + sql <- dumpAppDatabaseSchema databaseUrl case parseDumpedSql sql of Left error -> fail (cs error) Right result -> pure result @@ -320,10 +320,10 @@ getAppDBSchema = do -- | Returns the DDL statements of the locally running dev db -- -- Basically does the same as @make dumpdb@ but returns the output as a string -dumpAppDatabaseSchema :: IO Text -dumpAppDatabaseSchema = do +dumpAppDatabaseSchema :: ByteString -> IO Text +dumpAppDatabaseSchema databaseUrl = do projectDir <- Directory.getCurrentDirectory - cs <$> Process.readProcess "pg_dump" ["-s", "--no-owner", "--no-acl", "-h", projectDir <> "/build/db", "app"] [] + cs <$> Process.readProcess "pg_dump" ["-s", "--no-owner", "--no-acl", cs databaseUrl] [] parseDumpedSql :: Text -> (Either ByteString [Statement]) parseDumpedSql sql = diff --git a/IHP/IDE/Graph/Controller.hs b/IHP/IDE/Graph/Controller.hs new file mode 100644 index 000000000..b93425c71 --- /dev/null +++ b/IHP/IDE/Graph/Controller.hs @@ -0,0 +1,75 @@ +module IHP.IDE.Graph.Controller where + +import IHP.ControllerPrelude +import IHP.IDE.ToolServer.Types + +import IHP.IDE.Graph.View.Explore +import IHP.IDE.Graph.View.Schema + +import qualified IHP.IDE.SchemaDesigner.Parser as SchemaDesigner +import qualified IHP.GraphQL.ToText as GraphQL +import qualified IHP.GraphQL.SchemaCompiler as GraphQL +import qualified Database.PostgreSQL.Simple as PG +import IHP.IDE.Data.Controller (connectToAppDb, fetchRowsPage) + +import qualified Web.JWT as JWT +import qualified Data.Time.Clock.POSIX as Time +import qualified Control.Exception as Exception +import qualified Data.Maybe as Maybe +import qualified Data.ByteString as BS + +instance Controller GraphController where + action ExploreAction = do + SchemaDesigner.parseSchemaSql >>= \case + Left parserError -> fail (cs parserError) + Right sqlSchema -> do + let schema = GraphQL.sqlSchemaToGraphQLSchema sqlSchema + render ExploreView { .. } + + action SchemaAction = do + SchemaDesigner.parseSchemaSql >>= \case + Left parserError -> fail (cs parserError) + Right sqlSchema -> do + let schema = GraphQL.sqlSchemaToGraphQLSchema sqlSchema + render SchemaView { .. } + + action GraphUsersAction = do + connection <- connectToAppDb + rows :: [[DynamicField]] <- fetchRowsPage connection "users" 1 50 + + PG.close connection + + renderJson rows + + action GetJWTForUserId { userId } = do + let lifetime = 60 * 60 * 24 * 3 + + createdAt <- getCurrentTime + expiredAt <- addUTCTime lifetime <$> getCurrentTime + + let claimsSet = mempty + { JWT.iss = (JWT.stringOrURI "https://ihp-dev-identity.digitallyinduced.com/") + , JWT.sub = JWT.stringOrURI (tshow userId) + , JWT.iat = JWT.numericDate (Time.utcTimeToPOSIXSeconds createdAt) + , JWT.exp = JWT.numericDate (Time.utcTimeToPOSIXSeconds expiredAt) + } + + jwtSigner <- initJWTSigner + let token = JWT.encodeSigned jwtSigner mempty claimsSet + renderPlain (cs token) + +initJWTSigner :: IO JWT.Signer +initJWTSigner = do + appJwt <- Exception.try @Exception.SomeException (BS.readFile "Application/jwt.key") + + let privateKeyText = + case appJwt of + Left _ -> error "Could not find JWT" + Right result -> result + + + privateKeyText + |> JWT.readRsaSecret + |> Maybe.fromJust + |> JWT.RSAPrivateKey + |> pure diff --git a/IHP/IDE/Graph/View/Explore.hs b/IHP/IDE/Graph/View/Explore.hs new file mode 100644 index 000000000..3738de7bf --- /dev/null +++ b/IHP/IDE/Graph/View/Explore.hs @@ -0,0 +1,20 @@ +module IHP.IDE.Graph.View.Explore where + +import IHP.ViewPrelude +import IHP.IDE.ToolServer.Types +import qualified IHP.GraphQL.Types as GraphQL +import qualified IHP.GraphQL.SchemaCompiler as GraphQL +import qualified IHP.GraphQL.ToText as GraphQL +import IHP.IDE.Graph.View.Layout + +data ExploreView + = ExploreView + { schema :: GraphQL.GraphQLSchema } + +instance View ExploreView where + html ExploreView { .. } = [hsx| +
+ {headerNav} +
+
+ |] \ No newline at end of file diff --git a/IHP/IDE/Graph/View/Layout.hs b/IHP/IDE/Graph/View/Layout.hs new file mode 100644 index 000000000..3d24670e5 --- /dev/null +++ b/IHP/IDE/Graph/View/Layout.hs @@ -0,0 +1,45 @@ +module IHP.IDE.Graph.View.Layout +( headerNav +) where + +import IHP.ViewPrelude +import IHP.IDE.ToolServer.Types +import IHP.IDE.ToolServer.Routes +import qualified Data.Text as Text +import IHP.IDE.ToolServer.Helper.View + +headerNav :: Html +headerNav = [hsx| +
+
+ + Explore + + + + Schema + + +
+
+ {url} +
+
+
+
+|] + where + exploreActive :: Bool + exploreActive = isActivePath ExploreAction + + schemaActive :: Bool + schemaActive = isActivePath SchemaAction + + url :: Text + url = "http://localhost:8000/api/graphql" \ No newline at end of file diff --git a/IHP/IDE/Graph/View/Schema.hs b/IHP/IDE/Graph/View/Schema.hs new file mode 100644 index 000000000..c7c2d23ba --- /dev/null +++ b/IHP/IDE/Graph/View/Schema.hs @@ -0,0 +1,18 @@ +module IHP.IDE.Graph.View.Schema where + +import IHP.ViewPrelude +import IHP.IDE.ToolServer.Types +import qualified IHP.GraphQL.Types as GraphQL +import qualified IHP.GraphQL.SchemaCompiler as GraphQL +import qualified IHP.GraphQL.ToText as GraphQL +import IHP.IDE.Graph.View.Layout + +data SchemaView + = SchemaView + { schema :: GraphQL.GraphQLSchema } + +instance View SchemaView where + html SchemaView { .. } = [hsx| + {headerNav} + 
{GraphQL.toText schema}
+ |] \ No newline at end of file diff --git a/IHP/IDE/SchemaDesigner/Controller/Migrations.hs b/IHP/IDE/SchemaDesigner/Controller/Migrations.hs index 600056c65..87dda6ecb 100644 --- a/IHP/IDE/SchemaDesigner/Controller/Migrations.hs +++ b/IHP/IDE/SchemaDesigner/Controller/Migrations.hs @@ -45,14 +45,14 @@ instance Controller MigrationsController where action NewMigrationAction = do let description = paramOrDefault "" "description" - (_, plan) <- MigrationGenerator.buildPlan description Nothing + (_, plan) <- MigrationGenerator.buildPlan theDatabaseUrl description Nothing let runMigration = paramOrDefault True "runMigration" render NewView { .. } action CreateMigrationAction = do let description = paramOrDefault "" "description" let sqlStatements = paramOrNothing "sqlStatements" - (revision, plan) <- MigrationGenerator.buildPlan description sqlStatements + (revision, plan) <- MigrationGenerator.buildPlan theDatabaseUrl description sqlStatements let path = MigrationGenerator.migrationPathFromPlan plan executePlan plan @@ -63,7 +63,18 @@ instance Controller MigrationsController where setSuccessMessage ("Migration generated: " <> path) openEditor path 0 0 else do - migrateAppDB revision + result <- Exception.try (migrateAppDB revision) + case result of + Left (exception :: SomeException) -> do + let errorMessage = case fromException exception of + Just (exception :: EnhancedSqlError) -> cs $ get #sqlErrorMsg (get #sqlError exception) + Nothing -> tshow exception + + setErrorMessage errorMessage + redirectTo MigrationsAction + Right _ -> do + clearDatabaseNeedsMigration + redirectTo MigrationsAction clearDatabaseNeedsMigration @@ -153,4 +164,10 @@ withAppModelContext inner = pure (frameworkConfig, logger, modelContext) cleanupModelContext (frameworkConfig, logger, modelContext) = do - logger |> cleanup \ No newline at end of file + logger |> cleanup + +theDatabaseUrl :: (?context :: ControllerContext) => ByteString +theDatabaseUrl = + ?context + |> getFrameworkConfig + |> get #databaseUrl \ No newline at end of file diff --git a/IHP/IDE/SchemaDesigner/View/Layout.hs b/IHP/IDE/SchemaDesigner/View/Layout.hs index 510986ea8..bdafae6f5 100644 --- a/IHP/IDE/SchemaDesigner/View/Layout.hs +++ b/IHP/IDE/SchemaDesigner/View/Layout.hs @@ -350,6 +350,7 @@ suggestedColumnsSection tableName indexAndColumns = unless isUsersTable [hsx| +