From 6a63bbd6a017fe8cbf4f5c1ea2a2b6fb56c978b7 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Sun, 22 Mar 2026 11:33:03 +0100 Subject: [PATCH] Extract ihp-rowlevelsecurity package from ihp and ihp-datasync Move hasql-level RLS primitives (statements, sessions, role management, introspection) into a dedicated package with no dependency on ihp core. This makes the RLS building blocks reusable by both ihp and ihp-datasync, and introduces convenience wrappers (withRLS, withRLSPipeline, setRLSConfig) that simplify the existing inline RLS branching. New modules: - IHP.RowLevelSecurity.Types: RowLevelSecurityContext, TableWithRLS - IHP.RowLevelSecurity.Statement: all hasql Statement values - IHP.RowLevelSecurity.Session: withRLS, withRLSPipeline, setRLSConfig - IHP.RowLevelSecurity.Role: ensureAuthenticatedRole, grantPermissions - IHP.RowLevelSecurity.Introspection: ensureRLSEnabled, rlsPolicyColumns + caching Co-Authored-By: Claude Opus 4.6 (1M context) --- NixSupport/overlay.nix | 1 + cabal.project | 1 + ihp-datasync/IHP/DataSync/Role.hs | 89 +++----- ihp-datasync/IHP/DataSync/RowLevelSecurity.hs | 199 +++++------------- ihp-datasync/ihp-datasync.cabal | 1 + ihp-rowlevelsecurity/IHP/RowLevelSecurity.hs | 14 ++ .../IHP/RowLevelSecurity/Introspection.hs | 84 ++++++++ .../IHP/RowLevelSecurity/Role.hs | 58 +++++ .../IHP/RowLevelSecurity/Session.hs | 66 ++++++ .../IHP/RowLevelSecurity/Statement.hs | 85 ++++++++ .../IHP/RowLevelSecurity/Types.hs | 22 ++ ihp-rowlevelsecurity/LICENSE | 21 ++ ihp-rowlevelsecurity/changelog.md | 5 + .../ihp-rowlevelsecurity.cabal | 47 +++++ ihp/IHP/FetchPipelined.hs | 40 +--- ihp/IHP/ModelSupport.hs | 39 +--- ihp/IHP/ModelSupport/Types.hs | 8 +- ihp/ihp.cabal | 1 + 18 files changed, 501 insertions(+), 280 deletions(-) create mode 100644 ihp-rowlevelsecurity/IHP/RowLevelSecurity.hs create mode 100644 ihp-rowlevelsecurity/IHP/RowLevelSecurity/Introspection.hs create mode 100644 ihp-rowlevelsecurity/IHP/RowLevelSecurity/Role.hs create mode 100644 ihp-rowlevelsecurity/IHP/RowLevelSecurity/Session.hs create mode 100644 ihp-rowlevelsecurity/IHP/RowLevelSecurity/Statement.hs create mode 100644 ihp-rowlevelsecurity/IHP/RowLevelSecurity/Types.hs create mode 100644 ihp-rowlevelsecurity/LICENSE create mode 100644 ihp-rowlevelsecurity/changelog.md create mode 100644 ihp-rowlevelsecurity/ihp-rowlevelsecurity.cabal diff --git a/NixSupport/overlay.nix b/NixSupport/overlay.nix index 31d54b656..bf2f9569f 100644 --- a/NixSupport/overlay.nix +++ b/NixSupport/overlay.nix @@ -71,6 +71,7 @@ let wai-request-params = hackageOrLocal "wai-request-params"; ihp-imagemagick = hackageOrLocal "ihp-imagemagick"; ihp-hspec = hackageOrLocal "ihp-hspec"; + ihp-rowlevelsecurity = hackageOrLocal "ihp-rowlevelsecurity"; ihp-welcome = hackageOrLocal "ihp-welcome"; # Lazy session middleware: defer cookie decryption until first access, diff --git a/cabal.project b/cabal.project index 79efa7f5e..9e0ef09b9 100644 --- a/cabal.project +++ b/cabal.project @@ -12,3 +12,4 @@ packages: wai-asset-path/ wai-flash-messages/ wai-request-params/ + ihp-rowlevelsecurity/ diff --git a/ihp-datasync/IHP/DataSync/Role.hs b/ihp-datasync/IHP/DataSync/Role.hs index 4749d29f3..5da9a1c40 100644 --- a/ihp-datasync/IHP/DataSync/Role.hs +++ b/ihp-datasync/IHP/DataSync/Role.hs @@ -13,71 +13,39 @@ wrap it in a transaction and then use 'SET LOCAL ROLE ..' to switch to our second role for the duration of the transaction. -} -module IHP.DataSync.Role where +module IHP.DataSync.Role +( -- * Re-exported from "IHP.RowLevelSecurity.Role" + ensureAuthenticatedRole +, createAuthenticatedRole +, grantPermissions +, quoteIdentifier + -- * IHP-specific wrappers +, authenticatedRole +, ensureAuthenticatedRoleExists +, ensureAuthenticatedRoleExistsWithRole +, ensureAuthenticatedRoleSession +) where import IHP.Prelude import IHP.FrameworkConfig -import qualified Data.Text as Text import qualified Hasql.Pool -import qualified Hasql.Decoders as Decoders -import qualified Hasql.Encoders as Encoders -import qualified Hasql.Statement as Statement import qualified Hasql.Session as Session import IHP.DataSync.Hasql (runSession) --- Statements - -doesRoleExistsStatement :: Statement.Statement Text Bool -doesRoleExistsStatement = Statement.preparable - "SELECT EXISTS(SELECT 1 FROM pg_roles WHERE rolname = $1 LIMIT 1)" - (Encoders.param (Encoders.nonNullable Encoders.text)) - (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.bool))) - --- Sessions +-- Re-exports from the dedicated package +import IHP.RowLevelSecurity.Role + ( ensureAuthenticatedRole + , createAuthenticatedRole + , grantPermissions + , quoteIdentifier + ) +-- | Idempotent: ensure the role exists and has permissions. +-- Reads the role name from 'FrameworkConfig'. ensureAuthenticatedRoleSession :: (?context :: context, ConfigProvider context) => Session.Session () -ensureAuthenticatedRoleSession = do - let role = authenticatedRole - roleExists <- Session.statement role doesRoleExistsStatement - unless roleExists (createAuthenticatedRoleSession role) - grantPermissionsSession role - -createAuthenticatedRoleSession :: Text -> Session.Session () -createAuthenticatedRoleSession role = do - -- The role is only going to be used from 'SET ROLE ..' calls - -- Therefore we can disallow direct connection with NOLOGIN - Session.statement () (Statement.unpreparable - ("CREATE ROLE " <> quoteIdentifier role <> " NOLOGIN") - Encoders.noParams - Decoders.noResult) - -grantPermissionsSession :: Text -> Session.Session () -grantPermissionsSession role = do - -- From SO https://stackoverflow.com/a/17355059/14144232 - -- - -- GRANTs on different objects are separate. GRANTing on a database doesn't GRANT rights to the schema within. Similiarly, GRANTing on a schema doesn't grant rights on the tables within. - -- - -- If you have rights to SELECT from a table, but not the right to see it in the schema that contains it then you can't access the table. - -- - -- The rights tests are done in order: - -- - -- Do you have `USAGE` on the schema? - -- No: Reject access. - -- Yes: Do you also have the appropriate rights on the table? - -- No: Reject access. - -- Yes: Check column privileges. - - let exec sql = Session.statement () (Statement.unpreparable sql Encoders.noParams Decoders.noResult) - - -- The role should have access to all existing tables in our schema - exec ("GRANT USAGE ON SCHEMA public TO " <> quoteIdentifier role) - - -- The role should have access to all existing tables in our schema - exec ("GRANT ALL PRIVILEGES ON ALL TABLES IN SCHEMA public TO " <> quoteIdentifier role) - - -- Also grant access to all tables created in the future - exec ("ALTER DEFAULT PRIVILEGES IN SCHEMA public GRANT ALL PRIVILEGES ON TABLES TO " <> quoteIdentifier role) +ensureAuthenticatedRoleSession = ensureAuthenticatedRole authenticatedRole +-- | IO wrapper using the pool. Reads the role name from 'FrameworkConfig'. ensureAuthenticatedRoleExists :: (?context :: context, ConfigProvider context) => Hasql.Pool.Pool -> IO () ensureAuthenticatedRoleExists pool = runSession pool ensureAuthenticatedRoleSession @@ -85,15 +53,8 @@ ensureAuthenticatedRoleExists pool = runSession pool ensureAuthenticatedRoleSess -- instead of reading it from the framework config. Used by 'initHasqlPoolWithRLS' -- at config-build time when 'FrameworkConfig' is not yet available. ensureAuthenticatedRoleExistsWithRole :: Hasql.Pool.Pool -> Text -> IO () -ensureAuthenticatedRoleExistsWithRole pool role = runSession pool $ do - roleExists <- Session.statement role doesRoleExistsStatement - unless roleExists (createAuthenticatedRoleSession role) - grantPermissionsSession role +ensureAuthenticatedRoleExistsWithRole pool role = runSession pool (ensureAuthenticatedRole role) +-- | The authenticated role name from 'FrameworkConfig'. authenticatedRole :: (?context :: context, ConfigProvider context) => Text authenticatedRole = ?context.frameworkConfig.rlsAuthenticatedRole - --- | Quote a SQL identifier (role name, table name, etc.) to prevent SQL injection. --- Escapes embedded double quotes by doubling them per SQL standard. -quoteIdentifier :: Text -> Text -quoteIdentifier name = "\"" <> Text.replace "\"" "\"\"" name <> "\"" diff --git a/ihp-datasync/IHP/DataSync/RowLevelSecurity.hs b/ihp-datasync/IHP/DataSync/RowLevelSecurity.hs index beafa2199..8b00a1d4a 100644 --- a/ihp-datasync/IHP/DataSync/RowLevelSecurity.hs +++ b/ihp-datasync/IHP/DataSync/RowLevelSecurity.hs @@ -1,70 +1,67 @@ module IHP.DataSync.RowLevelSecurity -( ensureRLSEnabled +( -- * Re-exported from "IHP.RowLevelSecurity" + ensureRLSEnabled , hasRLSEnabled , TableWithRLS (..) , makeCachedEnsureRLSEnabled +, hasRLSEnabledSession +, ensureRLSEnabledSession +, setRLSConfigStatement +, rlsPolicyColumns +, makeCachedRLSPolicyColumns + -- * IHP-specific session wrappers , sqlQueryWithRLS , sqlQueryWriteWithRLS , sqlExecWithRLS , sqlQueryScalarWithRLS -, hasRLSEnabledSession -, ensureRLSEnabledSession , sqlQueryWithRLSSession , sqlQueryWriteWithRLSSession , sqlExecWithRLSSession , sqlQueryScalarWithRLSSession -, setRLSConfigStatement , setRLSConfigSession -, rlsPolicyColumns -, makeCachedRLSPolicyColumns ) where -import IHP.ControllerPrelude hiding (sqlQuery, sqlExec, sqlQueryScalar) +import IHP.ControllerPrelude hiding (sqlQuery, sqlExec, sqlQueryScalar, setRLSConfigStatement) import qualified Hasql.Pool -import qualified Hasql.Decoders as Decoders -import qualified Hasql.Encoders as Encoders +import qualified Hasql.Session import qualified Hasql.Statement as Statement -import qualified Hasql.Session as Session import qualified Hasql.Transaction as Tx import qualified Hasql.Transaction.Sessions as Tx import qualified IHP.DataSync.Role as Role -import qualified Data.Set as Set -import qualified Data.HashMap.Strict as HashMap import IHP.DataSync.Hasql (runSession) --- Statements - -hasRLSEnabledStatement :: Statement.Statement Text Bool -hasRLSEnabledStatement = Statement.preparable - "SELECT relrowsecurity FROM pg_class WHERE oid = quote_ident($1)::regclass" - (Encoders.param (Encoders.nonNullable Encoders.text)) - (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.bool))) - --- Sessions - -hasRLSEnabledSession :: Text -> Session.Session Bool -hasRLSEnabledSession table = Session.statement table hasRLSEnabledStatement - -ensureRLSEnabledSession :: Text -> Session.Session TableWithRLS -ensureRLSEnabledSession table = do - rlsEnabled <- hasRLSEnabledSession table - unless rlsEnabled (error "Row level security is required for accessing this table") - pure (TableWithRLS table) - --- | Set RLS config (role and user id) in the current transaction. +-- Re-exports from the dedicated package +import IHP.RowLevelSecurity + ( TableWithRLS(..) + , ensureRLSEnabled + , hasRLSEnabled + , makeCachedEnsureRLSEnabled + , hasRLSEnabledSession + , ensureRLSEnabledSession + , rlsPolicyColumns + , makeCachedRLSPolicyColumns + ) +import IHP.RowLevelSecurity.Statement (setRLSConfigStatement) +import qualified IHP.RowLevelSecurity.Session as RLS + +-- | Set RLS config (role and user id) in the current session. -- -- This is a Session-level action for use in user-managed transactions --- (e.g. after a manual @BEGIN@). +-- (e.g. after a manual @BEGIN@). Reads the user from 'currentUserOrNothing'. setRLSConfigSession :: ( ?context :: ControllerContext , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord , Typeable CurrentUserRecord , HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord)) - ) => Session.Session () -setRLSConfigSession = Session.statement (Role.authenticatedRole, encodedUserId) setRLSConfigStatement + ) => Hasql.Session.Session () +setRLSConfigSession = RLS.setRLSConfig rlsContext where + rlsContext = RowLevelSecurityContext + { rlsAuthenticatedRole = Role.authenticatedRole + , rlsUserId = encodedUserId + } encodedUserId = case (.id) <$> currentUserOrNothing of Just userId -> tshow userId Nothing -> "" @@ -75,33 +72,34 @@ sqlQueryWithRLSSession :: , HasNewSessionUrl CurrentUserRecord , Typeable CurrentUserRecord , HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord)) - ) => Statement.Statement () [result] -> Session.Session [result] + ) => Statement.Statement () [result] -> Hasql.Session.Session [result] sqlQueryWithRLSSession statement = - Tx.transaction Tx.ReadCommitted Tx.Read $ do - Tx.statement (Role.authenticatedRole, encodedUserId) setRLSConfigStatement - Tx.statement () statement + RLS.withRLS rlsContext Tx.Read (Tx.statement () statement) where + rlsContext = RowLevelSecurityContext + { rlsAuthenticatedRole = Role.authenticatedRole + , rlsUserId = encodedUserId + } encodedUserId = case (.id) <$> currentUserOrNothing of Just userId -> tshow userId Nothing -> "" {-# INLINE sqlQueryWithRLSSession #-} -- | Like 'sqlQueryWithRLSSession', but uses a write transaction. --- --- Use this for INSERT, UPDATE, or DELETE statements with RETURNING that need --- to return results (e.g. wrapped with 'wrapDynamicQuery'). sqlQueryWriteWithRLSSession :: ( ?context :: ControllerContext , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord , Typeable CurrentUserRecord , HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord)) - ) => Statement.Statement () [result] -> Session.Session [result] + ) => Statement.Statement () [result] -> Hasql.Session.Session [result] sqlQueryWriteWithRLSSession statement = - Tx.transaction Tx.ReadCommitted Tx.Write $ do - Tx.statement (Role.authenticatedRole, encodedUserId) setRLSConfigStatement - Tx.statement () statement + RLS.withRLS rlsContext Tx.Write (Tx.statement () statement) where + rlsContext = RowLevelSecurityContext + { rlsAuthenticatedRole = Role.authenticatedRole + , rlsUserId = encodedUserId + } encodedUserId = case (.id) <$> currentUserOrNothing of Just userId -> tshow userId Nothing -> "" @@ -113,12 +111,14 @@ sqlExecWithRLSSession :: , HasNewSessionUrl CurrentUserRecord , Typeable CurrentUserRecord , HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord)) - ) => Statement.Statement () () -> Session.Session () + ) => Statement.Statement () () -> Hasql.Session.Session () sqlExecWithRLSSession statement = - Tx.transaction Tx.ReadCommitted Tx.Write $ do - Tx.statement (Role.authenticatedRole, encodedUserId) setRLSConfigStatement - Tx.statement () statement + RLS.withRLS rlsContext Tx.Write (Tx.statement () statement) where + rlsContext = RowLevelSecurityContext + { rlsAuthenticatedRole = Role.authenticatedRole + , rlsUserId = encodedUserId + } encodedUserId = case (.id) <$> currentUserOrNothing of Just userId -> tshow userId Nothing -> "" @@ -130,12 +130,14 @@ sqlQueryScalarWithRLSSession :: , HasNewSessionUrl CurrentUserRecord , Typeable CurrentUserRecord , HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord)) - ) => Statement.Statement () result -> Session.Session result + ) => Statement.Statement () result -> Hasql.Session.Session result sqlQueryScalarWithRLSSession statement = - Tx.transaction Tx.ReadCommitted Tx.Read $ do - Tx.statement (Role.authenticatedRole, encodedUserId) setRLSConfigStatement - Tx.statement () statement + RLS.withRLS rlsContext Tx.Read (Tx.statement () statement) where + rlsContext = RowLevelSecurityContext + { rlsAuthenticatedRole = Role.authenticatedRole + , rlsUserId = encodedUserId + } encodedUserId = case (.id) <$> currentUserOrNothing of Just userId -> tshow userId Nothing -> "" @@ -153,10 +155,6 @@ sqlQueryWithRLS :: sqlQueryWithRLS pool statement = runSession pool (sqlQueryWithRLSSession statement) {-# INLINE sqlQueryWithRLS #-} --- | Like 'sqlQueryWithRLS', but uses a write transaction. --- --- Use this for INSERT, UPDATE, or DELETE statements with RETURNING that need --- to return results (e.g. wrapped with 'wrapDynamicQuery'). sqlQueryWriteWithRLS :: ( ?context :: ControllerContext , Show (PrimaryKey (GetTableName CurrentUserRecord)) @@ -186,88 +184,3 @@ sqlQueryScalarWithRLS :: ) => Hasql.Pool.Pool -> Statement.Statement () result -> IO result sqlQueryScalarWithRLS pool statement = runSession pool (sqlQueryScalarWithRLSSession statement) {-# INLINE sqlQueryScalarWithRLS #-} - --- | Returns a proof that RLS is enabled for a table -ensureRLSEnabled :: Hasql.Pool.Pool -> Text -> IO TableWithRLS -ensureRLSEnabled pool table = runSession pool (ensureRLSEnabledSession table) - --- | Returns a factory for 'ensureRLSEnabled' that memoizes when a table has RLS enabled. --- --- When a table doesn't have RLS enabled yet, the result is not memoized. --- --- __Example:__ --- --- > -- Setup --- > ensureRLSEnabled <- makeCachedEnsureRLSEnabled hasqlPool --- > --- > ensureRLSEnabled "projects" -- Runs a database query to check if row level security is enabled for the projects table --- > --- > -- Asuming 'ensureRLSEnabled "projects"' proceeded without errors: --- > --- > ensureRLSEnabled "projects" -- Now this will instantly return True and don't fire any SQL queries anymore --- -makeCachedEnsureRLSEnabled :: Hasql.Pool.Pool -> IO (Text -> IO TableWithRLS) -makeCachedEnsureRLSEnabled pool = do - tables <- newIORef Set.empty - pure \tableName -> do - rlsEnabled <- Set.member tableName <$> readIORef tables - - if rlsEnabled - then pure TableWithRLS { tableName } - else do - proof <- ensureRLSEnabled pool tableName - modifyIORef' tables (Set.insert tableName) - pure proof - --- | Returns 'True' if row level security has been enabled on a table --- --- RLS can be enabled with this SQL statement: --- --- > ALTER TABLE my_table ENABLE ROW LEVEL SECURITY; --- --- After this 'hasRLSEnabled' will return true: --- --- >>> hasRLSEnabled pool "my_table" --- True -hasRLSEnabled :: Hasql.Pool.Pool -> Text -> IO Bool -hasRLSEnabled pool table = runSession pool (hasRLSEnabledSession table) - --- | Can be constructed using 'ensureRLSEnabled' --- --- > tableWithRLS <- ensureRLSEnabled "my_table" --- --- Useful to carry a proof that the RLS is actually enabled -newtype TableWithRLS = TableWithRLS { tableName :: Text } deriving (Eq, Ord) - --- | Prepared statement to query which columns a table's RLS policies reference. --- --- Checks both @USING@ (@polqual@) and @WITH CHECK@ (@polwithcheck@) expressions. -rlsPolicyColumnsStatement :: Statement.Statement Text [Text] -rlsPolicyColumnsStatement = Statement.preparable - "SELECT DISTINCT a.attname::text FROM pg_policy p JOIN pg_class c ON c.oid = p.polrelid JOIN pg_attribute a ON a.attrelid = c.oid AND a.attnum > 0 WHERE c.relname = $1 AND (pg_get_expr(p.polqual, p.polrelid) LIKE '%' || a.attname || '%' OR pg_get_expr(p.polwithcheck, p.polrelid) LIKE '%' || a.attname || '%')" - (Encoders.param (Encoders.nonNullable Encoders.text)) - (Decoders.rowList (Decoders.column (Decoders.nonNullable Decoders.text))) - --- | Returns the set of column names referenced in a table's RLS policies. --- --- >>> rlsPolicyColumns pool "messages" --- fromList ["user_id"] -rlsPolicyColumns :: Hasql.Pool.Pool -> Text -> IO (Set.Set Text) -rlsPolicyColumns pool table = do - results <- runSession pool (Session.statement table rlsPolicyColumnsStatement) - pure (Set.fromList results) - --- | Returns a cached version of 'rlsPolicyColumns'. --- --- Queries once per table, caches forever for the connection lifetime. -makeCachedRLSPolicyColumns :: Hasql.Pool.Pool -> IO (Text -> IO (Set.Set Text)) -makeCachedRLSPolicyColumns pool = do - cache <- newIORef HashMap.empty - pure \tableName -> do - cached <- HashMap.lookup tableName <$> readIORef cache - case cached of - Just columns -> pure columns - Nothing -> do - columns <- rlsPolicyColumns pool tableName - modifyIORef' cache (HashMap.insert tableName columns) - pure columns diff --git a/ihp-datasync/ihp-datasync.cabal b/ihp-datasync/ihp-datasync.cabal index f96d12ffa..b72096f7e 100644 --- a/ihp-datasync/ihp-datasync.cabal +++ b/ihp-datasync/ihp-datasync.cabal @@ -54,6 +54,7 @@ common shared-properties , ihp , ihp-log , ihp-hsx + , ihp-rowlevelsecurity , deepseq , safe-exceptions , http-types diff --git a/ihp-rowlevelsecurity/IHP/RowLevelSecurity.hs b/ihp-rowlevelsecurity/IHP/RowLevelSecurity.hs new file mode 100644 index 000000000..1ef978f63 --- /dev/null +++ b/ihp-rowlevelsecurity/IHP/RowLevelSecurity.hs @@ -0,0 +1,14 @@ +module IHP.RowLevelSecurity +( module IHP.RowLevelSecurity.Types +, module IHP.RowLevelSecurity.Statement +, module IHP.RowLevelSecurity.Session +, module IHP.RowLevelSecurity.Role +, module IHP.RowLevelSecurity.Introspection +) where + +import Prelude () +import IHP.RowLevelSecurity.Types +import IHP.RowLevelSecurity.Statement +import IHP.RowLevelSecurity.Session +import IHP.RowLevelSecurity.Role +import IHP.RowLevelSecurity.Introspection diff --git a/ihp-rowlevelsecurity/IHP/RowLevelSecurity/Introspection.hs b/ihp-rowlevelsecurity/IHP/RowLevelSecurity/Introspection.hs new file mode 100644 index 000000000..63cf7ef5f --- /dev/null +++ b/ihp-rowlevelsecurity/IHP/RowLevelSecurity/Introspection.hs @@ -0,0 +1,84 @@ +module IHP.RowLevelSecurity.Introspection +( hasRLSEnabled +, ensureRLSEnabled +, makeCachedEnsureRLSEnabled +, rlsPolicyColumns +, makeCachedRLSPolicyColumns +) where + +import Prelude +import Control.Exception (throwIO) +import Data.IORef +import Data.Text (Text) +import qualified Data.Set as Set +import qualified Data.HashMap.Strict as HashMap +import qualified Hasql.Pool as Pool +import qualified Hasql.Session as Session +import IHP.RowLevelSecurity.Types +import IHP.RowLevelSecurity.Session (hasRLSEnabledSession, ensureRLSEnabledSession) +import IHP.RowLevelSecurity.Statement (rlsPolicyColumnsStatement) + +-- | Check whether a table has RLS enabled. +-- +-- >>> hasRLSEnabled pool "my_table" +-- True +hasRLSEnabled :: Pool.Pool -> Text -> IO Bool +hasRLSEnabled pool table = runSession pool (hasRLSEnabledSession table) + +-- | Check that a table has RLS enabled, returning a 'TableWithRLS' proof. +-- Throws an error if RLS is not enabled. +ensureRLSEnabled :: Pool.Pool -> Text -> IO TableWithRLS +ensureRLSEnabled pool table = runSession pool (ensureRLSEnabledSession table) + +-- | Returns a memoizing wrapper around 'ensureRLSEnabled'. +-- +-- Once a table has been verified to have RLS, subsequent checks for the +-- same table return instantly without hitting the database. Tables that +-- fail the check are not cached (they may have RLS enabled later). +-- +-- > ensureRLS <- makeCachedEnsureRLSEnabled pool +-- > ensureRLS "projects" -- hits database +-- > ensureRLS "projects" -- instant, cached +makeCachedEnsureRLSEnabled :: Pool.Pool -> IO (Text -> IO TableWithRLS) +makeCachedEnsureRLSEnabled pool = do + tables <- newIORef Set.empty + pure \tableName -> do + rlsEnabled <- Set.member tableName <$> readIORef tables + if rlsEnabled + then pure TableWithRLS { tableName } + else do + proof <- ensureRLSEnabled pool tableName + modifyIORef' tables (Set.insert tableName) + pure proof + +-- | Returns the set of column names referenced in a table's RLS policies. +-- +-- >>> rlsPolicyColumns pool "messages" +-- fromList ["user_id"] +rlsPolicyColumns :: Pool.Pool -> Text -> IO (Set.Set Text) +rlsPolicyColumns pool table = do + results <- runSession pool (Session.statement table rlsPolicyColumnsStatement) + pure (Set.fromList results) + +-- | Returns a cached version of 'rlsPolicyColumns'. +-- +-- Queries once per table, caches forever for the pool lifetime. +makeCachedRLSPolicyColumns :: Pool.Pool -> IO (Text -> IO (Set.Set Text)) +makeCachedRLSPolicyColumns pool = do + cache <- newIORef HashMap.empty + pure \tableName -> do + cached <- HashMap.lookup tableName <$> readIORef cache + case cached of + Just columns -> pure columns + Nothing -> do + columns <- rlsPolicyColumns pool tableName + modifyIORef' cache (HashMap.insert tableName columns) + pure columns + +-- | Run a session on the pool, throwing on failure. +runSession :: Pool.Pool -> Session.Session a -> IO a +runSession pool session = do + result <- Pool.use pool session + case result of + Left err -> throwIO err + Right val -> pure val diff --git a/ihp-rowlevelsecurity/IHP/RowLevelSecurity/Role.hs b/ihp-rowlevelsecurity/IHP/RowLevelSecurity/Role.hs new file mode 100644 index 000000000..7da3f5aa3 --- /dev/null +++ b/ihp-rowlevelsecurity/IHP/RowLevelSecurity/Role.hs @@ -0,0 +1,58 @@ +module IHP.RowLevelSecurity.Role +( ensureAuthenticatedRole +, createAuthenticatedRole +, grantPermissions +, doesRoleExist +, quoteIdentifier +) where + +import Prelude +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Hasql.Decoders as Decoders +import qualified Hasql.Encoders as Encoders +import qualified Hasql.Statement as Statement +import qualified Hasql.Session as Session +import IHP.RowLevelSecurity.Statement (doesRoleExistStatement) + +-- | Idempotent: ensure the authenticated role exists and has permissions. +-- +-- Checks @pg_roles@, creates the role with @NOLOGIN@ if missing, +-- then grants @USAGE ON SCHEMA public@ and @ALL PRIVILEGES ON ALL TABLES@. +ensureAuthenticatedRole :: Text -> Session.Session () +ensureAuthenticatedRole role = do + roleExists <- Session.statement role doesRoleExistStatement + unless roleExists (createAuthenticatedRole role) + grantPermissions role + +-- | Create a PostgreSQL role with @NOLOGIN@. +-- +-- The role is intended to be used only via @SET ROLE@ inside transactions. +-- Direct connections are disallowed. +createAuthenticatedRole :: Text -> Session.Session () +createAuthenticatedRole role = + Session.statement () (Statement.unpreparable + ("CREATE ROLE " <> quoteIdentifier role <> " NOLOGIN") + Encoders.noParams + Decoders.noResult) + +-- | Grant the role access to the @public@ schema and all tables within it. +grantPermissions :: Text -> Session.Session () +grantPermissions role = do + let exec sql = Session.statement () (Statement.unpreparable sql Encoders.noParams Decoders.noResult) + exec ("GRANT USAGE ON SCHEMA public TO " <> quoteIdentifier role) + exec ("GRANT ALL PRIVILEGES ON ALL TABLES IN SCHEMA public TO " <> quoteIdentifier role) + exec ("ALTER DEFAULT PRIVILEGES IN SCHEMA public GRANT ALL PRIVILEGES ON TABLES TO " <> quoteIdentifier role) + +-- | Check whether a PostgreSQL role exists. +doesRoleExist :: Text -> Session.Session Bool +doesRoleExist role = Session.statement role doesRoleExistStatement + +-- | Quote a SQL identifier to prevent SQL injection. +-- Escapes embedded double quotes by doubling them per SQL standard. +quoteIdentifier :: Text -> Text +quoteIdentifier name = "\"" <> Text.replace "\"" "\"\"" name <> "\"" + +-- Local Prelude bits (we don't depend on ihp) +unless :: Applicative f => Bool -> f () -> f () +unless p action = if p then pure () else action diff --git a/ihp-rowlevelsecurity/IHP/RowLevelSecurity/Session.hs b/ihp-rowlevelsecurity/IHP/RowLevelSecurity/Session.hs new file mode 100644 index 000000000..e9fbc4b5d --- /dev/null +++ b/ihp-rowlevelsecurity/IHP/RowLevelSecurity/Session.hs @@ -0,0 +1,66 @@ +module IHP.RowLevelSecurity.Session +( setRLSConfig +, withRLS +, withRLSPipeline +, hasRLSEnabledSession +, ensureRLSEnabledSession +) where + +import Prelude +import Data.Text (Text) +import IHP.RowLevelSecurity.Types +import IHP.RowLevelSecurity.Statement +import qualified Hasql.Session as Session +import qualified Hasql.Transaction as Tx +import qualified Hasql.Transaction.Sessions as Tx +import qualified Hasql.Pipeline as Pipeline +import qualified Hasql.Statement as Statement + +-- | Set the RLS role and user id in the current session. +-- +-- Use this after a manual @BEGIN@ (e.g. in 'withTransaction') to activate +-- RLS for all subsequent statements in the transaction. +setRLSConfig :: RowLevelSecurityContext -> Session.Session () +setRLSConfig ctx = Session.statement (ctx.rlsAuthenticatedRole, ctx.rlsUserId) setRLSConfigStatement + +-- | Wrap a transaction body with RLS config. +-- +-- Opens a @ReadCommitted@ transaction in the given mode, sets the RLS role +-- and user id, then runs the provided transaction body. +-- +-- > withRLS ctx Tx.Read $ do +-- > Tx.statement input myStatement +withRLS :: RowLevelSecurityContext -> Tx.Mode -> Tx.Transaction a -> Session.Session a +withRLS ctx mode tx = Tx.transaction Tx.ReadCommitted mode $ do + Tx.statement (ctx.rlsAuthenticatedRole, ctx.rlsUserId) setRLSConfigStatement + tx + +-- | Sandwich a pipeline with RLS set/reset statements. +-- +-- Uses session-scoped config (not transaction-local) because each pipelined +-- statement runs in its own implicit transaction. The reset at the end +-- restores the connection to its default role. +-- +-- > withRLSPipeline ctx $ do +-- > result1 <- Pipeline.statement input1 stmt1 +-- > result2 <- Pipeline.statement input2 stmt2 +-- > pure (result1, result2) +withRLSPipeline :: RowLevelSecurityContext -> Pipeline.Pipeline a -> Pipeline.Pipeline a +withRLSPipeline ctx p = + (\_ a _ -> a) + <$> Pipeline.statement (ctx.rlsAuthenticatedRole, ctx.rlsUserId) setRLSConfigPipelineStatement + <*> p + <*> Pipeline.statement () resetRLSConfigPipelineStatement + +-- | Check whether a table has RLS enabled. +hasRLSEnabledSession :: Text -> Session.Session Bool +hasRLSEnabledSession table = Session.statement table hasRLSEnabledStatement + +-- | Check that a table has RLS enabled, returning a 'TableWithRLS' proof. +-- Throws an error if RLS is not enabled. +ensureRLSEnabledSession :: Text -> Session.Session TableWithRLS +ensureRLSEnabledSession table = do + rlsEnabled <- hasRLSEnabledSession table + if rlsEnabled + then pure (TableWithRLS table) + else error "Row level security is required for accessing this table" diff --git a/ihp-rowlevelsecurity/IHP/RowLevelSecurity/Statement.hs b/ihp-rowlevelsecurity/IHP/RowLevelSecurity/Statement.hs new file mode 100644 index 000000000..559021e20 --- /dev/null +++ b/ihp-rowlevelsecurity/IHP/RowLevelSecurity/Statement.hs @@ -0,0 +1,85 @@ +module IHP.RowLevelSecurity.Statement +( setRLSConfigStatement +, setRLSConfigPipelineStatement +, resetRLSConfigPipelineStatement +, hasRLSEnabledStatement +, rlsPolicyColumnsStatement +, doesRoleExistStatement +) where + +import Prelude +import Data.Functor.Contravariant (contramap) +import Data.Functor.Contravariant.Divisible (conquer) +import Data.Text (Text) +import qualified Hasql.Decoders as Decoders +import qualified Hasql.Encoders as Encoders +import qualified Hasql.Statement as Statement + +-- | Set the PostgreSQL role and @rls.ihp_user_id@ GUC for the current transaction. +-- +-- Uses @set_config(setting, value, is_local)@ with @is_local = true@, +-- making the settings transaction-local (equivalent to @SET LOCAL@). +-- The role switch ensures queries are subject to RLS policies. +-- +-- Input: @(authenticatedRole, userId)@ +setRLSConfigStatement :: Statement.Statement (Text, Text) () +setRLSConfigStatement = Statement.preparable + "SELECT set_config('role', $1, true), set_config('rls.ihp_user_id', $2, true)" + (contramap fst (Encoders.param (Encoders.nonNullable Encoders.text)) + <> contramap snd (Encoders.param (Encoders.nonNullable Encoders.text))) + setConfigDecoder + +-- | Session-scoped RLS config for pipeline mode. +-- +-- Uses @is_local = false@ because pipeline mode runs each statement in its own +-- implicit transaction, so transaction-local settings would not carry across +-- statements. Must be paired with 'resetRLSConfigPipelineStatement'. +-- +-- Input: @(authenticatedRole, userId)@ +setRLSConfigPipelineStatement :: Statement.Statement (Text, Text) () +setRLSConfigPipelineStatement = Statement.preparable + "SELECT set_config('role', $1, false), set_config('rls.ihp_user_id', $2, false)" + (contramap fst (Encoders.param (Encoders.nonNullable Encoders.text)) + <> contramap snd (Encoders.param (Encoders.nonNullable Encoders.text))) + setConfigDecoder + +-- | Reset role and RLS user to connection defaults after a pipeline completes. +-- +-- Uses @session_user@ to restore the original connection role, matching +-- the behavior of @RESET ROLE@. +resetRLSConfigPipelineStatement :: Statement.Statement () () +resetRLSConfigPipelineStatement = Statement.preparable + "SELECT set_config('role', session_user::text, false), set_config('rls.ihp_user_id', '', false)" + conquer + setConfigDecoder + +-- | Check whether a table has RLS enabled via @pg_class.relrowsecurity@. +hasRLSEnabledStatement :: Statement.Statement Text Bool +hasRLSEnabledStatement = Statement.preparable + "SELECT relrowsecurity FROM pg_class WHERE oid = quote_ident($1)::regclass" + (Encoders.param (Encoders.nonNullable Encoders.text)) + (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.bool))) + +-- | Query which columns a table's RLS policies reference. +-- +-- Checks both @USING@ (@polqual@) and @WITH CHECK@ (@polwithcheck@) expressions +-- by introspecting @pg_policy@ and @pg_attribute@. +rlsPolicyColumnsStatement :: Statement.Statement Text [Text] +rlsPolicyColumnsStatement = Statement.preparable + "SELECT DISTINCT a.attname::text FROM pg_policy p JOIN pg_class c ON c.oid = p.polrelid JOIN pg_attribute a ON a.attrelid = c.oid AND a.attnum > 0 WHERE c.relname = $1 AND (pg_get_expr(p.polqual, p.polrelid) LIKE '%' || a.attname || '%' OR pg_get_expr(p.polwithcheck, p.polrelid) LIKE '%' || a.attname || '%')" + (Encoders.param (Encoders.nonNullable Encoders.text)) + (Decoders.rowList (Decoders.column (Decoders.nonNullable Decoders.text))) + +-- | Check whether a PostgreSQL role exists via @pg_roles@. +doesRoleExistStatement :: Statement.Statement Text Bool +doesRoleExistStatement = Statement.preparable + "SELECT EXISTS(SELECT 1 FROM pg_roles WHERE rolname = $1 LIMIT 1)" + (Encoders.param (Encoders.nonNullable Encoders.text)) + (Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.bool))) + +-- Internal: shared decoder for set_config() results (two text columns, discarded) +setConfigDecoder :: Decoders.Result () +setConfigDecoder = Decoders.singleRow + (Decoders.column (Decoders.nullable Decoders.text) + *> Decoders.column (Decoders.nullable Decoders.text) + *> pure ()) diff --git a/ihp-rowlevelsecurity/IHP/RowLevelSecurity/Types.hs b/ihp-rowlevelsecurity/IHP/RowLevelSecurity/Types.hs new file mode 100644 index 000000000..aa27fa25b --- /dev/null +++ b/ihp-rowlevelsecurity/IHP/RowLevelSecurity/Types.hs @@ -0,0 +1,22 @@ +module IHP.RowLevelSecurity.Types +( RowLevelSecurityContext (..) +, TableWithRLS (..) +) where + +import Prelude +import Data.Text (Text) + +-- | Runtime context for PostgreSQL Row Level Security. +-- +-- Carried through request processing to transparently wrap queries +-- with @SET LOCAL ROLE@ and @set_config('rls.ihp_user_id', ...)@. +data RowLevelSecurityContext = RowLevelSecurityContext + { rlsAuthenticatedRole :: Text -- ^ The PostgreSQL role to switch to (e.g. @"ihp_authenticated"@). This role is subject to RLS policies, unlike the table owner role. + , rlsUserId :: Text -- ^ The current user's id, serialized as text. Stored in the @rls.ihp_user_id@ GUC for use by the @ihp_user_id()@ SQL function. + } + +-- | Proof that a table has RLS enabled. Constructed via 'IHP.RowLevelSecurity.Introspection.ensureRLSEnabled'. +-- +-- Carrying this value proves that we checked @pg_class.relrowsecurity@ +-- for the table, so downstream code can skip redundant checks. +newtype TableWithRLS = TableWithRLS { tableName :: Text } deriving (Eq, Ord) diff --git a/ihp-rowlevelsecurity/LICENSE b/ihp-rowlevelsecurity/LICENSE new file mode 100644 index 000000000..0f56c5564 --- /dev/null +++ b/ihp-rowlevelsecurity/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2020 digitally induced GmbH + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/ihp-rowlevelsecurity/changelog.md b/ihp-rowlevelsecurity/changelog.md new file mode 100644 index 000000000..9b99da927 --- /dev/null +++ b/ihp-rowlevelsecurity/changelog.md @@ -0,0 +1,5 @@ +# Changelog + +## v1.5.0 + +- Initial release, extracted from ihp and ihp-datasync diff --git a/ihp-rowlevelsecurity/ihp-rowlevelsecurity.cabal b/ihp-rowlevelsecurity/ihp-rowlevelsecurity.cabal new file mode 100644 index 000000000..ffd0438ba --- /dev/null +++ b/ihp-rowlevelsecurity/ihp-rowlevelsecurity.cabal @@ -0,0 +1,47 @@ +cabal-version: 2.2 +name: ihp-rowlevelsecurity +version: 1.5.0 +synopsis: PostgreSQL Row Level Security for hasql +description: Provides hasql statements, sessions, role management, and introspection for PostgreSQL Row Level Security (RLS). Used by IHP but has no dependency on the IHP web framework. +license: MIT +license-file: LICENSE +author: digitally induced GmbH +maintainer: support@digitallyinduced.com +homepage: https://ihp.digitallyinduced.com/ +bug-reports: https://github.com/digitallyinduced/ihp/issues +copyright: (c) digitally induced GmbH +category: Database +build-type: Simple +extra-source-files: changelog.md + +source-repository head + type: git + location: https://github.com/digitallyinduced/ihp + +library + default-language: GHC2021 + default-extensions: + OverloadedStrings + OverloadedRecordDot + DuplicateRecordFields + DisambiguateRecordFields + BlockArguments + ScopedTypeVariables + ghc-options: -Werror=incomplete-patterns -Werror=unused-imports -Werror=missing-fields + build-depends: + base >= 4.17.0 && < 4.22 + , text + , hasql >= 1.4 + , hasql-pool >= 1.3 + , hasql-transaction >= 0.10 + , containers + , unordered-containers + , hashable + hs-source-dirs: . + exposed-modules: + IHP.RowLevelSecurity + IHP.RowLevelSecurity.Types + IHP.RowLevelSecurity.Statement + IHP.RowLevelSecurity.Session + IHP.RowLevelSecurity.Role + IHP.RowLevelSecurity.Introspection diff --git a/ihp/IHP/FetchPipelined.hs b/ihp/IHP/FetchPipelined.hs index 51cfa62d2..c9fb9a801 100644 --- a/ihp/IHP/FetchPipelined.hs +++ b/ihp/IHP/FetchPipelined.hs @@ -35,15 +35,11 @@ import IHP.ModelSupport import IHP.QueryBuilder import IHP.Hasql.FromRow (FromRowHasql(..)) import IHP.Fetch.Statement (buildQueryListStatement, buildQueryMaybeStatement, buildCountStatement, buildExistsStatement) -import qualified Hasql.Decoders as Decoders -import qualified Hasql.Encoders as Encoders import qualified Hasql.Pipeline as Pipeline import qualified Hasql.Session as HasqlSession -import qualified Hasql.Statement as HasqlStatement import qualified IHP.Log as Log import IHP.Hasql.Pool (usePoolWithRetry) -import Data.Functor.Contravariant (contramap) -import Data.Functor.Contravariant.Divisible (conquer) +import qualified IHP.RowLevelSecurity.Session as RLS -- | Convert a query builder into a 'Pipeline' step returning all matching rows. -- @@ -129,17 +125,8 @@ fetchExistsPipelined !queryBuilder = Pipeline.statement () (buildExistsStatement pipeline :: (?modelContext :: ModelContext) => Pipeline.Pipeline a -> IO a pipeline thePipeline = do let pool = ?modelContext.hasqlPool - -- When RLS is enabled and we're not already in a transaction, wrap the - -- pipeline with session-scoped set_config/reset statements. These are - -- part of the same pipeline batch so they add no extra round trips. - -- In pipeline mode the server processes statements sequentially, so the - -- set_config takes effect before the user queries execute. let effectivePipeline = case (?modelContext.transactionRunner, ?modelContext.rowLevelSecurity) of - (Nothing, Just RowLevelSecurityContext { rlsAuthenticatedRole, rlsUserId }) -> - (\_ a _ -> a) - <$> Pipeline.statement (rlsAuthenticatedRole, rlsUserId) setRLSConfigPipelineStatement - <*> thePipeline - <*> Pipeline.statement () resetRLSConfigPipelineStatement + (Nothing, Just rlsContext) -> RLS.withRLSPipeline rlsContext thePipeline _ -> thePipeline let session = HasqlSession.pipeline effectivePipeline let ?context = ?modelContext @@ -149,26 +136,3 @@ pipeline thePipeline = do Nothing -> usePoolWithRetry pool session logQueryTiming currentLogLevel "🔍 Pipeline" runQuery {-# INLINABLE pipeline #-} - --- | Session-scoped RLS config for pipeline mode. --- --- Uses @is_local = false@ (session-scoped) instead of @true@ (transaction-local) --- because pipeline mode runs each statement in its own implicit transaction. --- The companion 'resetRLSConfigPipelineStatement' resets these at the end of --- the pipeline batch. -setRLSConfigPipelineStatement :: HasqlStatement.Statement (Text, Text) () -setRLSConfigPipelineStatement = HasqlStatement.preparable - "SELECT set_config('role', $1, false), set_config('rls.ihp_user_id', $2, false)" - (contramap fst (Encoders.param (Encoders.nonNullable Encoders.text)) - <> contramap snd (Encoders.param (Encoders.nonNullable Encoders.text))) - (Decoders.singleRow (Decoders.column (Decoders.nullable Decoders.text) *> Decoders.column (Decoders.nullable Decoders.text) *> pure ())) - --- | Reset role and RLS user to connection defaults after the pipeline completes. --- --- Uses @session_user@ to restore the original connection role, matching --- the behavior of @RESET ROLE@. -resetRLSConfigPipelineStatement :: HasqlStatement.Statement () () -resetRLSConfigPipelineStatement = HasqlStatement.preparable - "SELECT set_config('role', session_user::text, false), set_config('rls.ihp_user_id', '', false)" - conquer - (Decoders.singleRow (Decoders.column (Decoders.nullable Decoders.text) *> Decoders.column (Decoders.nullable Decoders.text) *> pure ())) diff --git a/ihp/IHP/ModelSupport.hs b/ihp/IHP/ModelSupport.hs index d446f7a7b..be38aed85 100644 --- a/ihp/IHP/ModelSupport.hs +++ b/ihp/IHP/ModelSupport.hs @@ -65,7 +65,8 @@ import Data.Scientific import GHC.Stack import qualified Hasql.Transaction as Tx import qualified Hasql.Transaction.Sessions as Tx -import Data.Functor.Contravariant (contramap) +import qualified IHP.RowLevelSecurity.Statement as RLS +import qualified IHP.RowLevelSecurity.Session as RLS import Control.Concurrent (forkIO, MVar, newEmptyMVar, putMVar, takeMVar) import Control.Monad.IO.Class (liftIO) import Control.Monad.Error.Class (catchError) @@ -308,20 +309,9 @@ sqlExecDiscardResult theQuery theParameters = do {-# INLINABLE sqlExecDiscardResult #-} --- | Prepared statement that sets the RLS role and user id using set_config(). --- --- Uses @set_config(setting, value, is_local)@ which is a regular SQL function --- that supports parameterized values in the extended query protocol, unlike --- @SET LOCAL@ which is a utility command that cannot be parameterized. --- --- The third argument @true@ makes the setting local to the current transaction, --- equivalent to @SET LOCAL@. +-- | Re-exported from "IHP.RowLevelSecurity.Statement". setRLSConfigStatement :: Hasql.Statement (Text, Text) () -setRLSConfigStatement = Hasql.preparable - "SELECT set_config('role', $1, true), set_config('rls.ihp_user_id', $2, true)" - (contramap fst (Encoders.param (Encoders.nonNullable Encoders.text)) - <> contramap snd (Encoders.param (Encoders.nonNullable Encoders.text))) - (Decoders.singleRow (Decoders.column (Decoders.nullable Decoders.text) *> Decoders.column (Decoders.nullable Decoders.text) *> pure ())) +setRLSConfigStatement = RLS.setRLSConfigStatement -- | Runs a hasql 'Hasql.Statement' directly on the pool. -- @@ -338,10 +328,8 @@ sqlStatementHasql pool input statement = do let ?context = ?modelContext let currentLogLevel = ?modelContext.logger.level let session = case (?modelContext.transactionRunner, ?modelContext.rowLevelSecurity) of - (Nothing, Just RowLevelSecurityContext { rlsAuthenticatedRole, rlsUserId }) -> - Tx.transaction Tx.ReadCommitted Tx.Read $ do - Tx.statement (rlsAuthenticatedRole, rlsUserId) setRLSConfigStatement - Tx.statement input statement + (Nothing, Just rlsContext) -> + RLS.withRLS rlsContext Tx.Read (Tx.statement input statement) _ -> Hasql.statement input statement let runQuery = case ?modelContext.transactionRunner of @@ -380,10 +368,8 @@ sqlExecStatement pool input statement = do let session = case (?modelContext.transactionRunner, ?modelContext.rowLevelSecurity) of (Just _, _) -> Hasql.statement input statement - (Nothing, Just RowLevelSecurityContext { rlsAuthenticatedRole, rlsUserId }) -> - Tx.transaction Tx.ReadCommitted Tx.Write $ do - Tx.statement (rlsAuthenticatedRole, rlsUserId) setRLSConfigStatement - Tx.statement input statement + (Nothing, Just rlsContext) -> + RLS.withRLS rlsContext Tx.Write (Tx.statement input statement) _ -> Hasql.statement input statement let runQuery = case ?modelContext.transactionRunner of @@ -410,10 +396,8 @@ sqlExecHasqlCount pool snippet = do let currentLogLevel = ?modelContext.logger.level let statement = Snippet.toPreparableStatement snippet Decoders.rowsAffected let session = case (?modelContext.transactionRunner, ?modelContext.rowLevelSecurity) of - (Nothing, Just RowLevelSecurityContext { rlsAuthenticatedRole, rlsUserId }) -> - Tx.transaction Tx.ReadCommitted Tx.Write $ do - Tx.statement (rlsAuthenticatedRole, rlsUserId) setRLSConfigStatement - Tx.statement () statement + (Nothing, Just rlsContext) -> + RLS.withRLS rlsContext Tx.Write (Tx.statement () statement) _ -> Hasql.statement () statement let runQuery = case ?modelContext.transactionRunner of @@ -541,8 +525,7 @@ withTransaction block let transactionSession = do Hasql.script "BEGIN" case ?modelContext.rowLevelSecurity of - Just RowLevelSecurityContext { rlsAuthenticatedRole, rlsUserId } -> - Hasql.statement (rlsAuthenticatedRole, rlsUserId) setRLSConfigStatement + Just rlsContext -> RLS.setRLSConfig rlsContext Nothing -> pure () -- Fork the user's block in a separate thread diff --git a/ihp/IHP/ModelSupport/Types.hs b/ihp/IHP/ModelSupport/Types.hs index b98b7722d..37f4be63e 100644 --- a/ihp/IHP/ModelSupport/Types.hs +++ b/ihp/IHP/ModelSupport/Types.hs @@ -67,6 +67,7 @@ import GHC.Types import Data.Data import Data.Dynamic import IHP.Log.Types (Logger) +import IHP.RowLevelSecurity.Types (RowLevelSecurityContext(..)) -- | Runner that executes a hasql Session on the current transaction's connection newtype TransactionRunner = TransactionRunner @@ -96,13 +97,6 @@ data ModelContext = ModelContext , rowLevelSecurity :: Maybe RowLevelSecurityContext } --- | When row level security is enabled at runtime, this keeps track of the current --- logged in user and the postgresql role to switch to. -data RowLevelSecurityContext = RowLevelSecurityContext - { rlsAuthenticatedRole :: Text -- ^ Default is @ihp_authenticated@. This value comes from the @IHP_RLS_AUTHENTICATED_ROLE@ env var. - , rlsUserId :: Text -- ^ The user id of the current logged in user - } - type family GetModelById id :: Type where GetModelById (Maybe (Id' tableName)) = Maybe (GetModelByTableName tableName) GetModelById (Id' tableName) = GetModelByTableName tableName diff --git a/ihp/ihp.cabal b/ihp/ihp.cabal index 556fe3264..edf614856 100644 --- a/ihp/ihp.cabal +++ b/ihp/ihp.cabal @@ -128,6 +128,7 @@ common shared-properties , slugger , ihp-imagemagick , wai-request-params + , ihp-rowlevelsecurity , hasql , hasql-pool , hasql-dynamic-statements