Generate per-table Id newtypes (UserId, ProjectId, etc.)

NixSupport/default.nix

@@ -80,6 +80,7 @@ library
         , hasql-postgresql-types
         , hasql-pool
         , unordered-containers
+        , hashable
         , postgresql-types
     exposed-modules:
 CABAL_EOF
@@ -123,7 +124,7 @@ CABAL_EOF
     # Inline mkDerivation instead of callCabal2nix to avoid IFD (Import From Derivation).
     # The dependencies here must match the .cabal template generated in modelsPackageSrc above.
     modelsPackage = pkgs.haskell.lib.disableLibraryProfiling (pkgs.haskell.lib.dontHaddock (
-        ghc.callPackage ({ mkDerivation, base, ihp, basic-prelude, text, bytestring, time, uuid, aeson, postgresql-simple, deepseq, data-default, scientific, string-conversions, hasql, hasql-dynamic-statements, hasql-implicits, hasql-mapping, hasql-postgresql-types, hasql-pool, unordered-containers, postgresql-types }: mkDerivation {
+        ghc.callPackage ({ mkDerivation, base, ihp, basic-prelude, text, bytestring, time, uuid, aeson, postgresql-simple, deepseq, data-default, scientific, string-conversions, hasql, hasql-dynamic-statements, hasql-implicits, hasql-mapping, hasql-postgresql-types, hasql-pool, unordered-containers, hashable, postgresql-types }: mkDerivation {
             pname = "${appName}-models";
             version = "0.1.0";
             src = modelsPackageSrc;
@@ -148,6 +149,7 @@ CABAL_EOF
                 hasql-postgresql-types
                 hasql-pool
                 unordered-containers
+                hashable
                 postgresql-types
             ];
             license = pkgs.lib.licenses.free;

ihp-datasync/IHP/DataSync/Controller.hs

@@ -10,7 +10,7 @@ import IHP.DataSync.ControllerImpl (runDataSyncController)
 import IHP.DataSync.DynamicQueryCompiler (camelCaseRenamer)
 
 instance (
-    Show (PrimaryKey (GetTableName CurrentUserRecord))
+    Show (Id' (GetTableName CurrentUserRecord))
     , HasNewSessionUrl CurrentUserRecord
     , Typeable CurrentUserRecord
     , HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord))

ihp-datasync/IHP/DataSync/ControllerImpl.hs

@@ -46,7 +46,7 @@ runDataSyncController ::
     , ?state :: IORef DataSyncController
     , Typeable CurrentUserRecord
     , HasNewSessionUrl CurrentUserRecord
-    , Show (PrimaryKey (GetTableName CurrentUserRecord))
+    , Show (Id' (GetTableName CurrentUserRecord))
     ) => Hasql.Pool.Pool -> EnsureRLSEnabledFn -> InstallTableChangeTriggerFn -> IO ByteString -> SendJSONFn -> HandleCustomMessageFn -> (Text -> Renamer) -> IO ()
 runDataSyncController hasqlPool ensureRLSEnabled installTableChangeTriggers receiveData sendJSON handleCustomMessage renamer = do
     setState DataSyncReady { subscriptions = HashMap.empty, transactions = HashMap.empty }
@@ -111,7 +111,7 @@ buildMessageHandler ::
     , ?state :: IORef DataSyncController
     , Typeable CurrentUserRecord
     , HasNewSessionUrl CurrentUserRecord
-    , Show (PrimaryKey (GetTableName CurrentUserRecord))
+    , Show (Id' (GetTableName CurrentUserRecord))
     )
     => Hasql.Pool.Pool -> EnsureRLSEnabledFn -> InstallTableChangeTriggerFn -> SendJSONFn -> HandleCustomMessageFn -> (Text -> Renamer) -> (Text -> IO ColumnTypeInfo) -> IO (DataSyncMessage -> IO ())
 buildMessageHandler hasqlPool ensureRLSEnabled installTableChangeTriggers sendJSON handleCustomMessage renamer columnTypeLookup = do
@@ -512,7 +512,7 @@ encodePatchToSetSql ren columnTypes patch =
 
 sqlQueryWithRLSAndTransactionId ::
     ( ?context :: ControllerContext
-    , Show (PrimaryKey (GetTableName CurrentUserRecord))
+    , Show (Id' (GetTableName CurrentUserRecord))
     , HasNewSessionUrl CurrentUserRecord
     , Typeable CurrentUserRecord
     , HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord))
@@ -531,7 +531,7 @@ sqlQueryWithRLSAndTransactionId pool Nothing statement = runSession pool (sqlQue
 -- to return results (e.g. wrapped with 'wrapDynamicQuery').
 sqlQueryWriteWithRLSAndTransactionId ::
     ( ?context :: ControllerContext
-    , Show (PrimaryKey (GetTableName CurrentUserRecord))
+    , Show (Id' (GetTableName CurrentUserRecord))
     , HasNewSessionUrl CurrentUserRecord
     , Typeable CurrentUserRecord
     , HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord))
@@ -546,7 +546,7 @@ sqlQueryWriteWithRLSAndTransactionId pool Nothing statement = runSession pool (s
 
 sqlExecWithRLSAndTransactionId ::
     ( ?context :: ControllerContext
-    , Show (PrimaryKey (GetTableName CurrentUserRecord))
+    , Show (Id' (GetTableName CurrentUserRecord))
     , HasNewSessionUrl CurrentUserRecord
     , Typeable CurrentUserRecord
     , HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord))

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

@@ -25,7 +25,7 @@ import qualified Hasql.Decoders as Decoders
 import qualified Hasql.Statement as Hasql
 
 instance (
-    Show (PrimaryKey (GetTableName CurrentUserRecord))
+    Show (Id' (GetTableName CurrentUserRecord))
     , HasNewSessionUrl CurrentUserRecord
     , Typeable CurrentUserRecord
     , HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord))

ihp-datasync/IHP/DataSync/RowLevelSecurity.hs

@@ -58,7 +58,7 @@ ensureRLSEnabledSession table = do
 -- (e.g. after a manual @BEGIN@).
 setRLSConfigSession ::
     ( ?context :: ControllerContext
-    , Show (PrimaryKey (GetTableName CurrentUserRecord))
+    , Show (Id' (GetTableName CurrentUserRecord))
     , HasNewSessionUrl CurrentUserRecord
     , Typeable CurrentUserRecord
     , HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord))
@@ -71,7 +71,7 @@ setRLSConfigSession = Session.statement (Role.authenticatedRole, encodedUserId)
 
 sqlQueryWithRLSSession ::
     ( ?context :: ControllerContext
-    , Show (PrimaryKey (GetTableName CurrentUserRecord))
+    , Show (Id' (GetTableName CurrentUserRecord))
     , HasNewSessionUrl CurrentUserRecord
     , Typeable CurrentUserRecord
     , HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord))
@@ -92,7 +92,7 @@ sqlQueryWithRLSSession statement =
 -- to return results (e.g. wrapped with 'wrapDynamicQuery').
 sqlQueryWriteWithRLSSession ::
     ( ?context :: ControllerContext
-    , Show (PrimaryKey (GetTableName CurrentUserRecord))
+    , Show (Id' (GetTableName CurrentUserRecord))
     , HasNewSessionUrl CurrentUserRecord
     , Typeable CurrentUserRecord
     , HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord))
@@ -109,7 +109,7 @@ sqlQueryWriteWithRLSSession statement =
 
 sqlExecWithRLSSession ::
     ( ?context :: ControllerContext
-    , Show (PrimaryKey (GetTableName CurrentUserRecord))
+    , Show (Id' (GetTableName CurrentUserRecord))
     , HasNewSessionUrl CurrentUserRecord
     , Typeable CurrentUserRecord
     , HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord))
@@ -126,7 +126,7 @@ sqlExecWithRLSSession statement =
 
 sqlQueryScalarWithRLSSession ::
     ( ?context :: ControllerContext
-    , Show (PrimaryKey (GetTableName CurrentUserRecord))
+    , Show (Id' (GetTableName CurrentUserRecord))
     , HasNewSessionUrl CurrentUserRecord
     , Typeable CurrentUserRecord
     , HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord))
@@ -145,7 +145,7 @@ sqlQueryScalarWithRLSSession statement =
 
 sqlQueryWithRLS ::
     ( ?context :: ControllerContext
-    , Show (PrimaryKey (GetTableName CurrentUserRecord))
+    , Show (Id' (GetTableName CurrentUserRecord))
     , HasNewSessionUrl CurrentUserRecord
     , Typeable CurrentUserRecord
     , HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord))
@@ -159,7 +159,7 @@ sqlQueryWithRLS pool statement = runSession pool (sqlQueryWithRLSSession stateme
 -- to return results (e.g. wrapped with 'wrapDynamicQuery').
 sqlQueryWriteWithRLS ::
     ( ?context :: ControllerContext
-    , Show (PrimaryKey (GetTableName CurrentUserRecord))
+    , Show (Id' (GetTableName CurrentUserRecord))
     , HasNewSessionUrl CurrentUserRecord
     , Typeable CurrentUserRecord
     , HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord))
@@ -169,7 +169,7 @@ sqlQueryWriteWithRLS pool statement = runSession pool (sqlQueryWriteWithRLSSessi
 
 sqlExecWithRLS ::
     ( ?context :: ControllerContext
-    , Show (PrimaryKey (GetTableName CurrentUserRecord))
+    , Show (Id' (GetTableName CurrentUserRecord))
     , HasNewSessionUrl CurrentUserRecord
     , Typeable CurrentUserRecord
     , HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord))
@@ -179,7 +179,7 @@ sqlExecWithRLS pool statement = runSession pool (sqlExecWithRLSSession statement
 
 sqlQueryScalarWithRLS ::
     ( ?context :: ControllerContext
-    , Show (PrimaryKey (GetTableName CurrentUserRecord))
+    , Show (Id' (GetTableName CurrentUserRecord))
     , HasNewSessionUrl CurrentUserRecord
     , Typeable CurrentUserRecord
     , HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord))

ihp-datasync/Test/DataSync/DataSyncIntegrationSpec.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE UndecidableInstances, DerivingStrategies, GeneralizedNewtypeDeriving #-}
 module Test.DataSync.DataSyncIntegrationSpec where
 
 import Test.Hspec
@@ -18,7 +18,7 @@ import IHP.RequestVault (pgListenerVaultKey, frameworkConfigVaultKey)
 import IHP.Controller.Context (newControllerContext, putContext, freeze)
 import IHP.LoginSupport.Types (HasNewSessionUrl(..), CurrentUserRecord)
 import qualified IHP.ModelSupport as ModelSupport
-import IHP.ModelSupport.Types (Id'(..), PrimaryKey)
+import IHP.ModelSupport.Types (PrimaryKey)
 import qualified IHP.PGListener as PGListener
 import IHP.FrameworkConfig (buildFrameworkConfig)
 import IHP.FrameworkConfig.Types
@@ -37,7 +37,14 @@ import Control.Concurrent (threadDelay)
 import qualified IHP.Log as Log
 
 -- | Define CurrentUserRecord for this test module
-data TestUser = TestUser { id :: Id' "test_users" }
+newtype TestUserId = TestUserId UUID
+    deriving newtype (Eq, Ord, Show)
+type instance Id' "test_users" = TestUserId
+instance IdNewtype TestUserId UUID where
+    toId = TestUserId
+    fromId (TestUserId x) = x
+
+data TestUser = TestUser { id :: TestUserId }
     deriving (Show, Typeable)
 
 type instance CurrentUserRecord = TestUser