Skip to content

Commit 9e21b0c

Browse files
mpscholtenmpscholten
authored
Merge pull request #2358 from digitallyinduced/fix/hasql-pool-database-url
Fix initHasqlPoolWithRLS not picking up DATABASE_URL env var
2 parents 3af8b56 + 332a628 commit 9e21b0c

File tree

5 files changed

+27
-86
lines changed

5 files changed

+27
-86
lines changed

‎NixSupport/overlay.nix‎

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -91,9 +91,11 @@ let
9191
url = "https://hackage.haskell.org/package/postgresql-binary-0.15/postgresql-binary-0.15.tar.gz";
9292
sha256 = "11ysy91rsvdx9n7cjpyhp23ikv3h9b40k6rdggykhjkdv7vdvhj3";
9393
}) {}));
94+
# Patched to fix parsing of empty password in URI format (user:@host)
95+
# See: https://github.com/nikita-volkov/postgresql-connection-string/pull/3
9496
postgresql-connection-string = fastBuild (self.callCabal2nix "postgresql-connection-string" (builtins.fetchTarball {
95-
url = "https://hackage.haskell.org/package/postgresql-connection-string-0.1/postgresql-connection-string-0.1.tar.gz";
96-
sha256 = "071m8xzqak2b0l27zplfknsdq8x91k0iwimqikszdvdcj6mp1c6r";
97+
url = "https://github.com/mpscholten/postgresql-connection-string/archive/bb9bfb8cfff39e0e87aa24208d0e34a0cefb13cc.tar.gz";
98+
sha256 = "1jw3ka11anvx9prr5iliqwi42h5jlwbq8i0xlarzq2hgg3sc0sqp";
9799
}) {});
98100

