diff --git a/NixSupport/default.nix b/NixSupport/default.nix index 88a933458..75e9c94f4 100644 --- a/NixSupport/default.nix +++ b/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; diff --git a/ihp-datasync/IHP/DataSync/Controller.hs b/ihp-datasync/IHP/DataSync/Controller.hs index 7b8d50336..ec06ae1a5 100644 --- a/ihp-datasync/IHP/DataSync/Controller.hs +++ b/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)) diff --git a/ihp-datasync/IHP/DataSync/ControllerImpl.hs b/ihp-datasync/IHP/DataSync/ControllerImpl.hs index 49f6656a6..faa3ffa57 100644 --- a/ihp-datasync/IHP/DataSync/ControllerImpl.hs +++ b/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)) diff --git a/ihp-datasync/IHP/DataSync/REST/Controller.hs b/ihp-datasync/IHP/DataSync/REST/Controller.hs index 539efc3da..f4e0154d3 100644 --- a/ihp-datasync/IHP/DataSync/REST/Controller.hs +++ b/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)) diff --git a/ihp-datasync/IHP/DataSync/RowLevelSecurity.hs b/ihp-datasync/IHP/DataSync/RowLevelSecurity.hs index beafa2199..7126ac2f7 100644 --- a/ihp-datasync/IHP/DataSync/RowLevelSecurity.hs +++ b/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)) diff --git a/ihp-datasync/Test/DataSync/DataSyncIntegrationSpec.hs b/ihp-datasync/Test/DataSync/DataSyncIntegrationSpec.hs index e9cc6f755..7bf787524 100644 --- a/ihp-datasync/Test/DataSync/DataSyncIntegrationSpec.hs +++ b/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 diff --git a/ihp-ide/Test/SchemaCompilerSpec.hs b/ihp-ide/Test/SchemaCompilerSpec.hs index 7687d0bdf..1c51693b3 100644 --- a/ihp-ide/Test/SchemaCompilerSpec.hs +++ b/ihp-ide/Test/SchemaCompilerSpec.hs @@ -202,16 +202,35 @@ tests = do let compileOutput = compileStatementPreview [statement] statement |> Text.strip compileOutput `shouldBe` [trimming| - data User' = User {id :: (Id' "users"), ids :: (Maybe [UUID]), electricityUnitPrice :: Double, meta :: MetaBag} deriving (Eq, Show) + data User' = User {id :: (UserId), ids :: (Maybe [UUID]), electricityUnitPrice :: Double, meta :: MetaBag} deriving (Eq, Show) type instance PrimaryKey "users" = UUID + newtype UserId = UserId UUID deriving newtype (Eq, Ord, Show, Hashable, DeepSeq.NFData, FromField, ToField, Data.Aeson.ToJSON, Data.Aeson.FromJSON, Mapping.IsScalar) deriving stock (Data) + type instance Id' "users" = UserId + type instance GetTableForId UserId = "users" + instance IdNewtype UserId UUID where { toId = UserId; fromId (UserId x) = x } + instance Default UserId where def = UserId def + instance IsEmpty UserId where isEmpty (UserId x) = isEmpty x + instance InputValue UserId where inputValue (UserId x) = inputValue x + instance IsString UserId where + fromString str = case parsePrimaryKey (Data.String.Conversions.cs str) of + Just pk -> UserId pk + Nothing -> Prelude.error ("Unable to convert " <> Prelude.show str <> " to UserId") + instance Hasql.Implicits.Encoders.DefaultParamEncoder UserId where + defaultParam = Hasql.Encoders.nonNullable Mapping.encoder + instance Hasql.Implicits.Encoders.DefaultParamEncoder [UserId] where + defaultParam = Hasql.Encoders.nonNullable $ Hasql.Encoders.foldableArray $ Hasql.Encoders.nonNullable Mapping.encoder + instance Hasql.Implicits.Encoders.DefaultParamEncoder (Maybe UserId) where + defaultParam = Hasql.Encoders.nullable Mapping.encoder + instance Hasql.Implicits.Encoders.DefaultParamEncoder [Maybe UserId] where + defaultParam = Hasql.Encoders.nonNullable $ Hasql.Encoders.foldableArray $ Hasql.Encoders.nullable Mapping.encoder + type User = User' type instance GetTableName (User') = "users" type instance GetModelByTableName "users" = User - instance Default (Id' "users") where def = Id def instance IHP.ModelSupport.Table (User') where tableName = "users" @@ -285,6 +304,43 @@ tests = do builder |> QueryBuilder.filterWhere (#id, id) {-# INLINE filterWhereId #-} + instance HSX.ApplyAttribute UserId where + applyAttribute attr attr' (UserId x) h = HSX.applyAttribute attr attr' (inputValue x) h + instance ParamReader UserId where + readParameter bytes = UserId <$> readParameter bytes + readParameterJSON value = UserId <$> readParameterJSON value + instance Fetchable UserId User where + type FetchResult UserId User = User + {-# INLINE fetch #-} + fetch = genericFetchIdOne + {-# INLINE fetchOneOrNothing #-} + fetchOneOrNothing = genericfetchIdOneOrNothing + {-# INLINE fetchOne #-} + fetchOne = genericFetchIdOne + instance Fetchable (Maybe UserId) User where + type FetchResult (Maybe UserId) User = [User] + {-# INLINE fetch #-} + fetch (Just a) = genericFetchId a + fetch Nothing = pure [] + {-# INLINE fetchOneOrNothing #-} + fetchOneOrNothing Nothing = pure Nothing + fetchOneOrNothing (Just a) = genericfetchIdOneOrNothing a + {-# INLINE fetchOne #-} + fetchOne (Just a) = genericFetchIdOne a + fetchOne Nothing = error "Fetchable (Maybe UserId): Failed to fetch because given id is 'Nothing', 'Just id' was expected" + instance Fetchable [UserId] User where + type FetchResult [UserId] User = [User] + {-# INLINE fetch #-} + fetch = genericFetchIds + {-# INLINE fetchOneOrNothing #-} + fetchOneOrNothing = genericfetchIdsOneOrNothing + {-# INLINE fetchOne #-} + fetchOne = genericFetchIdsOne + instance CollectionFetchRelated UserId User where + collectionFetchRelated = collectionFetchRelatedById + instance CollectionFetchRelatedOrNothing UserId User where + collectionFetchRelatedOrNothing = collectionFetchRelatedOrNothingById + instance FieldBit "id" (User') where fieldBit = 1 instance FieldBit "ids" (User') where fieldBit = 2 instance FieldBit "electricityUnitPrice" (User') where fieldBit = 4 @@ -301,16 +357,35 @@ tests = do let compileOutput = compileStatementPreview [statement] statement |> Text.strip compileOutput `shouldBe` [trimming| - data User' = User {id :: (Id' "users"), ids :: (Maybe [UUID]), electricityUnitPrice :: Double, meta :: MetaBag} deriving (Eq, Show) + data User' = User {id :: (UserId), ids :: (Maybe [UUID]), electricityUnitPrice :: Double, meta :: MetaBag} deriving (Eq, Show) type instance PrimaryKey "users" = UUID + newtype UserId = UserId UUID deriving newtype (Eq, Ord, Show, Hashable, DeepSeq.NFData, FromField, ToField, Data.Aeson.ToJSON, Data.Aeson.FromJSON, Mapping.IsScalar) deriving stock (Data) + type instance Id' "users" = UserId + type instance GetTableForId UserId = "users" + instance IdNewtype UserId UUID where { toId = UserId; fromId (UserId x) = x } + instance Default UserId where def = UserId def + instance IsEmpty UserId where isEmpty (UserId x) = isEmpty x + instance InputValue UserId where inputValue (UserId x) = inputValue x + instance IsString UserId where + fromString str = case parsePrimaryKey (Data.String.Conversions.cs str) of + Just pk -> UserId pk + Nothing -> Prelude.error ("Unable to convert " <> Prelude.show str <> " to UserId") + instance Hasql.Implicits.Encoders.DefaultParamEncoder UserId where + defaultParam = Hasql.Encoders.nonNullable Mapping.encoder + instance Hasql.Implicits.Encoders.DefaultParamEncoder [UserId] where + defaultParam = Hasql.Encoders.nonNullable $ Hasql.Encoders.foldableArray $ Hasql.Encoders.nonNullable Mapping.encoder + instance Hasql.Implicits.Encoders.DefaultParamEncoder (Maybe UserId) where + defaultParam = Hasql.Encoders.nullable Mapping.encoder + instance Hasql.Implicits.Encoders.DefaultParamEncoder [Maybe UserId] where + defaultParam = Hasql.Encoders.nonNullable $ Hasql.Encoders.foldableArray $ Hasql.Encoders.nullable Mapping.encoder + type User = User' type instance GetTableName (User') = "users" type instance GetModelByTableName "users" = User - instance Default (Id' "users") where def = Id def instance IHP.ModelSupport.Table (User') where tableName = "users" @@ -384,6 +459,43 @@ tests = do builder |> QueryBuilder.filterWhere (#id, id) {-# INLINE filterWhereId #-} + instance HSX.ApplyAttribute UserId where + applyAttribute attr attr' (UserId x) h = HSX.applyAttribute attr attr' (inputValue x) h + instance ParamReader UserId where + readParameter bytes = UserId <$> readParameter bytes + readParameterJSON value = UserId <$> readParameterJSON value + instance Fetchable UserId User where + type FetchResult UserId User = User + {-# INLINE fetch #-} + fetch = genericFetchIdOne + {-# INLINE fetchOneOrNothing #-} + fetchOneOrNothing = genericfetchIdOneOrNothing + {-# INLINE fetchOne #-} + fetchOne = genericFetchIdOne + instance Fetchable (Maybe UserId) User where + type FetchResult (Maybe UserId) User = [User] + {-# INLINE fetch #-} + fetch (Just a) = genericFetchId a + fetch Nothing = pure [] + {-# INLINE fetchOneOrNothing #-} + fetchOneOrNothing Nothing = pure Nothing + fetchOneOrNothing (Just a) = genericfetchIdOneOrNothing a + {-# INLINE fetchOne #-} + fetchOne (Just a) = genericFetchIdOne a + fetchOne Nothing = error "Fetchable (Maybe UserId): Failed to fetch because given id is 'Nothing', 'Just id' was expected" + instance Fetchable [UserId] User where + type FetchResult [UserId] User = [User] + {-# INLINE fetch #-} + fetch = genericFetchIds + {-# INLINE fetchOneOrNothing #-} + fetchOneOrNothing = genericfetchIdsOneOrNothing + {-# INLINE fetchOne #-} + fetchOne = genericFetchIdsOne + instance CollectionFetchRelated UserId User where + collectionFetchRelated = collectionFetchRelatedById + instance CollectionFetchRelatedOrNothing UserId User where + collectionFetchRelatedOrNothing = collectionFetchRelatedOrNothingById + instance FieldBit "id" (User') where fieldBit = 1 instance FieldBit "ids" (User') where fieldBit = 2 instance FieldBit "electricityUnitPrice" (User') where fieldBit = 4 @@ -399,16 +511,35 @@ tests = do let compileOutput = compileStatementPreview [statement] statement |> Text.strip compileOutput `shouldBe` [trimming| - data User' = User {id :: (Id' "users"), ts :: (Maybe Tsvector), meta :: MetaBag} deriving (Eq, Show) + data User' = User {id :: (UserId), ts :: (Maybe Tsvector), meta :: MetaBag} deriving (Eq, Show) type instance PrimaryKey "users" = UUID + newtype UserId = UserId UUID deriving newtype (Eq, Ord, Show, Hashable, DeepSeq.NFData, FromField, ToField, Data.Aeson.ToJSON, Data.Aeson.FromJSON, Mapping.IsScalar) deriving stock (Data) + type instance Id' "users" = UserId + type instance GetTableForId UserId = "users" + instance IdNewtype UserId UUID where { toId = UserId; fromId (UserId x) = x } + instance Default UserId where def = UserId def + instance IsEmpty UserId where isEmpty (UserId x) = isEmpty x + instance InputValue UserId where inputValue (UserId x) = inputValue x + instance IsString UserId where + fromString str = case parsePrimaryKey (Data.String.Conversions.cs str) of + Just pk -> UserId pk + Nothing -> Prelude.error ("Unable to convert " <> Prelude.show str <> " to UserId") + instance Hasql.Implicits.Encoders.DefaultParamEncoder UserId where + defaultParam = Hasql.Encoders.nonNullable Mapping.encoder + instance Hasql.Implicits.Encoders.DefaultParamEncoder [UserId] where + defaultParam = Hasql.Encoders.nonNullable $ Hasql.Encoders.foldableArray $ Hasql.Encoders.nonNullable Mapping.encoder + instance Hasql.Implicits.Encoders.DefaultParamEncoder (Maybe UserId) where + defaultParam = Hasql.Encoders.nullable Mapping.encoder + instance Hasql.Implicits.Encoders.DefaultParamEncoder [Maybe UserId] where + defaultParam = Hasql.Encoders.nonNullable $ Hasql.Encoders.foldableArray $ Hasql.Encoders.nullable Mapping.encoder + type User = User' type instance GetTableName (User') = "users" type instance GetModelByTableName "users" = User - instance Default (Id' "users") where def = Id def instance IHP.ModelSupport.Table (User') where tableName = "users" @@ -479,6 +610,43 @@ tests = do builder |> QueryBuilder.filterWhere (#id, id) {-# INLINE filterWhereId #-} + instance HSX.ApplyAttribute UserId where + applyAttribute attr attr' (UserId x) h = HSX.applyAttribute attr attr' (inputValue x) h + instance ParamReader UserId where + readParameter bytes = UserId <$> readParameter bytes + readParameterJSON value = UserId <$> readParameterJSON value + instance Fetchable UserId User where + type FetchResult UserId User = User + {-# INLINE fetch #-} + fetch = genericFetchIdOne + {-# INLINE fetchOneOrNothing #-} + fetchOneOrNothing = genericfetchIdOneOrNothing + {-# INLINE fetchOne #-} + fetchOne = genericFetchIdOne + instance Fetchable (Maybe UserId) User where + type FetchResult (Maybe UserId) User = [User] + {-# INLINE fetch #-} + fetch (Just a) = genericFetchId a + fetch Nothing = pure [] + {-# INLINE fetchOneOrNothing #-} + fetchOneOrNothing Nothing = pure Nothing + fetchOneOrNothing (Just a) = genericfetchIdOneOrNothing a + {-# INLINE fetchOne #-} + fetchOne (Just a) = genericFetchIdOne a + fetchOne Nothing = error "Fetchable (Maybe UserId): Failed to fetch because given id is 'Nothing', 'Just id' was expected" + instance Fetchable [UserId] User where + type FetchResult [UserId] User = [User] + {-# INLINE fetch #-} + fetch = genericFetchIds + {-# INLINE fetchOneOrNothing #-} + fetchOneOrNothing = genericfetchIdsOneOrNothing + {-# INLINE fetchOne #-} + fetchOne = genericFetchIdsOne + instance CollectionFetchRelated UserId User where + collectionFetchRelated = collectionFetchRelatedById + instance CollectionFetchRelatedOrNothing UserId User where + collectionFetchRelatedOrNothing = collectionFetchRelatedOrNothingById + instance FieldBit "id" (User') where fieldBit = 1 instance FieldBit "ts" (User') where fieldBit = 2 |] @@ -531,16 +699,35 @@ tests = do let compileOutput = compileStatementPreview statements statement |> Text.strip compileOutput `shouldBe` [trimming| - data LandingPage' paragraphCtasLandingPages paragraphCtasToLandingPages = LandingPage {id :: (Id' "landing_pages"), paragraphCtasLandingPages :: paragraphCtasLandingPages, paragraphCtasToLandingPages :: paragraphCtasToLandingPages, meta :: MetaBag} deriving (Eq, Show) + data LandingPage' paragraphCtasLandingPages paragraphCtasToLandingPages = LandingPage {id :: (LandingPageId), paragraphCtasLandingPages :: paragraphCtasLandingPages, paragraphCtasToLandingPages :: paragraphCtasToLandingPages, meta :: MetaBag} deriving (Eq, Show) type instance PrimaryKey "landing_pages" = UUID - + + newtype LandingPageId = LandingPageId UUID deriving newtype (Eq, Ord, Show, Hashable, DeepSeq.NFData, FromField, ToField, Data.Aeson.ToJSON, Data.Aeson.FromJSON, Mapping.IsScalar) deriving stock (Data) + type instance Id' "landing_pages" = LandingPageId + type instance GetTableForId LandingPageId = "landing_pages" + instance IdNewtype LandingPageId UUID where { toId = LandingPageId; fromId (LandingPageId x) = x } + instance Default LandingPageId where def = LandingPageId def + instance IsEmpty LandingPageId where isEmpty (LandingPageId x) = isEmpty x + instance InputValue LandingPageId where inputValue (LandingPageId x) = inputValue x + instance IsString LandingPageId where + fromString str = case parsePrimaryKey (Data.String.Conversions.cs str) of + Just pk -> LandingPageId pk + Nothing -> Prelude.error ("Unable to convert " <> Prelude.show str <> " to LandingPageId") + instance Hasql.Implicits.Encoders.DefaultParamEncoder LandingPageId where + defaultParam = Hasql.Encoders.nonNullable Mapping.encoder + instance Hasql.Implicits.Encoders.DefaultParamEncoder [LandingPageId] where + defaultParam = Hasql.Encoders.nonNullable $ Hasql.Encoders.foldableArray $ Hasql.Encoders.nonNullable Mapping.encoder + instance Hasql.Implicits.Encoders.DefaultParamEncoder (Maybe LandingPageId) where + defaultParam = Hasql.Encoders.nullable Mapping.encoder + instance Hasql.Implicits.Encoders.DefaultParamEncoder [Maybe LandingPageId] where + defaultParam = Hasql.Encoders.nonNullable $ Hasql.Encoders.foldableArray $ Hasql.Encoders.nullable Mapping.encoder + type LandingPage = LandingPage' (QueryBuilder.QueryBuilder "paragraph_ctas") (QueryBuilder.QueryBuilder "paragraph_ctas") type instance GetTableName (LandingPage' _ _) = "landing_pages" type instance GetModelByTableName "landing_pages" = LandingPage - instance Default (Id' "landing_pages") where def = Id def instance IHP.ModelSupport.Table (LandingPage' paragraphCtasLandingPages paragraphCtasToLandingPages) where tableName = "landing_pages" @@ -612,6 +799,43 @@ tests = do builder |> QueryBuilder.filterWhere (#id, id) {-# INLINE filterWhereId #-} + instance HSX.ApplyAttribute LandingPageId where + applyAttribute attr attr' (LandingPageId x) h = HSX.applyAttribute attr attr' (inputValue x) h + instance ParamReader LandingPageId where + readParameter bytes = LandingPageId <$> readParameter bytes + readParameterJSON value = LandingPageId <$> readParameterJSON value + instance Fetchable LandingPageId LandingPage where + type FetchResult LandingPageId LandingPage = LandingPage + {-# INLINE fetch #-} + fetch = genericFetchIdOne + {-# INLINE fetchOneOrNothing #-} + fetchOneOrNothing = genericfetchIdOneOrNothing + {-# INLINE fetchOne #-} + fetchOne = genericFetchIdOne + instance Fetchable (Maybe LandingPageId) LandingPage where + type FetchResult (Maybe LandingPageId) LandingPage = [LandingPage] + {-# INLINE fetch #-} + fetch (Just a) = genericFetchId a + fetch Nothing = pure [] + {-# INLINE fetchOneOrNothing #-} + fetchOneOrNothing Nothing = pure Nothing + fetchOneOrNothing (Just a) = genericfetchIdOneOrNothing a + {-# INLINE fetchOne #-} + fetchOne (Just a) = genericFetchIdOne a + fetchOne Nothing = error "Fetchable (Maybe LandingPageId): Failed to fetch because given id is 'Nothing', 'Just id' was expected" + instance Fetchable [LandingPageId] LandingPage where + type FetchResult [LandingPageId] LandingPage = [LandingPage] + {-# INLINE fetch #-} + fetch = genericFetchIds + {-# INLINE fetchOneOrNothing #-} + fetchOneOrNothing = genericfetchIdsOneOrNothing + {-# INLINE fetchOne #-} + fetchOne = genericFetchIdsOne + instance CollectionFetchRelated LandingPageId LandingPage where + collectionFetchRelated = collectionFetchRelatedById + instance CollectionFetchRelatedOrNothing LandingPageId LandingPage where + collectionFetchRelatedOrNothing = collectionFetchRelatedOrNothingById + instance FieldBit "id" (LandingPage' paragraphCtasLandingPages paragraphCtasToLandingPages) where fieldBit = 1 |] it "should not use DEFAULT for array columns" do @@ -798,16 +1022,35 @@ tests = do -- data Post' has no type parameters, no QueryBuilder field, and userId has concrete type compileOutput `shouldBe` [trimming| - data Post' = Post {id :: (Id' "posts"), title :: Text, userId :: (Id' "users"), meta :: MetaBag} deriving (Eq, Show) + data Post' = Post {id :: (PostId), title :: Text, userId :: (UserId), meta :: MetaBag} deriving (Eq, Show) type instance PrimaryKey "posts" = UUID + newtype PostId = PostId UUID deriving newtype (Eq, Ord, Show, Hashable, DeepSeq.NFData, FromField, ToField, Data.Aeson.ToJSON, Data.Aeson.FromJSON, Mapping.IsScalar) deriving stock (Data) + type instance Id' "posts" = PostId + type instance GetTableForId PostId = "posts" + instance IdNewtype PostId UUID where { toId = PostId; fromId (PostId x) = x } + instance Default PostId where def = PostId def + instance IsEmpty PostId where isEmpty (PostId x) = isEmpty x + instance InputValue PostId where inputValue (PostId x) = inputValue x + instance IsString PostId where + fromString str = case parsePrimaryKey (Data.String.Conversions.cs str) of + Just pk -> PostId pk + Nothing -> Prelude.error ("Unable to convert " <> Prelude.show str <> " to PostId") + instance Hasql.Implicits.Encoders.DefaultParamEncoder PostId where + defaultParam = Hasql.Encoders.nonNullable Mapping.encoder + instance Hasql.Implicits.Encoders.DefaultParamEncoder [PostId] where + defaultParam = Hasql.Encoders.nonNullable $ Hasql.Encoders.foldableArray $ Hasql.Encoders.nonNullable Mapping.encoder + instance Hasql.Implicits.Encoders.DefaultParamEncoder (Maybe PostId) where + defaultParam = Hasql.Encoders.nullable Mapping.encoder + instance Hasql.Implicits.Encoders.DefaultParamEncoder [Maybe PostId] where + defaultParam = Hasql.Encoders.nonNullable $ Hasql.Encoders.foldableArray $ Hasql.Encoders.nullable Mapping.encoder + type Post = Post' type instance GetTableName (Post') = "posts" type instance GetModelByTableName "posts" = Post - instance Default (Id' "posts") where def = Id def instance IHP.ModelSupport.Table (Post') where tableName = "posts" @@ -881,6 +1124,43 @@ tests = do builder |> QueryBuilder.filterWhere (#id, id) {-# INLINE filterWhereId #-} + instance HSX.ApplyAttribute PostId where + applyAttribute attr attr' (PostId x) h = HSX.applyAttribute attr attr' (inputValue x) h + instance ParamReader PostId where + readParameter bytes = PostId <$> readParameter bytes + readParameterJSON value = PostId <$> readParameterJSON value + instance Fetchable PostId Post where + type FetchResult PostId Post = Post + {-# INLINE fetch #-} + fetch = genericFetchIdOne + {-# INLINE fetchOneOrNothing #-} + fetchOneOrNothing = genericfetchIdOneOrNothing + {-# INLINE fetchOne #-} + fetchOne = genericFetchIdOne + instance Fetchable (Maybe PostId) Post where + type FetchResult (Maybe PostId) Post = [Post] + {-# INLINE fetch #-} + fetch (Just a) = genericFetchId a + fetch Nothing = pure [] + {-# INLINE fetchOneOrNothing #-} + fetchOneOrNothing Nothing = pure Nothing + fetchOneOrNothing (Just a) = genericfetchIdOneOrNothing a + {-# INLINE fetchOne #-} + fetchOne (Just a) = genericFetchIdOne a + fetchOne Nothing = error "Fetchable (Maybe PostId): Failed to fetch because given id is 'Nothing', 'Just id' was expected" + instance Fetchable [PostId] Post where + type FetchResult [PostId] Post = [Post] + {-# INLINE fetch #-} + fetch = genericFetchIds + {-# INLINE fetchOneOrNothing #-} + fetchOneOrNothing = genericfetchIdsOneOrNothing + {-# INLINE fetchOne #-} + fetchOne = genericFetchIdsOne + instance CollectionFetchRelated PostId Post where + collectionFetchRelated = collectionFetchRelatedById + instance CollectionFetchRelatedOrNothing PostId Post where + collectionFetchRelatedOrNothing = collectionFetchRelatedOrNothingById + instance FieldBit "id" (Post') where fieldBit = 1 instance FieldBit "title" (Post') where fieldBit = 2 instance FieldBit "userId" (Post') where fieldBit = 4 diff --git a/ihp-job-dashboard/IHP/Job/Dashboard.hs b/ihp-job-dashboard/IHP/Job/Dashboard.hs index ece347711..a0a8e9935 100644 --- a/ihp-job-dashboard/IHP/Job/Dashboard.hs +++ b/ihp-job-dashboard/IHP/Job/Dashboard.hs @@ -268,7 +268,7 @@ instance {-# OVERLAPPABLE #-} (DisplayableJob job, JobsDashboard rest) => JobsDa -- | View the detail page for the job with a given uuid. viewJob _ uuid = do let id :: Id job = unsafeCoerce uuid - j <- fetch id + j <- genericFetchIdOne @(GetTableName job) id view <- makeDetailView @job j render view diff --git a/ihp-schema-compiler/IHP/SchemaCompiler.hs b/ihp-schema-compiler/IHP/SchemaCompiler.hs index ac3719ba1..368dd8fb1 100644 --- a/ihp-schema-compiler/IHP/SchemaCompiler.hs +++ b/ihp-schema-compiler/IHP/SchemaCompiler.hs @@ -133,6 +133,10 @@ tableModule options table = module $moduleName where $defaultImports import Generated.ActualTypes + import IHP.Fetch + import IHP.FetchRelated (CollectionFetchRelated(..), CollectionFetchRelatedOrNothing(..), collectionFetchRelatedById, collectionFetchRelatedOrNothingById) + import qualified IHP.HSX.Attribute as HSX + import IHP.Controller.Param (ParamReader(..)) $statementImports |] @@ -159,6 +163,9 @@ tableModuleBody options table = Text.unlines $ filter (not . Text.null) , compileUpdate table , compileBuild table , compileFilterPrimaryKeyInstance table + , if tableHasPrimaryKey table + then compileIdNewtypeModelInstances table + else "" , if needsHasFieldId table then compileHasFieldId table else "" @@ -279,15 +286,15 @@ compileActualTypesForTable table = Text.unlines , compileTableInstance table ] --- | Like 'compileActualTypesForTable' but includes PrimaryKey and Default Id' instances inline. +-- | Like 'compileActualTypesForTable' but includes PrimaryKey, Id newtype, and all instances inline. -- Used by 'compileStatementPreviewWith' so the IDE preview and tests see a self-contained output. compileActualTypesForTablePreview :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text compileActualTypesForTablePreview table = Text.unlines [ compileData table , compilePrimaryKeyInstance table + , compileIdNewtype table , compileTypeAlias table , compileHasTableNameInstance table - , compileDefaultIdInstance table , compileTableInstance table ] @@ -353,6 +360,7 @@ defaultImports = [trimming| import IHP.Job.Queue (textToEnumJobStatus) import qualified Control.DeepSeq as DeepSeq import qualified Data.Dynamic + import Data.Hashable (Hashable) import Data.Scientific import IHP.Hasql.FromRow (FromRowHasql(..)) import qualified Hasql.Decoders as Decoders @@ -405,18 +413,20 @@ compilePrimaryKeysModule schema@(Schema statements) = , statements |> mapMaybe (\case StatementCreateTable table | tableHasPrimaryKey table -> - Just (compilePrimaryKeyInstance table <> compileDefaultIdInstance table) + Just (compilePrimaryKeyInstance table <> "\n" <> compileIdNewtype table) _ -> Nothing) |> Text.intercalate "\n" ] where prelude = [trimming| -- This file is auto generated and will be overriden regulary. Please edit `Application/Schema.sql` to change the Types\n" - {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, InstanceSigs, MultiParamTypeClasses, TypeFamilies, DataKinds, TypeOperators, UndecidableInstances, ConstraintKinds, StandaloneDeriving #-} + {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, InstanceSigs, MultiParamTypeClasses, TypeFamilies, DataKinds, TypeOperators, UndecidableInstances, ConstraintKinds, StandaloneDeriving, DerivingStrategies, GeneralizedNewtypeDeriving, DeriveDataTypeable, PatternSynonyms, ViewPatterns #-} {-# OPTIONS_GHC -Wno-unused-imports -Wno-dodgy-imports -Wno-unused-matches #-} module Generated.ActualTypes.PrimaryKeys where $defaultImports + import qualified Prelude import Generated.Enums + import qualified Data.Functor.Contravariant |] compileStatementPreview :: [Statement] -> Statement -> Text @@ -458,7 +468,7 @@ compileTypeAlias table@(CreateTable { name, columns }) = | otherwise = "" primaryKeyTypeName :: Text -> Text -primaryKeyTypeName name = "Id' " <> tshow name <> "" +primaryKeyTypeName name = tableNameToModelName name <> "Id" compileData :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text compileData table@(CreateTable { name, columns }) = @@ -911,8 +921,125 @@ compileBuild table@(CreateTable { name, columns }) = <> " newRecord = " <> constructor <> " " <> unwords (map toDefaultValueExpr columns) <> " " <> qbDefaults <> " def\n" -compileDefaultIdInstance :: CreateTable -> Text -compileDefaultIdInstance table = "instance Default (Id' \"" <> table.name <> "\") where def = Id def" +-- | Generates the per-table Id newtype, type family instances, and all required typeclass instances. +-- +-- For a table "users" with UUID primary key, generates: +-- +-- > newtype UserId = UserId UUID deriving newtype (Eq, Ord, Hashable, NFData, FromField, ToField, ToJSON, FromJSON, Mapping.IsScalar) deriving stock (Data) +-- > type instance Id' "users" = UserId +-- > type instance GetTableForId UserId = "users" +-- > instance IdNewtype UserId UUID where { toId = UserId; fromId (UserId x) = x } +-- > instance Default UserId where def = UserId def +-- > ... +compileIdNewtype :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text +compileIdNewtype table = case primaryKeyColumns table of + [column] -> compileSingleColumnIdNewtype table column + _ -> compileCompositeIdNewtype table + +-- | Generate Id newtype for single-column primary key tables. +-- Only generates the newtype and instances that don't reference the model type. +-- Instances that need the model type (Fetchable, CollectionFetchRelated, ParamReader, +-- HSX.ApplyAttribute) are generated by 'compileIdNewtypeModelInstances' in the per-table module. +compileSingleColumnIdNewtype :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Column -> Text +compileSingleColumnIdNewtype table column = Text.unlines + [ "newtype " <> idTypeName <> " = " <> idTypeName <> " " <> pkType + <> " deriving newtype (Eq, Ord, Show, Hashable, DeepSeq.NFData, FromField, ToField, Data.Aeson.ToJSON, Data.Aeson.FromJSON, Mapping.IsScalar)" + <> " deriving stock (Data)" + , "type instance Id' " <> tshow table.name <> " = " <> idTypeName + , "type instance GetTableForId " <> idTypeName <> " = " <> tshow table.name + , "instance IdNewtype " <> idTypeName <> " " <> pkType <> " where { toId = " <> idTypeName <> "; fromId (" <> idTypeName <> " x) = x }" + , "instance Default " <> idTypeName <> " where def = " <> idTypeName <> " def" + , "instance IsEmpty " <> idTypeName <> " where isEmpty (" <> idTypeName <> " x) = isEmpty x" + , "instance InputValue " <> idTypeName <> " where inputValue (" <> idTypeName <> " x) = inputValue x" + , "instance IsString " <> idTypeName <> " where" + , " fromString str = case parsePrimaryKey (Data.String.Conversions.cs str) of" + , " Just pk -> " <> idTypeName <> " pk" + , " Nothing -> Prelude.error (\"Unable to convert \" <> Prelude.show str <> \" to " <> idTypeName <> "\")" + , "instance Hasql.Implicits.Encoders.DefaultParamEncoder " <> idTypeName <> " where" + , " defaultParam = Hasql.Encoders.nonNullable Mapping.encoder" + , "instance Hasql.Implicits.Encoders.DefaultParamEncoder [" <> idTypeName <> "] where" + , " defaultParam = Hasql.Encoders.nonNullable $ Hasql.Encoders.foldableArray $ Hasql.Encoders.nonNullable Mapping.encoder" + , "instance Hasql.Implicits.Encoders.DefaultParamEncoder (Maybe " <> idTypeName <> ") where" + , " defaultParam = Hasql.Encoders.nullable Mapping.encoder" + , "instance Hasql.Implicits.Encoders.DefaultParamEncoder [Maybe " <> idTypeName <> "] where" + , " defaultParam = Hasql.Encoders.nonNullable $ Hasql.Encoders.foldableArray $ Hasql.Encoders.nullable Mapping.encoder" + ] + where + idTypeName = primaryKeyTypeName table.name + pkType = atomicType column.columnType + +-- | Generates instances that reference the model type (Fetchable, CollectionFetchRelated, +-- ParamReader, HSX.ApplyAttribute). These go into per-table modules where the model type is in scope. +compileIdNewtypeModelInstances :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text +compileIdNewtypeModelInstances table = case primaryKeyColumns table of + [_column] -> Text.unlines + [ "instance HSX.ApplyAttribute " <> idTypeName <> " where" + , " applyAttribute attr attr' (" <> idTypeName <> " x) h = HSX.applyAttribute attr attr' (inputValue x) h" + , "instance ParamReader " <> idTypeName <> " where" + , " readParameter bytes = " <> idTypeName <> " <$> readParameter bytes" + , " readParameterJSON value = " <> idTypeName <> " <$> readParameterJSON value" + , compileFetchableIdInstances table + , "instance CollectionFetchRelated " <> idTypeName <> " " <> modelName <> " where" + , " collectionFetchRelated = collectionFetchRelatedById" + , "instance CollectionFetchRelatedOrNothing " <> idTypeName <> " " <> modelName <> " where" + , " collectionFetchRelatedOrNothing = collectionFetchRelatedOrNothingById" + ] + _ -> "" -- Composite PKs don't get these instances + where + idTypeName = primaryKeyTypeName table.name + modelName = tableNameToModelName table.name + +-- | Generate Fetchable instances for a single-column Id newtype +compileFetchableIdInstances :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text +compileFetchableIdInstances table = Text.intercalate "\n" + [ "instance Fetchable " <> idTypeName <> " " <> modelName <> " where" + , " type FetchResult " <> idTypeName <> " " <> modelName <> " = " <> modelName + , " {-# INLINE fetch #-}" + , " fetch = genericFetchIdOne" + , " {-# INLINE fetchOneOrNothing #-}" + , " fetchOneOrNothing = genericfetchIdOneOrNothing" + , " {-# INLINE fetchOne #-}" + , " fetchOne = genericFetchIdOne" + , "instance Fetchable (Maybe " <> idTypeName <> ") " <> modelName <> " where" + , " type FetchResult (Maybe " <> idTypeName <> ") " <> modelName <> " = [" <> modelName <> "]" + , " {-# INLINE fetch #-}" + , " fetch (Just a) = genericFetchId a" + , " fetch Nothing = pure []" + , " {-# INLINE fetchOneOrNothing #-}" + , " fetchOneOrNothing Nothing = pure Nothing" + , " fetchOneOrNothing (Just a) = genericfetchIdOneOrNothing a" + , " {-# INLINE fetchOne #-}" + , " fetchOne (Just a) = genericFetchIdOne a" + , " fetchOne Nothing = error \"Fetchable (Maybe " <> idTypeName <> "): Failed to fetch because given id is 'Nothing', 'Just id' was expected\"" + , "instance Fetchable [" <> idTypeName <> "] " <> modelName <> " where" + , " type FetchResult [" <> idTypeName <> "] " <> modelName <> " = [" <> modelName <> "]" + , " {-# INLINE fetch #-}" + , " fetch = genericFetchIds" + , " {-# INLINE fetchOneOrNothing #-}" + , " fetchOneOrNothing = genericfetchIdsOneOrNothing" + , " {-# INLINE fetchOne #-}" + , " fetchOne = genericFetchIdsOne" + ] + where + idTypeName = primaryKeyTypeName table.name + modelName = tableNameToModelName table.name + +-- | Generate Id handling for composite primary key tables. +-- These get simpler treatment - the PrimaryKey type is a tuple, wrapped in Id for pattern matching. +compileCompositeIdNewtype :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text +compileCompositeIdNewtype table = Text.unlines + [ "newtype " <> idTypeName <> " = " <> idTypeName <> " (" <> pkTupleType <> ")" + <> " deriving stock (Eq, Ord, Data)" + , "type instance Id' " <> tshow table.name <> " = " <> idTypeName + , "type instance GetTableForId " <> idTypeName <> " = " <> tshow table.name + , "instance IdNewtype " <> idTypeName <> " (" <> pkTupleType <> ") where { toId = " <> idTypeName <> "; fromId (" <> idTypeName <> " x) = x }" + , "instance Default " <> idTypeName <> " where def = " <> idTypeName <> " def" + , "instance Show " <> idTypeName <> " where show (" <> idTypeName <> " x) = Prelude.show x" + ] + where + idTypeName = primaryKeyTypeName table.name + pkColumns = primaryKeyColumns table + pkTupleType = intercalate ", " (map (\col -> haskellType table col) pkColumns) toDefaultValueExpr :: Column -> Text @@ -957,7 +1084,7 @@ compilePrimaryKeyInstance table@(CreateTable { name, columns, constraints }) = [ idType = case primaryKeyColumns table of [] -> error $ "Impossible happened in compilePrimaryKeyInstance. No primary keys found for table " <> cs name <> ". At least one primary key is required." [column] -> atomicType column.columnType -- PrimaryKey User = UUID - cs -> "(" <> intercalate ", " (map colType cs) <> ")" -- PrimaryKey PostsTag = (Id' "posts", Id' "tags") + cs -> "(" <> intercalate ", " (map colType cs) <> ")" -- PrimaryKey PostsTag = (PostId, TagId) where colType column = haskellType table column @@ -1085,7 +1212,7 @@ compileFieldBitInstances table@(CreateTable { name }) = unlines (map compileInst compileHasFieldId :: (?schema :: Schema, ?compilerOptions :: CompilerOptions) => CreateTable -> Text compileHasFieldId table@CreateTable { name, primaryKeyConstraint } = cs [i| -instance HasField "id" #{tableNameToModelName name} (Id' "#{name}") where +instance HasField "id" #{tableNameToModelName name} (#{primaryKeyTypeName name}) where getField (#{compileDataTypePattern table}) = #{compilePrimaryKeyValue} {-# INLINE getField #-} |] diff --git a/ihp-typed-sql/IHP/TypedSql/Decoders.hs b/ihp-typed-sql/IHP/TypedSql/Decoders.hs index c402b8d87..ab2af95c1 100644 --- a/ihp-typed-sql/IHP/TypedSql/Decoders.hs +++ b/ihp-typed-sql/IHP/TypedSql/Decoders.hs @@ -13,7 +13,6 @@ import qualified Hasql.Decoders as HasqlDecoders import qualified Hasql.Mapping.IsScalar as Mapping import qualified Language.Haskell.TH as TH import IHP.Hasql.FromRow as HasqlFromRow -import IHP.ModelSupport.Types (Id' (..)) import IHP.Prelude import IHP.TypedSql.Metadata (ColumnMeta (..), DescribeColumn (..), PgTypeInfo (..), TableMeta (..)) diff --git a/ihp-typed-sql/IHP/TypedSql/TypeMapping.hs b/ihp-typed-sql/IHP/TypedSql/TypeMapping.hs index b2cfd565f..cabdb49ec 100644 --- a/ihp-typed-sql/IHP/TypedSql/TypeMapping.hs +++ b/ihp-typed-sql/IHP/TypedSql/TypeMapping.hs @@ -17,7 +17,6 @@ import qualified Data.Set as Set import qualified Data.String.Conversions as CS import qualified Database.PostgreSQL.LibPQ as PQ import qualified Language.Haskell.TH as TH -import IHP.ModelSupport.Types (Id') import IHP.Prelude import PostgresqlTypes.Point (Point) import PostgresqlTypes.Polygon (Polygon) diff --git a/ihp-typed-sql/Test/Test/TypedSqlSpec.hs b/ihp-typed-sql/Test/Test/TypedSqlSpec.hs index e2901fbb9..a85b864cc 100644 --- a/ihp-typed-sql/Test/Test/TypedSqlSpec.hs +++ b/ihp-typed-sql/Test/Test/TypedSqlSpec.hs @@ -1,6 +1,7 @@ module Test.TypedSqlSpec where import qualified Control.Exception as Exception +import qualified Data.Char as Char import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Text.IO as Text @@ -542,6 +543,38 @@ runtimeTest description moduleText = assertGhciSuccess ghciOutput ghciOutput `shouldContainText` "RUNTIME_OK" +-- | Generate Id newtype boilerplate for a test table. +-- E.g. for "typed_sql_test_items" generates TypedSqlTestItemId newtype. +mkTestIdNewtype :: Text -> [Text] +mkTestIdNewtype tableName = + let idName = tableNameToIdName tableName + in [ "type instance PrimaryKey \"" <> tableName <> "\" = UUID" + , "newtype " <> idName <> " = " <> idName <> " UUID deriving newtype (Eq, Ord, Show, Mapping.IsScalar)" + , "type instance Id' \"" <> tableName <> "\" = " <> idName + , "instance IdNewtype " <> idName <> " UUID where { toId = " <> idName <> "; fromId (" <> idName <> " x) = x }" + , "instance IsString " <> idName <> " where" + , " fromString str = case Text.Read.readMaybe str of" + , " Just pk -> " <> idName <> " pk" + , " Nothing -> error \"Unable to convert to " <> idName <> "\"" + , "instance Hasql.Implicits.Encoders.DefaultParamEncoder " <> idName <> " where defaultParam = Hasql.Encoders.nonNullable Mapping.encoder" + , "instance Hasql.Implicits.Encoders.DefaultParamEncoder [" <> idName <> "] where defaultParam = Hasql.Encoders.nonNullable $ Hasql.Encoders.foldableArray $ Hasql.Encoders.nonNullable Mapping.encoder" + , "" + ] + +-- | Convert a table name like "typed_sql_test_items" to an Id type name like "TypedSqlTestItemId". +tableNameToIdName :: Text -> Text +tableNameToIdName tableName = + let parts = Text.splitOn "_" tableName + capitalize t = case Text.uncons t of + Just (c, rest) -> Text.cons (Char.toUpper c) rest + Nothing -> t + -- Singularize: drop trailing 's' from last part + singularize t = fromMaybe t (Text.stripSuffix "s" t) + modelName = case reverse parts of + [] -> "" + (lastPart:restParts) -> mconcat (map capitalize (reverse restParts)) <> singularize (capitalize lastPart) + in modelName <> "Id" + -- | Build a test module from a type signature and body expression. -- Used for both compile-pass and compile-fail tests. mkTestModule :: Text -> Text -> Text @@ -562,6 +595,8 @@ mkTestModule typeSig body = Text.unlines mkTestModuleWithPK :: [Text] -> Text -> Text -> Text mkTestModuleWithPK pkTables typeSig body = Text.unlines $ [ "{-# LANGUAGE DataKinds #-}" + , "{-# LANGUAGE DerivingStrategies #-}" + , "{-# LANGUAGE GeneralizedNewtypeDeriving #-}" , "{-# LANGUAGE NoImplicitPrelude #-}" , "{-# LANGUAGE OverloadedStrings #-}" , "{-# LANGUAGE QuasiQuotes #-}" @@ -569,11 +604,15 @@ mkTestModuleWithPK pkTables typeSig body = Text.unlines $ , "module TypedSqlCase where" , "" , "import IHP.Prelude" - , "import IHP.ModelSupport (Id'(..), PrimaryKey)" + , "import IHP.ModelSupport (Id', PrimaryKey, IdNewtype(..))" , "import IHP.TypedSql (TypedQuery, typedSql)" + , "import qualified Hasql.Implicits.Encoders" + , "import qualified Hasql.Encoders" + , "import qualified Hasql.Mapping.IsScalar as Mapping" + , "import qualified Text.Read" , "" ] - <> map (\t -> "type instance PrimaryKey \"" <> t <> "\" = UUID") pkTables + <> concatMap mkTestIdNewtype pkTables <> [ "" , "query :: " <> typeSig @@ -583,8 +622,10 @@ mkTestModuleWithPK pkTables typeSig body = Text.unlines $ -- Test modules --------------------------------------------------------------- compilePassModule :: Text -compilePassModule = Text.unlines +compilePassModule = Text.unlines $ [ "{-# LANGUAGE DataKinds #-}" + , "{-# LANGUAGE DerivingStrategies #-}" + , "{-# LANGUAGE GeneralizedNewtypeDeriving #-}" , "{-# LANGUAGE NoImplicitPrelude #-}" , "{-# LANGUAGE OverloadedStrings #-}" , "{-# LANGUAGE QuasiQuotes #-}" @@ -593,14 +634,20 @@ compilePassModule = Text.unlines , "module TypedSqlCompilePass where" , "" , "import IHP.Prelude" - , "import IHP.ModelSupport (Id'(..), PrimaryKey)" + , "import IHP.ModelSupport (Id', PrimaryKey, IdNewtype(..))" , "import IHP.Hasql.FromRow (FromRowHasql (..))" , "import IHP.TypedSql (TypedQuery, typedSql)" , "import qualified Hasql.Decoders as HasqlDecoders" + , "import qualified Hasql.Implicits.Encoders" + , "import qualified Hasql.Encoders" + , "import qualified Hasql.Mapping.IsScalar as Mapping" + , "import qualified Text.Read" , "" - , "type instance PrimaryKey \"typed_sql_test_items\" = UUID" - , "type instance PrimaryKey \"typed_sql_test_authors\" = UUID" - , "" + ] + <> mkTestIdNewtype "typed_sql_test_items" + <> mkTestIdNewtype "typed_sql_test_authors" + <> + [ "" , "data TypedSqlTestItem = TypedSqlTestItem" , " { typedSqlTestItemId :: Id' \"typed_sql_test_items\"" , " , typedSqlTestItemAuthorId :: Maybe (Id' \"typed_sql_test_authors\")" @@ -730,8 +777,10 @@ compilePassModule = Text.unlines ] runtimeModule :: Text -runtimeModule = Text.unlines +runtimeModule = Text.unlines $ [ "{-# LANGUAGE DataKinds #-}" + , "{-# LANGUAGE DerivingStrategies #-}" + , "{-# LANGUAGE GeneralizedNewtypeDeriving #-}" , "{-# LANGUAGE ImplicitParams #-}" , "{-# LANGUAGE NoImplicitPrelude #-}" , "{-# LANGUAGE OverloadedStrings #-}" @@ -742,15 +791,21 @@ runtimeModule = Text.unlines , "import qualified Control.Exception as Exception" , "import IHP.Prelude" , "import IHP.Log.Types" - , "import IHP.ModelSupport (Id'(..), ModelContext, PrimaryKey, createModelContext, releaseModelContext)" + , "import IHP.ModelSupport (Id', ModelContext, PrimaryKey, IdNewtype(..), createModelContext, releaseModelContext)" , "import IHP.Hasql.FromRow (FromRowHasql (..))" , "import IHP.TypedSql (sqlExecTyped, sqlQueryTyped, typedSql)" , "import qualified Hasql.Decoders as HasqlDecoders" + , "import qualified Hasql.Implicits.Encoders" + , "import qualified Hasql.Encoders" + , "import qualified Hasql.Mapping.IsScalar as Mapping" + , "import qualified Text.Read" , "import System.Environment (lookupEnv)" , "" - , "type instance PrimaryKey \"typed_sql_test_items\" = UUID" - , "type instance PrimaryKey \"typed_sql_test_authors\" = UUID" - , "" + ] + <> mkTestIdNewtype "typed_sql_test_items" + <> mkTestIdNewtype "typed_sql_test_authors" + <> + [ "" , "data TypedSqlTestItem = TypedSqlTestItem" , " { typedSqlTestItemId :: Id' \"typed_sql_test_items\"" , " , typedSqlTestItemAuthorId :: Maybe (Id' \"typed_sql_test_authors\")" @@ -974,8 +1029,10 @@ runtimeModule = Text.unlines ] runtimeUpdateDeleteModule :: Text -runtimeUpdateDeleteModule = Text.unlines +runtimeUpdateDeleteModule = Text.unlines $ [ "{-# LANGUAGE DataKinds #-}" + , "{-# LANGUAGE DerivingStrategies #-}" + , "{-# LANGUAGE GeneralizedNewtypeDeriving #-}" , "{-# LANGUAGE ImplicitParams #-}" , "{-# LANGUAGE NoImplicitPrelude #-}" , "{-# LANGUAGE OverloadedStrings #-}" @@ -986,13 +1043,19 @@ runtimeUpdateDeleteModule = Text.unlines , "import qualified Control.Exception as Exception" , "import IHP.Prelude" , "import IHP.Log.Types" - , "import IHP.ModelSupport (Id'(..), ModelContext, PrimaryKey, createModelContext, releaseModelContext)" + , "import IHP.ModelSupport (Id', ModelContext, PrimaryKey, IdNewtype(..), createModelContext, releaseModelContext)" , "import IHP.TypedSql (sqlExecTyped, sqlQueryTyped, typedSql)" + , "import qualified Hasql.Implicits.Encoders" + , "import qualified Hasql.Encoders" + , "import qualified Hasql.Mapping.IsScalar as Mapping" + , "import qualified Text.Read" , "import System.Environment (lookupEnv)" , "" - , "type instance PrimaryKey \"typed_sql_test_items\" = UUID" - , "type instance PrimaryKey \"typed_sql_test_authors\" = UUID" - , "" + ] + <> mkTestIdNewtype "typed_sql_test_items" + <> mkTestIdNewtype "typed_sql_test_authors" + <> + [ "" , "assertTest :: Text -> Bool -> IO ()" , "assertTest name True = putStrLn (\"PASS: \" <> name)" , "assertTest name False = error (\"FAIL: \" <> name)" @@ -1062,8 +1125,10 @@ runtimeUpdateDeleteModule = Text.unlines ] runtimeEdgeCasesModule :: Text -runtimeEdgeCasesModule = Text.unlines +runtimeEdgeCasesModule = Text.unlines $ [ "{-# LANGUAGE DataKinds #-}" + , "{-# LANGUAGE DerivingStrategies #-}" + , "{-# LANGUAGE GeneralizedNewtypeDeriving #-}" , "{-# LANGUAGE ImplicitParams #-}" , "{-# LANGUAGE NoImplicitPrelude #-}" , "{-# LANGUAGE OverloadedStrings #-}" @@ -1074,13 +1139,19 @@ runtimeEdgeCasesModule = Text.unlines , "import qualified Control.Exception as Exception" , "import IHP.Prelude" , "import IHP.Log.Types" - , "import IHP.ModelSupport (Id'(..), ModelContext, PrimaryKey, createModelContext, releaseModelContext)" + , "import IHP.ModelSupport (Id', ModelContext, PrimaryKey, IdNewtype(..), createModelContext, releaseModelContext)" , "import IHP.TypedSql (sqlExecTyped, sqlQueryTyped, typedSql)" + , "import qualified Hasql.Implicits.Encoders" + , "import qualified Hasql.Encoders" + , "import qualified Hasql.Mapping.IsScalar as Mapping" + , "import qualified Text.Read" , "import System.Environment (lookupEnv)" , "" - , "type instance PrimaryKey \"typed_sql_test_items\" = UUID" - , "type instance PrimaryKey \"typed_sql_test_authors\" = UUID" - , "" + ] + <> mkTestIdNewtype "typed_sql_test_items" + <> mkTestIdNewtype "typed_sql_test_authors" + <> + [ "" , "assertTest :: Text -> Bool -> IO ()" , "assertTest name True = putStrLn (\"PASS: \" <> name)" , "assertTest name False = error (\"FAIL: \" <> name)" diff --git a/ihp/IHP/AuthSupport/Controller/Sessions.hs b/ihp/IHP/AuthSupport/Controller/Sessions.hs index ea9a6f472..70f3f72a6 100644 --- a/ihp/IHP/AuthSupport/Controller/Sessions.hs +++ b/ihp/IHP/AuthSupport/Controller/Sessions.hs @@ -68,6 +68,7 @@ createSessionAction :: forall record action. , SetField "failedLoginAttempts" record Int , CanUpdate record , Show (PrimaryKey (GetTableName record)) + , Show (Id record) , record ~ GetModelByTableName (GetTableName record) , Table record , FromRowHasql record diff --git a/ihp/IHP/Controller/FileUpload.hs b/ihp/IHP/Controller/FileUpload.hs index 162872b55..3565762c9 100644 --- a/ihp/IHP/Controller/FileUpload.hs +++ b/ihp/IHP/Controller/FileUpload.hs @@ -147,7 +147,7 @@ uploadImageWithOptions :: forall (fieldName :: Symbol) record (tableName :: Symb , SetField fieldName record (Maybe Text) , KnownSymbol fieldName , HasField "id" record (ModelSupport.Id (ModelSupport.NormalizeModel record)) - , Show (ModelSupport.PrimaryKey (ModelSupport.GetTableName (ModelSupport.NormalizeModel record))) + , Show (ModelSupport.Id (ModelSupport.NormalizeModel record)) , tableName ~ ModelSupport.GetTableName record , KnownSymbol tableName ) => ImageUploadOptions -> Proxy fieldName -> record -> IO record @@ -197,7 +197,7 @@ uploadImageFile :: forall (fieldName :: Symbol) record (tableName :: Symbol). ( , SetField fieldName record (Maybe Text) , KnownSymbol fieldName , HasField "id" record (ModelSupport.Id (ModelSupport.NormalizeModel record)) - , Show (ModelSupport.PrimaryKey (ModelSupport.GetTableName (ModelSupport.NormalizeModel record))) + , Show (ModelSupport.Id (ModelSupport.NormalizeModel record)) , tableName ~ ModelSupport.GetTableName record , KnownSymbol tableName ) => Text -> Proxy fieldName -> record -> IO record @@ -222,7 +222,7 @@ uploadPng :: ( ?request :: Request , SetField fieldName record (Maybe Text) , HasField "id" record (ModelSupport.Id' (GetTableName (ModelSupport.GetModelByTableName (GetTableName record)))) - , Show (ModelSupport.PrimaryKey (GetTableName (ModelSupport.GetModelByTableName (GetTableName record)))) + , Show (ModelSupport.Id' (GetTableName (ModelSupport.GetModelByTableName (GetTableName record)))) , KnownSymbol fieldName , KnownSymbol (GetTableName record) ) => Proxy fieldName -> record -> IO record @@ -234,7 +234,7 @@ uploadSVG :: ( ?request :: Request , SetField fieldName record (Maybe Text) , HasField "id" record (ModelSupport.Id' (GetTableName (ModelSupport.GetModelByTableName (GetTableName record)))) - , Show (ModelSupport.PrimaryKey (GetTableName (ModelSupport.GetModelByTableName (GetTableName record)))) + , Show (ModelSupport.Id' (GetTableName (ModelSupport.GetModelByTableName (GetTableName record)))) , KnownSymbol fieldName , KnownSymbol (GetTableName record) ) => Proxy fieldName -> record -> IO record diff --git a/ihp/IHP/Controller/Param.hs b/ihp/IHP/Controller/Param.hs index 4de73730d..c3eb671c0 100644 --- a/ihp/IHP/Controller/Param.hs +++ b/ihp/IHP/Controller/Param.hs @@ -312,10 +312,8 @@ instance ParamReader ModelSupport.Polygon where readParameterJSON (Aeson.String string) = let byteString :: ByteString = cs string in readParameter byteString readParameterJSON _ = Left "Expected Polygon" -instance {-# OVERLAPS #-} (ParamReader (ModelSupport.PrimaryKey model')) => ParamReader (ModelSupport.Id' model') where - {-# INLINABLE readParameter #-} - readParameter uuid = ModelSupport.Id <$> readParameter uuid - readParameterJSON value = ModelSupport.Id <$> readParameterJSON value +-- Per-table ParamReader instances for Id newtypes (UserId, ProjectId, etc.) +-- are generated by the schema compiler in Generated.ActualTypes.PrimaryKeys. -- | Can be used as a default implementation for 'readParameter' for enum structures -- diff --git a/ihp/IHP/Controller/Session.hs b/ihp/IHP/Controller/Session.hs index 8a46058d6..bb59e9b01 100644 --- a/ihp/IHP/Controller/Session.hs +++ b/ihp/IHP/Controller/Session.hs @@ -1,5 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} {-| Module: IHP.Controller.Session Description: Functions to work with session cookies, provides 'setSession', 'getSession' and friends @@ -32,7 +34,7 @@ import Prelude import Data.ByteString (ByteString) import Data.Maybe (isJust) import Control.Monad (when) -import IHP.ModelSupport.Types (PrimaryKey, Id'(..)) +import IHP.ModelSupport.Types (IdNewtype(..)) import Data.UUID (UUID) import qualified Data.UUID as UUID import qualified Data.Vault.Lazy as Vault @@ -148,13 +150,13 @@ getSessionAndClear name = do pure value {-# INLINABLE getSessionAndClear #-} -instance (PrimaryKey table ~ UUID) => Serialize (Id' table) where - put (Id value) = Serialize.put (UUID.toASCIIBytes value) +instance {-# OVERLAPPABLE #-} (IdNewtype id UUID) => Serialize id where + put id = Serialize.put (UUID.toASCIIBytes (fromId id)) get = do maybeUUID <- UUID.fromASCIIBytes <$> Serialize.get case maybeUUID of Nothing -> fail "Failed to parse UUID" - Just uuid -> pure (Id uuid) + Just uuid -> pure (toId uuid) sessionInsert :: (?request :: Request) => ByteString -> ByteString -> IO () sessionInsert = snd sessionVault diff --git a/ihp/IHP/Fetch.hs b/ihp/IHP/Fetch.hs index 1584d6985..d8faa9ef7 100644 --- a/ihp/IHP/Fetch.hs +++ b/ihp/IHP/Fetch.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, TypeFamilies, DataKinds, PolyKinds, TypeApplications, ScopedTypeVariables, ConstraintKinds, TypeOperators, GADTs, UndecidableInstances, StandaloneDeriving, FunctionalDependencies, FlexibleContexts, InstanceSigs, AllowAmbiguousTypes, DeriveAnyClass #-} +{-# LANGUAGE BangPatterns, TypeFamilies, DataKinds, PolyKinds, TypeApplications, ScopedTypeVariables, ConstraintKinds, TypeOperators, GADTs, UndecidableInstances, StandaloneDeriving, FunctionalDependencies, FlexibleContexts, InstanceSigs, AllowAmbiguousTypes, DeriveAnyClass, FlexibleInstances #-} {-| Module: IHP.Fetch Description: fetch, fetchOne, fetchOneOrNothing and friends @@ -187,15 +187,15 @@ genericFetchIdOne !id = do Nothing -> throwIO RecordNotFoundException { queryAndParams = cs (Hasql.toSql (fetchByIdOneOrNothingStatement @table @model)) } {-# INLINE genericFetchIds #-} -genericFetchIds :: forall table model. (Table model, KnownSymbol table, FromRowHasql model, ?modelContext :: ModelContext, model ~ GetModelByTableName table, GetTableName model ~ table, DefaultParamEncoder [PrimaryKey (GetTableName model)]) => [Id model] -> IO [model] +genericFetchIds :: forall table model. (Table model, KnownSymbol table, FromRowHasql model, ?modelContext :: ModelContext, model ~ GetModelByTableName table, GetTableName model ~ table, DefaultParamEncoder [PrimaryKey (GetTableName model)], IdNewtype (Id' table) (PrimaryKey table)) => [Id model] -> IO [model] genericFetchIds !ids = query @model |> filterWhereIdIn ids |> fetch {-# INLINE genericfetchIdsOneOrNothing #-} -genericfetchIdsOneOrNothing :: forall table model. (Table model, KnownSymbol table, FromRowHasql model, ?modelContext :: ModelContext, model ~ GetModelByTableName table, GetTableName model ~ table, DefaultParamEncoder [PrimaryKey (GetTableName model)]) => [Id model] -> IO (Maybe model) +genericfetchIdsOneOrNothing :: forall table model. (Table model, KnownSymbol table, FromRowHasql model, ?modelContext :: ModelContext, model ~ GetModelByTableName table, GetTableName model ~ table, DefaultParamEncoder [PrimaryKey (GetTableName model)], IdNewtype (Id' table) (PrimaryKey table)) => [Id model] -> IO (Maybe model) genericfetchIdsOneOrNothing !ids = query @model |> filterWhereIdIn ids |> fetchOneOrNothing {-# INLINE genericFetchIdsOne #-} -genericFetchIdsOne :: forall table model. (Table model, KnownSymbol table, FromRowHasql model, ?modelContext :: ModelContext, model ~ GetModelByTableName table, GetTableName model ~ table, DefaultParamEncoder [PrimaryKey (GetTableName model)]) => [Id model] -> IO model +genericFetchIdsOne :: forall table model. (Table model, KnownSymbol table, FromRowHasql model, ?modelContext :: ModelContext, model ~ GetModelByTableName table, GetTableName model ~ table, DefaultParamEncoder [PrimaryKey (GetTableName model)], IdNewtype (Id' table) (PrimaryKey table)) => [Id model] -> IO model genericFetchIdsOne !ids = query @model |> filterWhereIdIn ids |> fetchOne {-# INLINE findBy #-} @@ -209,35 +209,8 @@ findMaybeBy !field !value !queryBuilder = queryBuilder |> filterWhere (field, va findManyBy !field !value !queryBuilder = queryBuilder |> filterWhere (field, value) |> fetch -- Step.findOneByWorkflowId id == queryBuilder |> findBy #templateId id -instance (model ~ GetModelById (Id' table), GetTableName model ~ table, FilterPrimaryKey table, DefaultParamEncoder (Id' table)) => Fetchable (Id' table) model where - type FetchResult (Id' table) model = model - {-# INLINE fetch #-} - fetch = genericFetchIdOne - {-# INLINE fetchOneOrNothing #-} - fetchOneOrNothing = genericfetchIdOneOrNothing - {-# INLINE fetchOne #-} - fetchOne = genericFetchIdOne - -instance (model ~ GetModelById (Id' table), GetTableName model ~ table, FilterPrimaryKey table, DefaultParamEncoder (Id' table)) => Fetchable (Maybe (Id' table)) model where - type FetchResult (Maybe (Id' table)) model = [model] - {-# INLINE fetch #-} - fetch (Just a) = genericFetchId a - fetch Nothing = pure [] - {-# INLINE fetchOneOrNothing #-} - fetchOneOrNothing Nothing = pure Nothing - fetchOneOrNothing (Just a) = genericfetchIdOneOrNothing a - {-# INLINE fetchOne #-} - fetchOne (Just a) = genericFetchIdOne a - fetchOne Nothing = error "Fetchable (Maybe Id): Failed to fetch because given id is 'Nothing', 'Just id' was expected" - -instance (model ~ GetModelById (Id' table), GetModelByTableName table ~ model, GetTableName model ~ table, DefaultParamEncoder [PrimaryKey table]) => Fetchable [Id' table] model where - type FetchResult [Id' table] model = [model] - {-# INLINE fetch #-} - fetch = genericFetchIds - {-# INLINE fetchOneOrNothing #-} - fetchOneOrNothing = genericfetchIdsOneOrNothing - {-# INLINE fetchOne #-} - fetchOne = genericFetchIdsOne +-- Fetchable instances for per-table Id newtypes (UserId, ProjectId, etc.) +-- are generated by the schema compiler in Generated.ActualTypes. -- | Returns the latest record or Nothing -- diff --git a/ihp/IHP/Fetch/Statement.hs b/ihp/IHP/Fetch/Statement.hs index 1fa71a57f..166d3dcd5 100644 --- a/ihp/IHP/Fetch/Statement.hs +++ b/ihp/IHP/Fetch/Statement.hs @@ -18,7 +18,7 @@ module IHP.Fetch.Statement import Prelude import IHP.ModelSupport (Table(..), primaryKeyConditionColumnSelector, GetModelByTableName) -import IHP.ModelSupport.Types (Id'(..), GetTableName) +import IHP.ModelSupport.Types (Id', GetTableName) import IHP.Hasql.FromRow (FromRowHasql(..)) import qualified Hasql.Statement as Hasql import qualified Hasql.Decoders as Decoders diff --git a/ihp/IHP/FetchRelated.hs b/ihp/IHP/FetchRelated.hs index 5a38fbcf5..1dd91a472 100644 --- a/ihp/IHP/FetchRelated.hs +++ b/ihp/IHP/FetchRelated.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeFamilies, DataKinds, MultiParamTypeClasses, PolyKinds, TypeApplications, ScopedTypeVariables, ConstraintKinds, TypeOperators, GADTs, UndecidableInstances, StandaloneDeriving, FunctionalDependencies, FlexibleContexts, AllowAmbiguousTypes #-} +{-# LANGUAGE TypeFamilies, DataKinds, MultiParamTypeClasses, PolyKinds, TypeApplications, ScopedTypeVariables, ConstraintKinds, TypeOperators, GADTs, UndecidableInstances, StandaloneDeriving, FunctionalDependencies, FlexibleContexts, AllowAmbiguousTypes, FlexibleInstances #-} {-| Module: IHP.FetchRelated Description: Provides fetchRelated, collectionFetchRelated, etc. @@ -8,10 +8,10 @@ This modules provides helper functions to access relationshops for a model. See https://ihp.digitallyinduced.com/Guide/relationships.html for some examples. -} -module IHP.FetchRelated (fetchRelated, collectionFetchRelated, collectionFetchRelatedOrNothing, fetchRelatedOrNothing, maybeFetchRelatedOrNothing) where +module IHP.FetchRelated (fetchRelated, collectionFetchRelated, collectionFetchRelatedOrNothing, fetchRelatedOrNothing, maybeFetchRelatedOrNothing, CollectionFetchRelated(..), CollectionFetchRelatedOrNothing(..), collectionFetchRelatedById, collectionFetchRelatedOrNothingById) where import IHP.Prelude -import IHP.ModelSupport (Include, Id', PrimaryKey, GetModelByTableName, Table) +import IHP.ModelSupport (Include, PrimaryKey, GetModelByTableName, Table, GetTableForId) import IHP.QueryBuilder import IHP.Fetch import IHP.Hasql.FromRow (FromRowHasql) @@ -65,43 +65,8 @@ class CollectionFetchRelatedOrNothing relatedFieldValue relatedModel where -- -- > SELECT * FROM users -- > SELECT * FROM companies WHERE id IN (?) -instance ( - Eq (PrimaryKey tableName) - , Show (PrimaryKey tableName) - , HasField "id" relatedModel (Id' tableName) - , relatedModel ~ GetModelByTableName (GetTableName relatedModel) - , GetTableName relatedModel ~ tableName - , Table relatedModel - , DefaultParamEncoder [PrimaryKey tableName] - ) => CollectionFetchRelated (Id' tableName) relatedModel where - collectionFetchRelated :: forall model relatedField. ( - ?modelContext :: ModelContext, - HasField relatedField model (Id' tableName), - UpdateField relatedField model (Include relatedField model) (Id' tableName) (FetchResult (Id' tableName) relatedModel), - Fetchable (Id' tableName) relatedModel, - KnownSymbol (GetTableName relatedModel), - FromRowHasql relatedModel, - KnownSymbol relatedField, - Table relatedModel - ) => Proxy relatedField -> [model] -> IO [Include relatedField model] - collectionFetchRelated relatedField model = do - relatedModels :: [relatedModel] <- query @relatedModel |> filterWhereIdIn (map (getField @relatedField) model) |> fetch - let - assignRelated :: model -> Include relatedField model - assignRelated model = - let - relatedModel :: relatedModel - relatedModel = case find (\r -> r.id == targetForeignKey) relatedModels of - Just m -> m - Nothing -> error ("Could not find record with id = " <> show targetForeignKey <> " in result set. Looks like the foreign key is pointing to a non existing record") - targetForeignKey = (getField @relatedField model :: Id' tableName) - in - updateField @relatedField relatedModel model - - let - result :: [Include relatedField model] - result = map assignRelated model - pure result +-- CollectionFetchRelated instances for per-table Id newtypes (UserId, ProjectId, etc.) +-- are generated by the schema compiler in Generated.ActualTypes.PrimaryKeys. -- | Provides collectionFetchRelatedOrNothing for nullable ids, e.g. @collectionFetchRelatedOrNothing #companyId@ -- @@ -117,39 +82,68 @@ instance ( -- -- > SELECT * FROM users -- > SELECT * FROM companies WHERE id IN (?) -instance ( - Eq (PrimaryKey tableName) - , HasField "id" relatedModel (Id' tableName) - , relatedModel ~ GetModelByTableName (GetTableName relatedModel) - , GetTableName relatedModel ~ tableName - , Table relatedModel - , DefaultParamEncoder [PrimaryKey tableName] - ) => CollectionFetchRelatedOrNothing (Id' tableName) relatedModel where - collectionFetchRelatedOrNothing :: forall model relatedField. ( - ?modelContext :: ModelContext, - HasField relatedField model (Maybe (Id' tableName)), - UpdateField relatedField model (Include relatedField model) (Maybe (Id' tableName)) (Maybe (FetchResult (Id' tableName) relatedModel)), - Fetchable (Id' tableName) relatedModel, - KnownSymbol (GetTableName relatedModel), - FromRowHasql relatedModel, - KnownSymbol relatedField - ) => Proxy relatedField -> [model] -> IO [Include relatedField model] - collectionFetchRelatedOrNothing relatedField model = do - relatedModels :: [relatedModel] <- query @relatedModel |> filterWhereIdIn (mapMaybe (getField @relatedField) model) |> fetch - let - assignRelated :: model -> Include relatedField model - assignRelated model = - let - relatedModel :: Maybe (FetchResult (Id' tableName) relatedModel) - relatedModel = find (\r -> Just r.id == targetForeignKey) relatedModels - targetForeignKey = (getField @relatedField model :: Maybe (Id' tableName)) - in - updateField @relatedField relatedModel model +-- CollectionFetchRelatedOrNothing instances for per-table Id newtypes (UserId, ProjectId, etc.) +-- are generated by the schema compiler in Generated.ActualTypes.PrimaryKeys. + +-- | Helper used by generated CollectionFetchRelated instances for Id newtypes +collectionFetchRelatedById :: forall id relatedModel model relatedField. + ( ?modelContext :: ModelContext + , HasField relatedField model id + , IdNewtype id (PrimaryKey (GetTableForId id)) + , id ~ Id' (GetTableForId id) + , Eq id, Show id + , Table relatedModel + , GetTableName relatedModel ~ GetTableForId id + , relatedModel ~ GetModelByTableName (GetTableForId id) + , HasField "id" relatedModel id + , UpdateField relatedField model (Include relatedField model) id relatedModel + , KnownSymbol (GetTableName relatedModel) + , FromRowHasql relatedModel + , KnownSymbol relatedField + , DefaultParamEncoder [PrimaryKey (GetTableForId id)] + ) => Proxy relatedField -> [model] -> IO [Include relatedField model] +collectionFetchRelatedById relatedField model = do + relatedModels :: [relatedModel] <- query @relatedModel |> filterWhereIdIn (map (getField @relatedField) model) |> fetch + let + assignRelated m = + let + rm :: relatedModel + rm = case find (\r -> r.id == tf) relatedModels of + Just x -> x + Nothing -> error ("Could not find record with id = " <> show tf <> " in result set. Looks like the foreign key is pointing to a non existing record") + tf = (getField @relatedField m :: id) + in + updateField @relatedField rm m + pure (map assignRelated model) - let - result :: [Include relatedField model] - result = map assignRelated model - pure result +-- | Helper used by generated CollectionFetchRelatedOrNothing instances for Id newtypes +collectionFetchRelatedOrNothingById :: forall id relatedModel model relatedField. + ( ?modelContext :: ModelContext + , HasField relatedField model (Maybe id) + , IdNewtype id (PrimaryKey (GetTableForId id)) + , id ~ Id' (GetTableForId id) + , Eq id + , Table relatedModel + , GetTableName relatedModel ~ GetTableForId id + , relatedModel ~ GetModelByTableName (GetTableForId id) + , HasField "id" relatedModel id + , UpdateField relatedField model (Include relatedField model) (Maybe id) (Maybe relatedModel) + , KnownSymbol (GetTableName relatedModel) + , FromRowHasql relatedModel + , KnownSymbol relatedField + , DefaultParamEncoder [PrimaryKey (GetTableForId id)] + ) => Proxy relatedField -> [model] -> IO [Include relatedField model] +collectionFetchRelatedOrNothingById relatedField model = do + relatedModels :: [relatedModel] <- query @relatedModel |> filterWhereIdIn (mapMaybe (getField @relatedField) model) |> fetch + let + assignRelated m = + let + rm :: Maybe relatedModel + rm = find (\r -> Just r.id == tf) relatedModels + tf = (getField @relatedField m :: Maybe id) + in + updateField @relatedField rm m + pure (map assignRelated model) -- | Provides collectionFetchRelated for QueryBuilder's, e.g. @collectionFetchRelated #comments@ -- diff --git a/ihp/IHP/Hasql/Encoders.hs b/ihp/IHP/Hasql/Encoders.hs index a5705c495..f85954aa5 100644 --- a/ihp/IHP/Hasql/Encoders.hs +++ b/ihp/IHP/Hasql/Encoders.hs @@ -32,7 +32,6 @@ import Database.PostgreSQL.Simple (Only(..), (:.)(..)) import Data.Functor.Contravariant (contramap) import Data.Functor.Contravariant.Divisible (divide) import Data.Vector (Vector) -import IHP.ModelSupport.Types (Id'(..), PrimaryKey) import Data.UUID (UUID) import Database.PostgreSQL.Simple.Types (Binary(..)) import qualified Hasql.Mapping.IsScalar as Mapping @@ -67,24 +66,6 @@ instance DefaultParamEncoder [Maybe Int] where instance DefaultParamEncoder (Vector Int) where defaultParam = Encoders.nonNullable $ Encoders.foldableArray $ Encoders.nonNullable (contramap (fromIntegral :: Int -> Int64) Encoders.int8) --- | Encode 'Id' table' for tables with any primary key type that has an 'IsScalar' instance. --- This covers UUID, Text, Int, and other primary key types. -instance Mapping.IsScalar (PrimaryKey table) => DefaultParamEncoder (Id' table) where - defaultParam = Encoders.nonNullable (contramap (\(Id pk) -> pk) Mapping.encoder) - --- | Encode list of 'Id' table' for tables with any encodable primary key type. --- Used by filterWhereIdIn for simple primary keys. -instance Mapping.IsScalar (PrimaryKey table) => DefaultParamEncoder [Id' table] where - defaultParam = Encoders.nonNullable $ Encoders.foldableArray $ Encoders.nonNullable (contramap (\(Id pk) -> pk) Mapping.encoder) - --- | Encode 'Maybe (Id' table)' for nullable foreign keys with any encodable primary key type. -instance Mapping.IsScalar (PrimaryKey table) => DefaultParamEncoder (Maybe (Id' table)) where - defaultParam = Encoders.nullable (contramap (\(Id pk) -> pk) Mapping.encoder) - --- | Encode '[Maybe (Id' table)]' for filterWhereIn with nullable foreign keys. -instance Mapping.IsScalar (PrimaryKey table) => DefaultParamEncoder [Maybe (Id' table)] where - defaultParam = Encoders.nonNullable $ Encoders.foldableArray $ Encoders.nullable (contramap (\(Id pk) -> pk) Mapping.encoder) - -- | Encode '(UUID, UUID)' as PostgreSQL composite/record type -- Used for composite primary keys with two UUID columns instance DefaultParamEncoder (UUID, UUID) where @@ -95,18 +76,6 @@ instance DefaultParamEncoder (UUID, UUID) where instance DefaultParamEncoder [(UUID, UUID)] where defaultParam = Encoders.nonNullable $ Encoders.foldableArray $ Encoders.nonNullable $ Encoders.composite (Nothing :: Maybe Text) "" uuidPairComposite --- | Encode '(Id' a, Id' b)' as PostgreSQL composite/record type --- Used for composite primary keys with two Id columns (where both resolve to UUID) -instance (PrimaryKey a ~ UUID, PrimaryKey b ~ UUID) => DefaultParamEncoder (Id' a, Id' b) where - defaultParam = Encoders.nonNullable $ Encoders.composite (Nothing :: Maybe Text) "" $ - contramap (\(Id a, Id b) -> (a, b)) uuidPairComposite - --- | Encode '[(Id' a, Id' b)]' as PostgreSQL array of composite types --- Used by filterWhereIdIn for tables with composite primary keys of two Id columns -instance (PrimaryKey a ~ UUID, PrimaryKey b ~ UUID) => DefaultParamEncoder [(Id' a, Id' b)] where - defaultParam = Encoders.nonNullable $ Encoders.foldableArray $ Encoders.nonNullable $ Encoders.composite (Nothing :: Maybe Text) "" $ - contramap (\(Id a, Id b) -> (a, b)) uuidPairComposite - -- | Helper: composite encoder for a pair of UUIDs uuidPairComposite :: Encoders.Composite (UUID, UUID) uuidPairComposite = divide id (Encoders.field (Encoders.nonNullable Encoders.uuid)) (Encoders.field (Encoders.nonNullable Encoders.uuid)) diff --git a/ihp/IHP/Hasql/FromRow.hs b/ihp/IHP/Hasql/FromRow.hs index f1fa14e33..17df83f62 100644 --- a/ihp/IHP/Hasql/FromRow.hs +++ b/ihp/IHP/Hasql/FromRow.hs @@ -22,8 +22,7 @@ import Prelude import qualified Hasql.Decoders as Decoders import qualified Hasql.Mapping.IsScalar as Mapping import qualified Database.PostgreSQL.Simple.Types as PG -import Data.Functor.Contravariant (contramap) -import IHP.ModelSupport.Types (LabeledData(..), Id'(..), PrimaryKey) +import IHP.ModelSupport.Types (LabeledData(..)) -- | Typeclass for types that can be decoded from a hasql result row -- @@ -45,20 +44,6 @@ instance {-# OVERLAPPABLE #-} Mapping.IsScalar a => HasqlDecodeColumn a where instance {-# OVERLAPPING #-} Mapping.IsScalar a => HasqlDecodeColumn (Maybe a) where hasqlColumnDecoder = Decoders.column (Decoders.nullable Mapping.decoder) --- | 'IsScalar' instance for 'Id'' so that Id columns can use 'Mapping.encoder' and 'Mapping.decoder' --- directly in generated code, without manual wrapping/unwrapping. -instance Mapping.IsScalar (PrimaryKey table) => Mapping.IsScalar (Id' table) where - encoder = contramap (\(Id pk) -> pk) Mapping.encoder - decoder = Id <$> Mapping.decoder - --- | Decode 'Id' table' by decoding the primary key type and wrapping with 'Id' -instance {-# OVERLAPPING #-} Mapping.IsScalar (PrimaryKey table) => HasqlDecodeColumn (Id' table) where - hasqlColumnDecoder = Decoders.column (Decoders.nonNullable Mapping.decoder) - --- | Decode 'Maybe (Id' table)' for nullable foreign keys -instance {-# OVERLAPPING #-} Mapping.IsScalar (PrimaryKey table) => HasqlDecodeColumn (Maybe (Id' table)) where - hasqlColumnDecoder = Decoders.column (Decoders.nullable Mapping.decoder) - -- FromRowHasql instances for PG.Only and tuples (used by sqlQuery callers like fetchCount, fetchExists) instance HasqlDecodeColumn a => FromRowHasql (PG.Only a) where diff --git a/ihp/IHP/Job/Queue/Result.hs b/ihp/IHP/Job/Queue/Result.hs index 93fdf7336..6f49e9c9e 100644 --- a/ihp/IHP/Job/Queue/Result.hs +++ b/ihp/IHP/Job/Queue/Result.hs @@ -12,7 +12,7 @@ import IHP.Job.Types import IHP.Job.Queue.Pool (runPool) import IHP.Job.Queue.StatusInstances () import IHP.ModelSupport (Table (..), InputValue (..)) -import IHP.ModelSupport.Types (Id' (..), PrimaryKey) +import IHP.ModelSupport.Types (PrimaryKey) import qualified IHP.Log as Log import qualified Hasql.Pool as HasqlPool import qualified Hasql.Session as HasqlSession @@ -26,6 +26,7 @@ jobDidFail :: forall job context. ( Table job , HasField "id" job (Id' (GetTableName job)) , PrimaryKey (GetTableName job) ~ UUID + , IdNewtype (Id' (GetTableName job)) UUID , HasField "attemptsCount" job Int , HasField "runAt" job UTCTime , Job job @@ -60,6 +61,7 @@ jobDidTimeout :: forall job context. ( Table job , HasField "id" job (Id' (GetTableName job)) , PrimaryKey (GetTableName job) ~ UUID + , IdNewtype (Id' (GetTableName job)) UUID , HasField "attemptsCount" job Int , HasField "runAt" job UTCTime , Job job @@ -96,6 +98,7 @@ jobDidSucceed :: forall job context. ( Table job , HasField "id" job (Id' (GetTableName job)) , PrimaryKey (GetTableName job) ~ UUID + , IdNewtype (Id' (GetTableName job)) UUID , ?context :: context , HasField "logger" context Log.Logger ) => HasqlPool.Pool -> job -> IO () diff --git a/ihp/IHP/Job/Runner/WorkerLoop.hs b/ihp/IHP/Job/Runner/WorkerLoop.hs index 187bc2a1c..ca7e1b29a 100644 --- a/ihp/IHP/Job/Runner/WorkerLoop.hs +++ b/ihp/IHP/Job/Runner/WorkerLoop.hs @@ -25,6 +25,7 @@ worker :: forall job. , KnownSymbol (GetTableName job) , HasField "id" job (Id' (GetTableName job)) , PrimaryKey (GetTableName job) ~ UUID + , IdNewtype (Id' (GetTableName job)) UUID , HasField "runAt" job UTCTime , HasField "attemptsCount" job Int , Job job @@ -41,6 +42,7 @@ jobWorkerFetchAndRunLoop :: forall job. , KnownSymbol (GetTableName job) , HasField "id" job (Id' (GetTableName job)) , PrimaryKey (GetTableName job) ~ UUID + , IdNewtype (Id' (GetTableName job)) UUID , HasField "runAt" job UTCTime , HasField "attemptsCount" job Int , Job job diff --git a/ihp/IHP/LoginSupport/Middleware.hs b/ihp/IHP/LoginSupport/Middleware.hs index ee05aaff8..2ea93328a 100644 --- a/ihp/IHP/LoginSupport/Middleware.hs +++ b/ihp/IHP/LoginSupport/Middleware.hs @@ -11,6 +11,7 @@ import IHP.ControllerSupport import IHP.ModelSupport import IHP.Controller.Context import IHP.Hasql.FromRow (FromRowHasql) +import Data.Serialize (Serialize) {-# INLINE initAuthentication #-} initAuthentication :: forall user normalizedModel. @@ -22,6 +23,8 @@ initAuthentication :: forall user normalizedModel. , Table normalizedModel , FromRowHasql normalizedModel , PrimaryKey (GetTableName normalizedModel) ~ UUID + , Serialize (Id user) + , Fetchable (Maybe (Id user)) normalizedModel , GetTableName normalizedModel ~ GetTableName user , FilterPrimaryKey (GetTableName normalizedModel) , KnownSymbol (GetModelName user) diff --git a/ihp/IHP/ModelSupport.hs b/ihp/IHP/ModelSupport.hs index cf546f10a..5cc52301e 100644 --- a/ihp/IHP/ModelSupport.hs +++ b/ihp/IHP/ModelSupport.hs @@ -23,7 +23,6 @@ import Data.Int (Int64) import Data.IORef (IORef, newIORef, modifyIORef') import Control.Exception (bracket, finally, throwIO, Exception, SomeException, try, mask) import Data.Maybe (fromMaybe, isNothing, isJust) -import Data.String (IsString(..)) import Database.PostgreSQL.Simple.Types (Query(..)) import Data.Default import Data.Bits ((.&.), bit, clearBit) @@ -38,7 +37,6 @@ import GHC.Records import GHC.TypeLits import Data.Proxy import Data.Data -import Data.Aeson (ToJSON (..), FromJSON (..)) import qualified Data.Aeson as Aeson import qualified Data.Set as Set import qualified Text.Read as Read @@ -175,47 +173,29 @@ getModelName :: forall model. KnownSymbol (GetModelName model) => Text getModelName = cs $! symbolVal (Proxy :: Proxy (GetModelName model)) {-# INLINE getModelName #-} -instance InputValue (PrimaryKey model') => InputValue (Id' model') where - {-# INLINE inputValue #-} - inputValue = inputValue . unpackId -instance IsEmpty (PrimaryKey table) => IsEmpty (Id' table) where - isEmpty (Id primaryKey) = isEmpty primaryKey - -recordToInputValue :: (HasField "id" entity (Id entity), Show (PrimaryKey (GetTableName entity))) => entity -> Text +recordToInputValue :: (HasField "id" entity (Id entity), IdNewtype (Id entity) (PrimaryKey (GetTableName entity)), Show (PrimaryKey (GetTableName entity))) => entity -> Text recordToInputValue entity = entity.id - |> unpackId + |> fromId |> Text.pack . show {-# INLINE recordToInputValue #-} -instance Show (PrimaryKey model) => Show (Id' model) where - {-# INLINE show #-} - show = show . unpackId - -- | Turns an @UUID@ into a @Id@ type -- -- > let uuid :: UUID = "5240e79c-97ff-4a5f-8567-84112541aaba" -- > let userId :: Id User = packId uuid -- -packId :: PrimaryKey model -> Id' model -packId uuid = Id uuid +packId :: IdNewtype id pk => pk -> id +packId = toId -- | Unwraps a @Id@ value into an @UUID@ -- -- >>> unpackId ("296e5a50-b237-4ee9-83b0-17fb1e6f208f" :: Id User) -- "296e5a50-b237-4ee9-83b0-17fb1e6f208f" :: UUID -- -unpackId :: Id' model -> PrimaryKey model -unpackId (Id uuid) = uuid - --- | Sometimes you have a hardcoded UUID value which represents some record id. This instance allows you --- to write the Id like a string: --- --- > let projectId = "ca63aace-af4b-4e6c-bcfa-76ca061dbdc6" :: Id Project -instance (Read (PrimaryKey model), ParsePrimaryKey (PrimaryKey model)) => IsString (Id' model) where - fromString uuid = textToId uuid - {-# INLINE fromString #-} +unpackId :: IdNewtype id pk => id -> pk +unpackId = fromId instance ParsePrimaryKey UUID where parsePrimaryKey = Read.readMaybe . cs @@ -234,9 +214,9 @@ instance ParsePrimaryKey Text where -- can just write it like: -- -- > let projectId = "ca63aace-af4b-4e6c-bcfa-76ca061dbdc6" :: Id Project -textToId :: (HasCallStack, ParsePrimaryKey (PrimaryKey model), ConvertibleStrings text Text) => text -> Id' model +textToId :: (HasCallStack, IdNewtype id pk, ParsePrimaryKey pk, ConvertibleStrings text Text) => text -> id textToId text = case parsePrimaryKey (cs text) of - Just id -> Id id + Just pk -> toId pk Nothing -> error (cs $ "Unable to convert " <> (cs text :: Text) <> " to Id value. Is it a valid uuid?") {-# INLINE textToId #-} @@ -928,13 +908,6 @@ didTouchField :: forall fieldName fieldValue record. (KnownSymbol fieldName, Has didTouchField field record = record.meta.touchedFields .&. fieldBit @fieldName @record /= 0 -instance (ToJSON (PrimaryKey a)) => ToJSON (Id' a) where - toJSON (Id a) = toJSON a - -instance (FromJSON (PrimaryKey a)) => FromJSON (Id' a) where - parseJSON value = Id <$> parseJSON value - - instance Default Aeson.Value where def = Aeson.Null diff --git a/ihp/IHP/ModelSupport/Types.hs b/ihp/IHP/ModelSupport/Types.hs index 69e0ffe50..d9a7869a4 100644 --- a/ihp/IHP/ModelSupport/Types.hs +++ b/ihp/IHP/ModelSupport/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts, AllowAmbiguousTypes, UndecidableInstances, FlexibleInstances, DataKinds, PolyKinds, TypeApplications, ScopedTypeVariables, ConstraintKinds, TypeOperators, GADTs, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts, AllowAmbiguousTypes, UndecidableInstances, FlexibleInstances, DataKinds, PolyKinds, TypeApplications, ScopedTypeVariables, ConstraintKinds, TypeOperators, GADTs, GeneralizedNewtypeDeriving, PatternSynonyms, ViewPatterns, FunctionalDependencies #-} {-| Module: IHP.ModelSupport.Types @@ -26,8 +26,11 @@ module IHP.ModelSupport.Types , Include' , NormalizeModel -- * Id Types -, Id'(..) +, Id' , Id +, pattern Id +, IdNewtype (..) +, GetTableForId -- * Record Metadata , MetaBag (..) , Violation (..) @@ -53,8 +56,6 @@ import Prelude import Data.ByteString (ByteString) import Data.Text (Text) import qualified Data.Text.Encoding -import Data.Hashable (Hashable) -import Control.DeepSeq (NFData) import Control.Exception (Exception) import Database.PostgreSQL.Simple.Types (Query) import qualified Database.PostgreSQL.Simple as PG @@ -97,8 +98,8 @@ data RowLevelSecurityContext = RowLevelSecurityContext } type family GetModelById id :: Type where - GetModelById (Maybe (Id' tableName)) = Maybe (GetModelByTableName tableName) - GetModelById (Id' tableName) = GetModelByTableName tableName + GetModelById (Maybe id) = Maybe (GetModelByTableName (GetTableForId id)) + GetModelById id = GetModelByTableName (GetTableForId id) type family GetTableName model :: Symbol type family GetModelByTableName (tableName :: Symbol) :: Type @@ -135,13 +136,32 @@ type family Include' (name :: [GHC.Types.Symbol]) model where -- Post type NormalizeModel model = GetModelByTableName (GetTableName model) -newtype Id' table = Id (PrimaryKey table) +-- | Maps a table name (type-level string) to its Id newtype. +-- Instances are generated by the schema compiler, e.g.: +-- +-- > type instance Id' "users" = UserId +-- +type family Id' (table :: Symbol) :: Type -deriving instance (Eq (PrimaryKey table)) => Eq (Id' table) -deriving instance (Ord (PrimaryKey table)) => Ord (Id' table) -deriving instance (Hashable (PrimaryKey table)) => Hashable (Id' table) -deriving instance (KnownSymbol table, Data (PrimaryKey table)) => Data (Id' table) -deriving instance (KnownSymbol table, NFData (PrimaryKey table)) => NFData (Id' table) +-- | Maps an Id newtype back to its table name. +-- Used by 'GetModelById' and 'Fetchable' to recover the table. +-- Instances are generated by the schema compiler, e.g.: +-- +-- > type instance GetTableForId UserId = "users" +-- +type family GetTableForId id :: Symbol + +-- | Typeclass connecting per-table Id newtypes to their underlying primary key type. +-- Enables the 'Id' pattern synonym to work across all Id types. +class IdNewtype id pk | id -> pk where + toId :: pk -> id + fromId :: id -> pk + +-- | Bidirectional pattern synonym that preserves all existing @Id@ constructor usage. +-- Construction: @Id someUUID@ calls 'toId' to wrap the value. +-- Pattern matching: @case x of Id pk -> ...@ calls 'fromId' to unwrap. +pattern Id :: IdNewtype id pk => pk -> id +pattern Id x <- (fromId -> x) where Id x = toId x -- | We need to map the model to its table name to prevent infinite recursion in the model data definition -- E.g. `type Project = Project' { id :: Id Project }` will not work diff --git a/ihp/IHP/PGSimpleCompat.hs b/ihp/IHP/PGSimpleCompat.hs index 9bd66baed..510342c18 100644 --- a/ihp/IHP/PGSimpleCompat.hs +++ b/ihp/IHP/PGSimpleCompat.hs @@ -17,28 +17,12 @@ import Database.PostgreSQL.Simple.FromField (FromField(..)) import Database.PostgreSQL.Simple.ToField (ToField(..), Action(..)) import qualified Database.PostgreSQL.Simple.FromRow as PGFR import qualified Database.PostgreSQL.Simple.Types as PG -import IHP.ModelSupport.Types (Id'(..), PrimaryKey, LabeledData(..), FieldWithDefault(..), FieldWithUpdate(..)) +import IHP.ModelSupport.Types (LabeledData(..), FieldWithDefault(..), FieldWithUpdate(..)) import IHP.NameSupport (fieldNameToColumnName) -- Import postgresql-simple-postgresql-types for FromField/ToField instances -- of all postgresql-types types (Point, Polygon, Inet, Interval, etc.) -import Database.PostgreSQL.Simple.PostgresqlTypes () - --- Id instances - -instance FromField (PrimaryKey model) => FromField (Id' model) where - {-# INLINE fromField #-} - fromField value metaData = do - fieldValue <- fromField value metaData - pure (Id fieldValue) - -instance ToField (PrimaryKey model) => ToField (Id' model) where - {-# INLINE toField #-} - toField (Id pk) = toField pk - -instance (ToField (Id' a), ToField (Id' b)) => ToField (Id' a, Id' b) where - {-# INLINE toField #-} - toField (a, b) = Many [Plain "(", toField a, Plain ",", toField b, Plain ")"] +-- import Database.PostgreSQL.Simple.PostgresqlTypes () -- TODO: re-enable when package is available in nix env -- LabeledData instance diff --git a/ihp/IHP/Prelude.hs b/ihp/IHP/Prelude.hs index 97c29ed9d..da39626f6 100644 --- a/ihp/IHP/Prelude.hs +++ b/ihp/IHP/Prelude.hs @@ -1,4 +1,5 @@ {-# OPTIONS_HADDOCK not-home, hide #-} +{-# LANGUAGE PatternSynonyms #-} module IHP.Prelude ( module CorePrelude , module Data.Text.IO @@ -71,7 +72,7 @@ import GHC.OverloadedLabels import Data.Data (Data) import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) import IHP.NameSupport -import IHP.ModelSupport (ModelContext (..), CanUpdate, NormalizeModel, Id, GetTableName, GetModelName, updateRecord, updateRecordDiscardResult, createRecord, deleteRecord, MetaBag (..), FieldBit (..)) +import IHP.ModelSupport (ModelContext (..), CanUpdate, NormalizeModel, Id, Id', pattern Id, IdNewtype(..), GetTableName, GetModelName, updateRecord, updateRecordDiscardResult, createRecord, deleteRecord, MetaBag (..), FieldBit (..)) import Data.TMap (TMap) import Data.IORef import Data.Time.Format diff --git a/ihp/IHP/QueryBuilder/Filter.hs b/ihp/IHP/QueryBuilder/Filter.hs index 5fecaa164..2c9742b5d 100644 --- a/ihp/IHP/QueryBuilder/Filter.hs +++ b/ihp/IHP/QueryBuilder/Filter.hs @@ -621,12 +621,12 @@ filterWhereCaseInsensitive (name, value) queryBuilderProvider = injectQueryBuild {-# INLINE filterWhereCaseInsensitive #-} -filterWhereIdIn :: forall table model queryBuilderProvider (joinRegister :: Type). (KnownSymbol table, Table model, model ~ GetModelByTableName table, HasQueryBuilder queryBuilderProvider joinRegister, DefaultParamEncoder [PrimaryKey (GetTableName model)]) => [Id model] -> queryBuilderProvider table -> queryBuilderProvider table +filterWhereIdIn :: forall table model queryBuilderProvider (joinRegister :: Type). (KnownSymbol table, Table model, model ~ GetModelByTableName table, HasQueryBuilder queryBuilderProvider joinRegister, DefaultParamEncoder [PrimaryKey table], IdNewtype (Id' table) (PrimaryKey table)) => [Id' table] -> queryBuilderProvider table -> queryBuilderProvider table filterWhereIdIn values queryBuilderProvider = -- We don't need to treat null values differently here, because primary keys imply not-null -- Extract the raw primary key values from the Id wrappers let - rawPrimaryKeys = map (\(Id pk) -> pk) values + rawPrimaryKeys = map fromId values condition = ColumnCondition (primaryKeyConditionColumnSelector @model) InOp (paramValue rawPrimaryKeys) Nothing Nothing in injectQueryBuilder $ addCondition condition (getQueryBuilder queryBuilderProvider) diff --git a/ihp/IHP/RouterPrelude.hs b/ihp/IHP/RouterPrelude.hs index 4eee874a3..1f638817c 100644 --- a/ihp/IHP/RouterPrelude.hs +++ b/ihp/IHP/RouterPrelude.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_HADDOCK not-home, hide #-} {-| Module: IHP.RouterPrelude @@ -18,5 +19,5 @@ import Data.Attoparsec.ByteString.Char8 import IHP.RouterSupport import ClassyPrelude hiding (index, delete, show, take, takeWhile, try) import Data.String.Conversions (cs) -import IHP.ModelSupport (Id, Id' (..)) +import IHP.ModelSupport (Id, Id', pattern Id, IdNewtype(..)) import Network.HTTP.Types.Method (StdMethod (..)) diff --git a/ihp/IHP/RouterSupport.hs b/ihp/IHP/RouterSupport.hs index 95cd33cfa..5c815a72b 100644 --- a/ihp/IHP/RouterSupport.hs +++ b/ihp/IHP/RouterSupport.hs @@ -961,7 +961,7 @@ parseUUID = do {-# INLINABLE parseUUID #-} -- | Parses an UUID, afterwards wraps it in an Id -parseId :: ((ModelSupport.PrimaryKey table) ~ UUID) => Parser (ModelSupport.Id' table) +parseId :: ((ModelSupport.PrimaryKey table) ~ UUID, ModelSupport.IdNewtype (ModelSupport.Id' table) UUID) => Parser (ModelSupport.Id' table) parseId = ModelSupport.Id <$> parseUUID {-# INLINABLE parseId #-} diff --git a/ihp/IHP/Test/Mocking.hs b/ihp/IHP/Test/Mocking.hs index 5d76e8479..6860b31e4 100644 --- a/ihp/IHP/Test/Mocking.hs +++ b/ihp/IHP/Test/Mocking.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE QuantifiedConstraints #-} @@ -18,7 +19,7 @@ import Wai.Request.Params.Middleware (Respond) import IHP.ControllerSupport (InitControllerContext, Controller, runActionWithNewContext) import IHP.FrameworkConfig (ConfigBuilder (..), FrameworkConfig (..), RootApplication (..)) import qualified IHP.FrameworkConfig as FrameworkConfig -import IHP.ModelSupport (createModelContext, withModelContext, Id') +import IHP.ModelSupport (createModelContext, withModelContext) import IHP.Prelude import IHP.Log.Types import IHP.Job.Types diff --git a/ihp/IHP/View/Form.hs b/ihp/IHP/View/Form.hs index c5a347282..c8b51a3ff 100644 --- a/ihp/IHP/View/Form.hs +++ b/ihp/IHP/View/Form.hs @@ -19,7 +19,7 @@ import IHP.Controller.Context import IHP.HSX.ConvertibleStrings () import IHP.HSX.QQ (hsx) import IHP.HSX.ToHtml -import IHP.ModelSupport (Id', InputValue, didTouchField, getModelName, inputValue, isNew) +import IHP.ModelSupport (InputValue, didTouchField, getModelName, inputValue, isNew) import IHP.Prelude import IHP.ValidationSupport import IHP.View.Classes () diff --git a/ihp/IHP/ViewSupport.hs b/ihp/IHP/ViewSupport.hs index 726e2757b..228c327f1 100644 --- a/ihp/IHP/ViewSupport.hs +++ b/ihp/IHP/ViewSupport.hs @@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-| Module: IHP.ViewSupport Description: Provides functions to be used in all views @@ -36,7 +37,6 @@ module IHP.ViewSupport import IHP.Prelude import qualified Text.Blaze.Html5 as Html5 import IHP.ControllerSupport -import IHP.ModelSupport import qualified Data.Aeson as JSON import qualified Data.Text as Text import qualified Data.Typeable as Typeable @@ -53,7 +53,6 @@ import qualified Data.Sequences as Sequences import qualified IHP.View.CSSFramework as CSSFramework () import IHP.View.Types import qualified IHP.FrameworkConfig as FrameworkConfig -import qualified IHP.HSX.Attribute as HSX import qualified Network.Wai.Middleware.AssetPath as AssetPath import IHP.ActionType (isActiveController) @@ -197,8 +196,9 @@ instance (T.TypeError (T.Text "‘fetch‘ or ‘query‘ can only be used insid fetch = error "unreachable" query = error "unreachable" -instance (T.TypeError (T.Text "Looks like you forgot to pass a " :<>: (T.ShowType (GetModelByTableName record)) :<>: T.Text " id to this data constructor.")) => Eq (Id' (record :: T.Symbol) -> controller) where - a == b = error "unreachable" +-- Note: The type error instance for (Id' record -> controller) was removed +-- because Id' is now a type family. Per-table Id newtypes (UserId, etc.) +-- provide clear error messages naturally. fromCSSFramework :: (?request :: Request, KnownSymbol field, HasField field CSSFramework (CSSFramework -> appliedFunction)) => Proxy field -> appliedFunction fromCSSFramework field = let cssFramework = theCSSFramework in (get field cssFramework) cssFramework @@ -224,8 +224,8 @@ liveReloadWebsocketUrl = ?request.frameworkConfig.ideBaseUrl |> Text.replace "http://" "ws://" |> Text.replace "https://" "wss://" -instance InputValue (PrimaryKey table) => HSX.ApplyAttribute (Id' table) where - applyAttribute attr attr' value h = HSX.applyAttribute attr attr' (inputValue value) h +-- Note: Per-table ApplyAttribute instances for Id newtypes (UserId, ProjectId, etc.) +-- are generated by the schema compiler in Generated.ActualTypes.PrimaryKeys. -- | Adds a cache buster to a asset path diff --git a/ihp/Test/Test/HasqlEncoderSpec.hs b/ihp/Test/Test/HasqlEncoderSpec.hs index bcfe6bb50..c5b7178aa 100644 --- a/ihp/Test/Test/HasqlEncoderSpec.hs +++ b/ihp/Test/Test/HasqlEncoderSpec.hs @@ -1,20 +1,48 @@ +{-# LANGUAGE DerivingStrategies, GeneralizedNewtypeDeriving #-} module Test.HasqlEncoderSpec where import Test.Hspec import IHP.Prelude import IHP.Hasql.Encoders (ToSnippetParams(..), sqlToSnippet) -import IHP.ModelSupport.Types (Id'(..), PrimaryKey) +import IHP.ModelSupport.Types (PrimaryKey) +import Test.ModelFixtures (UserId(..)) import qualified Hasql.DynamicStatements.Snippet as Snippet import Hasql.DynamicStatements.Snippet (Snippet) import qualified Hasql.Statement as Statement import qualified Hasql.Decoders as Decoders -import Hasql.Implicits.Encoders () +import Hasql.Implicits.Encoders (DefaultParamEncoder(..)) +import qualified Hasql.Encoders as Encoders import Database.PostgreSQL.Simple (Only(..), (:.)(..)) +import qualified Hasql.Mapping.IsScalar as Mapping +import Data.Functor.Contravariant (contramap) -- Test type family instances for non-UUID primary keys type instance PrimaryKey "countries" = Text type instance PrimaryKey "serial_table" = Int -type instance PrimaryKey "users" = UUID +-- Test Id newtypes (mirroring what the schema compiler generates) +newtype CountryId = CountryId Text + deriving newtype (Eq, Ord, Show, IsString, Mapping.IsScalar) +type instance Id' "countries" = CountryId +instance IdNewtype CountryId Text where + toId = CountryId + fromId (CountryId x) = x +instance DefaultParamEncoder CountryId where defaultParam = Encoders.nonNullable Mapping.encoder +instance DefaultParamEncoder (Maybe CountryId) where defaultParam = Encoders.nullable Mapping.encoder +instance DefaultParamEncoder [CountryId] where defaultParam = (Encoders.nonNullable . Encoders.array . Encoders.dimension foldl' . Encoders.element . Encoders.nonNullable) Mapping.encoder + +newtype SerialTableId = SerialTableId Int + deriving newtype (Eq, Ord, Show, Num, Mapping.IsScalar) +type instance Id' "serial_table" = SerialTableId +instance IdNewtype SerialTableId Int where + toId = SerialTableId + fromId (SerialTableId x) = x +instance DefaultParamEncoder SerialTableId where defaultParam = Encoders.nonNullable Mapping.encoder + +-- UserId for "users" table is imported from Test.ModelFixtures +instance Mapping.IsScalar UserId where + encoder = contramap fromId Mapping.encoder + decoder = toId <$> Mapping.decoder +instance DefaultParamEncoder UserId where defaultParam = Encoders.nonNullable Mapping.encoder -- | Convert a Snippet to its SQL text representation for testing. -- Parameters become $1, $2, etc. diff --git a/ihp/Test/Test/ModelFixtures.hs b/ihp/Test/Test/ModelFixtures.hs index 97229a63c..3451bac01 100644 --- a/ihp/Test/Test/ModelFixtures.hs +++ b/ihp/Test/Test/ModelFixtures.hs @@ -3,6 +3,8 @@ Module: Test.ModelFixtures Description: Shared model types for test specs Copyright: (c) digitally induced GmbH, 2020 -} +{-# LANGUAGE DerivingStrategies, GeneralizedNewtypeDeriving #-} + module Test.ModelFixtures where import IHP.Prelude @@ -10,6 +12,77 @@ import IHP.ModelSupport import IHP.Hasql.FromRow (FromRowHasql(..), HasqlDecodeColumn(..)) import IHP.Job.Types (JobStatus(..)) import IHP.Job.Queue () +import qualified IHP.HSX.Attribute as HSX + +-- | Per-table Id newtypes for test models. +-- These are shared across all test modules. + +newtype PostId = PostId UUID + deriving newtype (Eq, Ord, Show) +type instance Id' "posts" = PostId +instance IdNewtype PostId UUID where + toId = PostId + fromId (PostId x) = x +instance Default PostId where def = PostId def +instance IsString PostId where + fromString str = case parsePrimaryKey (cs str) of + Just pk -> PostId pk + Nothing -> error ("Unable to convert " <> show str <> " to PostId") + +newtype TagId = TagId UUID + deriving newtype (Eq, Ord, Show) +type instance Id' "tags" = TagId +instance IdNewtype TagId UUID where + toId = TagId + fromId (TagId x) = x +instance Default TagId where def = TagId def +instance IsString TagId where + fromString str = case parsePrimaryKey (cs str) of + Just pk -> TagId pk + Nothing -> error ("Unable to convert " <> show str <> " to TagId") + +newtype WeirdTagId = WeirdTagId UUID + deriving newtype (Eq, Ord, Show) +type instance Id' "weird_tags" = WeirdTagId +instance IdNewtype WeirdTagId UUID where + toId = WeirdTagId + fromId (WeirdTagId x) = x +instance Default WeirdTagId where def = WeirdTagId def +instance IsString WeirdTagId where + fromString str = case parsePrimaryKey (cs str) of + Just pk -> WeirdTagId pk + Nothing -> error ("Unable to convert " <> show str <> " to WeirdTagId") + +newtype TaggingId = TaggingId UUID + deriving newtype (Eq, Ord, Show) +type instance Id' "taggings" = TaggingId +instance IdNewtype TaggingId UUID where + toId = TaggingId + fromId (TaggingId x) = x +instance Default TaggingId where def = TaggingId def + +newtype UserId = UserId UUID + deriving newtype (Eq, Ord, Show) +type instance Id' "users" = UserId +instance IdNewtype UserId UUID where + toId = UserId + fromId (UserId x) = x +instance Default UserId where def = UserId def +instance InputValue UserId where inputValue (UserId x) = inputValue x +instance HSX.ApplyAttribute UserId where + applyAttribute attr attr' (UserId x) h = HSX.applyAttribute attr attr' (inputValue x) h +instance IsString UserId where + fromString str = case parsePrimaryKey (cs str) of + Just pk -> UserId pk + Nothing -> error ("Unable to convert " <> show str <> " to UserId") + +newtype BackgroundJobId = BackgroundJobId UUID + deriving newtype (Eq, Ord, Show) +type instance Id' "background_jobs" = BackgroundJobId +instance IdNewtype BackgroundJobId UUID where + toId = BackgroundJobId + fromId (BackgroundJobId x) = x +instance Default BackgroundJobId where def = BackgroundJobId def data Post = Post { id :: UUID @@ -86,7 +159,14 @@ data CompositeTagging = CompositeTagging type instance GetTableName CompositeTagging = "composite_taggings" type instance GetModelByTableName "composite_taggings" = CompositeTagging -type instance PrimaryKey "composite_taggings" = (Id' "posts", Id' "tags") +type instance PrimaryKey "composite_taggings" = (UUID, UUID) + +newtype CompositeTaggingPK = CompositeTaggingPK (UUID, UUID) + deriving newtype (Eq, Ord, Show) +type instance Id' "composite_taggings" = CompositeTaggingPK +instance IdNewtype CompositeTaggingPK (UUID, UUID) where + toId = CompositeTaggingPK + fromId (CompositeTaggingPK x) = x instance Table CompositeTagging where columnNames = ["post_id", "tag_id"] diff --git a/ihp/Test/Test/QueryBuilderSpec.hs b/ihp/Test/Test/QueryBuilderSpec.hs index d4f4b2283..41f06a4d8 100644 --- a/ihp/Test/Test/QueryBuilderSpec.hs +++ b/ihp/Test/Test/QueryBuilderSpec.hs @@ -7,7 +7,6 @@ module Test.QueryBuilderSpec where import Test.Hspec import IHP.Prelude import IHP.QueryBuilder -import IHP.ModelSupport import IHP.Job.Types (JobStatus(..)) import IHP.Job.Queue () import Test.ModelFixtures diff --git a/ihp/Test/Test/RouterSupportSpec.hs b/ihp/Test/Test/RouterSupportSpec.hs index 50a6ad7b3..0d2ce9fda 100644 --- a/ihp/Test/Test/RouterSupportSpec.hs +++ b/ihp/Test/Test/RouterSupportSpec.hs @@ -4,6 +4,8 @@ Module: Test.RouterSupportSpec Tests for typed auto routing. -} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Test.RouterSupportSpec where import ClassyPrelude @@ -19,6 +21,37 @@ import IHP.ControllerPrelude hiding (get, request) import Network.Wai.Test import Network.HTTP.Types +newtype BandId = BandId Integer + deriving newtype (Eq, Ord, Show, Num) + deriving stock (Data) +type instance Id' "bands" = BandId +instance IdNewtype BandId Integer where + toId = BandId + fromId (BandId x) = x +instance Default BandId where def = BandId 0 + +newtype PerformanceId = PerformanceId UUID + deriving newtype (Eq, Ord, Show) + deriving stock (Data) +type instance Id' "performances" = PerformanceId +instance IdNewtype PerformanceId UUID where + toId = PerformanceId + fromId (PerformanceId x) = x +instance Default PerformanceId where def = PerformanceId def +instance IsString PerformanceId where + fromString str = case parsePrimaryKey (cs str) of + Just pk -> PerformanceId pk + Nothing -> ClassyPrelude.error ("Unable to convert " <> ClassyPrelude.show str <> " to PerformanceId") + +newtype TextModelId = TextModelId Text + deriving newtype (Eq, Ord, Show, IsString) + deriving stock (Data) +type instance Id' "textModel" = TextModelId +instance IdNewtype TextModelId Text where + toId = TextModelId + fromId (TextModelId x) = x +instance Default TextModelId where def = TextModelId "" + data Band' = Band {id :: (Id' "bands"), meta :: MetaBag} deriving (Eq, Show) type Band = Band' type instance GetTableName (Band') = "bands" @@ -115,7 +148,7 @@ instance Controller CustomRouteController where instance AutoRoute CustomRouteController where customRoutes = do string "/performances/" - performanceId <- parseId + performanceId <- parseId @"performances" endOfInput onlyAllowMethods [GET, HEAD] pure ShowPerformanceAction { performanceId } diff --git a/ihp/Test/Test/View/FormSpec.hs b/ihp/Test/Test/View/FormSpec.hs index 58f82b643..d7a70a699 100644 --- a/ihp/Test/Test/View/FormSpec.hs +++ b/ihp/Test/Test/View/FormSpec.hs @@ -2,6 +2,9 @@ Module: Test.View.FormSpec Copyright: (c) digitally induced GmbH, 2022 -} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Test.View.FormSpec where import Test.Hspec @@ -16,6 +19,7 @@ import qualified Data.Text.Lazy as LT import qualified Data.Vault.Lazy as Vault import qualified IHP.RequestVault import qualified Data.TMap as TypeMap +import qualified IHP.HSX.Attribute as HSX tests = do @@ -93,7 +97,26 @@ createControllerContext = do let customFields = TypeMap.insert request TypeMap.empty pure FrozenControllerContext { customFields } -data Project' = Project {id :: (Id' "projects"), title :: Text, meta :: MetaBag} deriving (Eq, Show) +newtype ProjectId = ProjectId UUID + deriving newtype (Eq, Ord, Show) +type instance Id' "projects" = ProjectId +instance IdNewtype ProjectId UUID where + toId = ProjectId + fromId (ProjectId x) = x +instance Default ProjectId where def = ProjectId def +instance InputValue ProjectId where inputValue (ProjectId x) = inputValue x +instance HSX.ApplyAttribute ProjectId where + applyAttribute attr attr' (ProjectId x) h = HSX.applyAttribute attr attr' (inputValue x) h + +newtype EventId = EventId UUID + deriving newtype (Eq, Ord, Show) +type instance Id' "events" = EventId +instance IdNewtype EventId UUID where + toId = EventId + fromId (EventId x) = x +instance Default EventId where def = EventId def + +data Project' = Project {id :: (ProjectId), title :: Text, meta :: MetaBag} deriving (Eq, Show) instance InputValue Project where inputValue = IHP.ModelSupport.recordToInputValue type Project = Project' @@ -106,9 +129,8 @@ type instance PrimaryKey "projects" = UUID instance Record Project where {-# INLINE newRecord #-} newRecord = Project def def def -instance Default (Id' "projects") where def = Id def -instance SetField "id" (Project' ) (Id' "projects") where +instance SetField "id" (Project' ) (ProjectId) where {-# INLINE setField #-} setField newValue (Project id title meta) = Project newValue title (meta { touchedFields = touchedFields meta .|. 1 }) @@ -120,7 +142,7 @@ instance SetField "meta" (Project' ) MetaBag where {-# INLINE setField #-} setField newValue (Project id title meta) = Project id title newValue -instance UpdateField "id" (Project' ) (Project' ) (Id' "projects") (Id' "projects") where +instance UpdateField "id" (Project' ) (Project' ) (ProjectId) (ProjectId) where {-# INLINE updateField #-} updateField newValue (Project id title meta) = Project newValue title (meta { touchedFields = touchedFields meta .|. 1 }) instance UpdateField "title" (Project' ) (Project' ) Text Text where @@ -134,7 +156,7 @@ instance FieldBit "title" (Project' ) where fieldBit = 2 -- Event model for testing date fields data Event' = Event - { id :: (Id' "events") + { id :: (EventId) , date :: Maybe Day , createdAt :: Maybe UTCTime , meta :: MetaBag @@ -152,9 +174,8 @@ type instance PrimaryKey "events" = UUID instance Record Event where {-# INLINE newRecord #-} newRecord = Event def def def def -instance Default (Id' "events") where def = Id def -instance SetField "id" (Event' ) (Id' "events") where +instance SetField "id" (Event' ) (EventId) where {-# INLINE setField #-} setField newValue (Event id date createdAt meta) = Event newValue date createdAt (meta { touchedFields = touchedFields meta .|. 1 }) @@ -171,7 +192,7 @@ instance SetField "meta" (Event' ) MetaBag where setField newValue (Event id date createdAt meta) = Event id date createdAt newValue -instance UpdateField "id" (Event' ) (Event' ) (Id' "events") (Id' "events") where +instance UpdateField "id" (Event' ) (Event' ) (EventId) (EventId) where {-# INLINE updateField #-} updateField newValue (Event id date createdAt meta) = Event newValue date createdAt (meta { touchedFields = touchedFields meta .|. 1 }) instance UpdateField "date" (Event' ) (Event' ) (Maybe Day) (Maybe Day) where diff --git a/ihp/Test/Test/ViewSupportSpec.hs b/ihp/Test/Test/ViewSupportSpec.hs index cfc2e5ef7..bbd2e75b5 100644 --- a/ihp/Test/Test/ViewSupportSpec.hs +++ b/ihp/Test/Test/ViewSupportSpec.hs @@ -18,6 +18,7 @@ import IHP.ControllerPrelude hiding (get, request) import Network.Wai.Test import Network.HTTP.Types import Data.Text as Text +import Test.ModelFixtures () data WebApplication = WebApplication deriving (Eq, Show, Data)