IHP GraphQL Standalone

.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"
 

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
 --

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)
 

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

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.
         --

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 }