99101
hasql = final.haskell.lib.dontCheck (final.haskell.lib.doJailbreak (fastBuild (self.callCabal2nix "hasql" (builtins.fetchTarball {

‎ihp-datasync/IHP/DataSync/Controller.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -19,7 +19,7 @@ instance (
1919
initialState = DataSyncController
2020

2121
run = do
22-
let hasqlPool = requestHasqlPool ?request
22+
let hasqlPool = requestHasqlPool
2323
ensureRLSEnabled <- makeCachedEnsureRLSEnabled hasqlPool
2424
installTableChangeTriggers <- ChangeNotifications.makeCachedInstallTableChangeTriggers hasqlPool
2525
runDataSyncController hasqlPool ensureRLSEnabled installTableChangeTriggers (receiveData @ByteString) sendJSON (\_ _ -> pure ()) (\_ -> camelCaseRenamer)

‎ihp-datasync/IHP/DataSync/Pool.hs‎

Lines changed: 17 additions & 76 deletions
Original file line numberDiff line numberDiff line change
@@ -1,67 +1,31 @@
11
module IHP.DataSync.Pool
2-
( hasqlPoolVaultKey
3-
, hasqlPoolMiddleware
4-
, requestHasqlPool
5-
, initHasqlPoolMiddleware
2+
( requestHasqlPool
63
, initHasqlPool
74
, initHasqlPoolWithRLS
85
) where
96

107
import IHP.Prelude
11-
import Network.Wai
12-
import qualified Data.Vault.Lazy as Vault
13-
import System.IO.Unsafe (unsafePerformIO)
148
import qualified Hasql.Pool
15-
import qualified Hasql.Pool.Config as Hasql.Pool.Config
16-
import qualified Hasql.Connection.Settings as HasqlSettings
17-
import IHP.FrameworkConfig (findOptionOrNothing, configIO, defaultDatabaseUrl)
18-
import IHP.FrameworkConfig.Types (DatabaseUrl(..), DBPoolMaxConnections(..), CustomMiddleware(..), RLSAuthenticatedRole(..))
9+
import IHP.FrameworkConfig (findOptionOrNothing, addInitializer)
10+
import IHP.FrameworkConfig.Types (RLSAuthenticatedRole(..))
11+
import IHP.ModelSupport.Types (ModelContext(..))
1912
import qualified Control.Monad.Trans.State.Strict as State
2013
import qualified Data.TMap as TMap
21-
import qualified Control.Concurrent as Concurrent
2214
import qualified IHP.DataSync.Role as Role
2315

24-
hasqlPoolVaultKey :: Vault.Key Hasql.Pool.Pool
25-
hasqlPoolVaultKey = unsafePerformIO Vault.newKey
26-
{-# NOINLINE hasqlPoolVaultKey #-}
27-
28-
hasqlPoolMiddleware :: Hasql.Pool.Pool -> Middleware
29-
hasqlPoolMiddleware pool app req respond =
30-
let req' = req { vault = Vault.insert hasqlPoolVaultKey pool req.vault }
31-
in app req' respond
32-
33-
requestHasqlPool :: Request -> Hasql.Pool.Pool
34-
requestHasqlPool req = case Vault.lookup hasqlPoolVaultKey req.vault of
16+
-- | Returns the hasql pool from the model context.
17+
requestHasqlPool :: (?modelContext :: ModelContext) => Hasql.Pool.Pool
18+
requestHasqlPool = case ?modelContext.hasqlPool of
3519
Just pool -> pool
36-
Nothing -> error "requestHasqlPool: No hasql pool in request vault. Add hasqlPoolMiddleware to your Config.hs."
37-
38-
-- | Convenience: creates pool and returns middleware. Pool lives for app lifetime.
39-
initHasqlPoolMiddleware :: ByteString -> Int -> IO Middleware
40-
initHasqlPoolMiddleware databaseUrl poolSize = do
41-
let poolConfig = Hasql.Pool.Config.settings
42-
[ Hasql.Pool.Config.size poolSize
43-
, Hasql.Pool.Config.staticConnectionSettings
44-
(HasqlSettings.connectionString (cs databaseUrl))
45-
]
46-
pool <- Hasql.Pool.acquire poolConfig
47-
pure (hasqlPoolMiddleware pool)
20+
Nothing -> error "requestHasqlPool: No hasql pool available in ModelContext"
4821

49-
-- | Reads 'DatabaseUrl' and 'DBPoolMaxConnections' from the framework config,
50-
-- creates a hasql connection pool, and composes 'hasqlPoolMiddleware' into the
51-
-- existing 'CustomMiddleware' stack.
52-
--
53-
-- Use this in your @Config.hs@:
54-
--
55-
-- > config :: ConfigBuilder
56-
-- > config = do
57-
-- > initHasqlPool
22+
-- | No-op for backwards compatibility. The hasql pool is now always created
23+
-- as part of the ModelContext. You can remove this call from your Config.hs.
5824
initHasqlPool :: State.StateT TMap.TMap IO ()
59-
initHasqlPool = do
60-
initHasqlPoolImpl
61-
pure ()
25+
initHasqlPool = pure ()
6226

63-
-- | Like 'initHasqlPool', but also ensures the RLS authenticated role exists
64-
-- in postgres. Reads 'RLSAuthenticatedRole' from the config (default: @ihp_authenticated@).
27+
-- | Ensures the RLS authenticated role exists in postgres at startup.
28+
-- Reads 'RLSAuthenticatedRole' from the config (default: @ihp_authenticated@).
6529
--
6630
-- Use this in your @Config.hs@:
6731
--
@@ -70,33 +34,10 @@ initHasqlPool = do
7034
-- > initHasqlPoolWithRLS
7135
initHasqlPoolWithRLS :: State.StateT TMap.TMap IO ()
7236
initHasqlPoolWithRLS = do
73-
pool <- initHasqlPoolImpl
7437
rlsRole <- findOptionOrNothing @RLSAuthenticatedRole >>= \case
7538
Just (RLSAuthenticatedRole role) -> pure role
7639
Nothing -> pure "ihp_authenticated"
77-
configIO $ Role.ensureAuthenticatedRoleExistsWithRole pool rlsRole
78-
79-
-- | Shared implementation: creates the pool, installs the middleware, returns the pool.
80-
initHasqlPoolImpl :: State.StateT TMap.TMap IO Hasql.Pool.Pool
81-
initHasqlPoolImpl = do
82-
databaseUrl <- findOptionOrNothing @DatabaseUrl >>= \case
83-
Just (DatabaseUrl url) -> pure url
84-
Nothing -> configIO defaultDatabaseUrl
85-
maxConnections <- findOptionOrNothing @DBPoolMaxConnections >>= \case
86-
Just (DBPoolMaxConnections n) -> pure n
87-
Nothing -> configIO $ max 20 <$> Concurrent.getNumCapabilities
88-
pool <- configIO $ do
89-
let poolConfig = Hasql.Pool.Config.settings
90-
[ Hasql.Pool.Config.size maxConnections
91-
, Hasql.Pool.Config.staticConnectionSettings
92-
(HasqlSettings.connectionString (cs databaseUrl))
93-
]
94-
Hasql.Pool.acquire poolConfig
95-
existingMiddleware <- findOptionOrNothing @CustomMiddleware >>= \case
96-
Just (CustomMiddleware mw) -> pure mw
97-
Nothing -> pure id
98-
State.modify (\map -> map
99-
|> TMap.delete @CustomMiddleware
100-
|> TMap.insert (CustomMiddleware (existingMiddleware . hasqlPoolMiddleware pool))
101-
)
102-
pure pool
40+
addInitializer do
41+
case ?modelContext.hasqlPool of
42+
Just pool -> Role.ensureAuthenticatedRoleExistsWithRole pool rlsRole
43+
Nothing -> pure ()

‎ihp-datasync/IHP/DataSync/REST/Controller.hs‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -33,7 +33,7 @@ instance (
3333
, HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord))
3434
) => Controller ApiController where
3535
action CreateRecordAction { table } = do
36-
let hasqlPool = requestHasqlPool ?request
36+
let hasqlPool = requestHasqlPool
3737
ensureRLSEnabled hasqlPool table
3838

3939
columnTypeLookup <- makeCachedColumnTypeLookup hasqlPool
@@ -98,7 +98,7 @@ instance (
9898
_ -> error "Expected JSON object or array"
9999

100100
action UpdateRecordAction { table, id } = do
101-
let hasqlPool = requestHasqlPool ?request
101+
let hasqlPool = requestHasqlPool
102102
ensureRLSEnabled hasqlPool table
103103

104104
columnTypeLookup <- makeCachedColumnTypeLookup hasqlPool
@@ -128,7 +128,7 @@ instance (
128128

129129
-- DELETE /api/:table/:id
130130
action DeleteRecordAction { table, id } = do
131-
let hasqlPool = requestHasqlPool ?request
131+
let hasqlPool = requestHasqlPool
132132
ensureRLSEnabled hasqlPool table
133133

134134
sqlExecWithRLS hasqlPool (Snippet.sql "DELETE FROM " <> quoteIdentifier table <> Snippet.sql " WHERE id = " <> Snippet.param id)
@@ -137,7 +137,7 @@ instance (
137137

138138
-- GET /api/:table/:id
139139
action ShowRecordAction { table, id } = do
140-
let hasqlPool = requestHasqlPool ?request
140+
let hasqlPool = requestHasqlPool
141141
ensureRLSEnabled hasqlPool table
142142

143143
columnTypeLookup <- makeCachedColumnTypeLookup hasqlPool
@@ -151,7 +151,7 @@ instance (
151151
-- GET /api/:table?orderBy=createdAt
152152
-- GET /api/:table?fields=id,title
153153
action ListRecordsAction { table } = do
154-
let hasqlPool = requestHasqlPool ?request
154+
let hasqlPool = requestHasqlPool
155155
ensureRLSEnabled hasqlPool table
156156
157157
columnTypeLookup <- makeCachedColumnTypeLookup hasqlPool

‎ihp-datasync/Test/DataSync/DataSyncIntegrationSpec.hs‎

Lines changed: 0 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -14,7 +14,6 @@ import IHP.DataSync.DynamicQuery (Field(..))
1414
import IHP.DataSync.DynamicQueryCompiler (camelCaseRenamer)
1515
import IHP.DataSync.RowLevelSecurity (makeCachedEnsureRLSEnabled)
1616
import qualified IHP.DataSync.ChangeNotifications as ChangeNotifications
17-
import IHP.DataSync.Pool (hasqlPoolVaultKey)
1817
import IHP.RequestVault (pgListenerVaultKey, frameworkConfigVaultKey)
1918
import IHP.Controller.Context (newControllerContext, putContext, freeze)
2019
import IHP.LoginSupport.Types (HasNewSessionUrl(..), CurrentUserRecord)
@@ -153,7 +152,6 @@ withDataSyncController connStr testUserId action = do
153152
let frameworkConfig' = frameworkConfig { databaseUrl = actualConnStr }
154153

155154
let v = Vault.empty
156-
|> Vault.insert hasqlPoolVaultKey hasqlPool
157155
|> Vault.insert pgListenerVaultKey pgListener
158156
|> Vault.insert frameworkConfigVaultKey frameworkConfig'
159157
let request = defaultRequest { vault = v }

0 commit comments

Comments
 (0)