diff --git a/CHANGELOG.md b/CHANGELOG.md index 7aac401..97cf97d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -13,6 +13,21 @@ * Many instances of database entities being dropped and recreated instead of altered are now supported. * [#47](https://github.com/obsidiansystems/beam-automigrate/pull/47): Generate postgres enum types in schema when using `Nullable PgEnum` values. +## 0.1.6.0 + +* Fix instance HasSchemaConstraints build failure with GHC 9.2.8 + +## 0.1.5.0 + +* Add ltree column type +* Add vector column type +* Fix ghc 9.2.8 build + +## 0.1.4.0 + +* [#52](https://github.com/obsidiansystems/beam-automigrate/pull/52) Support sql arrays +* Loosen some version bounds + ## 0.1.3.0 * [#47](https://github.com/obsidiansystems/beam-automigrate/pull/47): Generate postgres enum types in schema when using `Nullable PgEnum` values. diff --git a/README.md b/README.md index 7f3df36..f3412b7 100644 --- a/README.md +++ b/README.md @@ -270,7 +270,7 @@ something like this: > > exampleAutoMigration :: Connection -> IO () > exampleAutoMigration conn = -> BA.tryRunMigrationsWithEditUpdate Prelude.id annotatedDB conn +> BA.tryRunMigrationsWithEditUpdate Prelude.id hsSchema conn > > main :: IO () > main = do diff --git a/beam-automigrate.cabal b/beam-automigrate.cabal index 6e3bfba..f25de21 100644 --- a/beam-automigrate.cabal +++ b/beam-automigrate.cabal @@ -1,5 +1,5 @@ name: beam-automigrate -version: 0.1.3.0 +version: 0.1.6.0 license-file: LICENSE build-type: Simple cabal-version: 2.0 @@ -43,7 +43,7 @@ library build-depends: aeson >=1.4.4 && <2.2 , base >=4.9 && <5 - , beam-core >=0.9 && <0.10 + , beam-core >=0.9 && <0.11 , beam-postgres >=0.5 && <0.6 , bytestring >=0.10.8.2 && <0.12.0.0 , containers >=0.5.9.2 && <0.8.0.0 @@ -129,7 +129,7 @@ executable beam-automigrate-integration-tests , beam-postgres , containers , postgresql-simple - , postgresql-syntax >= 0.4 && <0.5 + , postgresql-syntax >= 0.3 && <0.5 , pretty-simple , QuickCheck , tasty diff --git a/cabal.project b/cabal.project index e6fdbad..b0bc288 100644 --- a/cabal.project +++ b/cabal.project @@ -1 +1,20 @@ packages: . + +source-repository-package + type: git + location: https://github.com/obsidiansystems/beam.git + -- branch dylang/sql-deconstruct-maybe + tag: 9b6bf4f846869223737131999ceec16e8eb79ef8 + subdir: + beam-core + beam-postgres + beam-migrate + +source-repository-package + type: git + location: https://github.com/obsidiansystems/postgresql-simple.git + -- branch dylang/synthesizable-fields-2 + tag: 2a3e5210f87628eaa5d7a51d17211e84a5acd13b + +allow-older: + postgresql-simple diff --git a/src/Database/Beam/AutoMigrate.hs b/src/Database/Beam/AutoMigrate.hs index 8b3eccf..8fb592f 100644 --- a/src/Database/Beam/AutoMigrate.hs +++ b/src/Database/Beam/AutoMigrate.hs @@ -677,6 +677,15 @@ renderDataType = \case PgSpecificType (PgEnumeration (EnumerationName ty)) -> ty -- oid PgSpecificType PgOid -> "oid" + -- ltree + PgSpecificType PgLTree -> "ltree" + -- vector + PgSpecificType (PgVector Nothing) -> "vector" + PgSpecificType (PgVector (Just n)) -> mconcat ["vector(", T.pack . show $ n, ")"] + -- Arrays + SqlArrayType (SqlArrayType _ _) _ -> error "beam-automigrate: invalid nested array." + SqlArrayType _ 0 -> error "beam-automigrate: array with zero dimensions" + SqlArrayType t d -> renderDataType t <> mconcat (replicate (fromIntegral d) "[]") evalMigration :: Monad m => Migration m -> m (Either MigrationError [WithPriority Edit]) evalMigration m = do diff --git a/src/Database/Beam/AutoMigrate/Compat.hs b/src/Database/Beam/AutoMigrate/Compat.hs index 664e9a6..374f0d5 100644 --- a/src/Database/Beam/AutoMigrate/Compat.hs +++ b/src/Database/Beam/AutoMigrate/Compat.hs @@ -18,6 +18,7 @@ import Data.Time (LocalTime, TimeOfDay, UTCTime) import Data.Time.Calendar (Day) import Data.Typeable import Data.UUID +import Data.Vector (Vector) import Data.Word import qualified Database.Beam as Beam import Database.Beam.AutoMigrate.Types @@ -81,7 +82,8 @@ instance HasSchemaConstraints' 'False (Beam.TableField e t) where instance ( IsMaybe a ~ nullary, - HasSchemaConstraints' nullary a + HasSchemaConstraints' nullary a, + Ord (SchemaConstraint a) ) => HasSchemaConstraints a where @@ -241,6 +243,15 @@ instance HasColumnType (Pg.PgRange Pg.PgTsTzRange a) where instance HasColumnType (Pg.PgRange Pg.PgDateRange a) where defaultColumnType _ = PgSpecificType PgRangeDate +-- +-- support for arrays +-- + +instance HasColumnType a => HasColumnType (Vector a) where + defaultColumnType _ = case defaultColumnType (Proxy @a) of + SqlArrayType t d -> SqlArrayType t (d + 1) + t -> SqlArrayType t 1 + -- -- Support for 'SqlSerial'. \"SERIAL\" is treated by Postgres as syntactic sugar for: --- diff --git a/src/Database/Beam/AutoMigrate/Diff.hs b/src/Database/Beam/AutoMigrate/Diff.hs index ee88b10..49f4862 100644 --- a/src/Database/Beam/AutoMigrate/Diff.hs +++ b/src/Database/Beam/AutoMigrate/Diff.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ImportQualifiedPost #-} module Database.Beam.AutoMigrate.Diff ( Diffable (..), @@ -21,23 +22,25 @@ module Database.Beam.AutoMigrate.Diff ) where -import Control.Monad.Writer.Strict -import Control.Monad.State.Strict import Control.Applicative ((<|>)) -import Control.Lens (preview, ifoldMap, ifor, at, (.=), ix, (<<.=)) import Control.Exception (assert) +import Control.Lens (preview, ifoldMap, ifor, at, (.=), ix, (<<.=)) +import Control.Monad +import Control.Monad.State.Strict +import Control.Monad.Writer.Strict import Data.DList (DList) -import qualified Data.DList as D +import Data.DList qualified as D import Data.Foldable (foldlM, toList) +import Data.Function (on) import Data.List ((\\)) -import qualified Data.List as L +import Data.List qualified as L import Data.Map.Merge.Strict -import qualified Data.Map.Strict as M -import Data.Function (on) +import Data.Map.Strict qualified as M import Data.Maybe -import qualified Data.Set as S +import Data.Set qualified as S import Data.Text (Text) import Data.Word (Word8) + import Database.Beam.AutoMigrate.Types -- diff --git a/src/Database/Beam/AutoMigrate/Generic.hs b/src/Database/Beam/AutoMigrate/Generic.hs index a860761..aa04648 100644 --- a/src/Database/Beam/AutoMigrate/Generic.hs +++ b/src/Database/Beam/AutoMigrate/Generic.hs @@ -163,7 +163,7 @@ mkTableEntryNoFkDiscovery annEntity = let entity = annEntity ^. deannotate tName = entity ^. dbEntityDescriptor . dbEntityName pks = noTableConstraints {primaryKeyConstraint = Just (PrimaryKey $ S.fromList $ pkFieldNames entity, def)} -- TODO: expose default? - (columns, seqs) = gColumns (Proxy @ 'GenSequences) (TableName tName) . from $ dbAnnotatedSchema (annEntity ^. annotatedDescriptor) + (columns, seqs) = gColumns (Proxy @'GenSequences) (TableName tName) . from $ dbAnnotatedSchema (annEntity ^. annotatedDescriptor) annotatedCons = dbAnnotatedConstraints (annEntity ^. annotatedDescriptor) in ((TableName tName, Table (pks <> annotatedCons) columns), seqs) diff --git a/src/Database/Beam/AutoMigrate/Postgres.hs b/src/Database/Beam/AutoMigrate/Postgres.hs index 3673bfd..2ebe202 100644 --- a/src/Database/Beam/AutoMigrate/Postgres.hs +++ b/src/Database/Beam/AutoMigrate/Postgres.hs @@ -132,7 +132,7 @@ tableColumnsQ :: Pg.Query tableColumnsQ = fromString $ unlines - [ "SELECT attname, atttypid, atttypmod, attnotnull, pg_catalog.format_type(atttypid, atttypmod) ", + [ "SELECT attname, atttypid, atttypmod, attndims, attnotnull, pg_catalog.format_type(atttypid, atttypmod) ", "FROM pg_catalog.pg_attribute att ", "WHERE att.attrelid=? AND att.attnum>0 AND att.attisdropped='f' " ] @@ -236,17 +236,39 @@ referenceActionsQ = "WHERE sch_child.nspname = current_schema() ORDER BY c.conname " ] +-- | Return the names and OIDs of all user defined types in the public namespace +-- +-- This lets us work with types that come from extensions, regardless of when the extension is added. +-- Without this, the OIDs of these types could shift underneath us. +extensionTypeNamesQ :: Pg.Query +extensionTypeNamesQ = + fromString $ + unlines + [ "SELECT ty.oid, ty.typname ", + "FROM pg_type ty ", + "INNER JOIN pg_namespace ns ON ty.typnamespace = ns.oid ", + "WHERE ns.nspname = 'public' AND ty.typcategory = 'U' " + ] + -- | Connects to a running PostgreSQL database and extract the relevant 'Schema' out of it. getSchema :: Pg.Connection -> IO Schema getSchema conn = do allTableConstraints <- getAllConstraints conn allDefaults <- getAllDefaults conn + extensionTypeData <- Pg.fold_ conn extensionTypeNamesQ mempty getExtension enumerationData <- Pg.fold_ conn enumerationsQ mempty getEnumeration sequences <- Pg.fold_ conn sequencesQ mempty getSequence tables <- - Pg.fold_ conn userTablesQ mempty (getTable allDefaults enumerationData allTableConstraints) + Pg.fold_ conn userTablesQ mempty (getTable allDefaults extensionTypeData enumerationData allTableConstraints) pure $ Schema tables (M.fromList $ M.elems enumerationData) sequences where + getExtension :: + Map Pg.Oid ExtensionTypeName -> + (Pg.Oid, Text) -> + IO (Map Pg.Oid ExtensionTypeName) + getExtension allExtensions (oid, name) = + pure $ M.insert oid (ExtensionTypeName name) allExtensions + getEnumeration :: Map Pg.Oid (EnumerationName, Enumeration) -> (Text, Pg.Oid, V.Vector Text) -> @@ -264,26 +286,28 @@ getSchema conn = do getTable :: AllDefaults -> + Map Pg.Oid ExtensionTypeName -> Map Pg.Oid (EnumerationName, Enumeration) -> AllTableConstraints -> Tables -> (Pg.Oid, Text) -> IO Tables - getTable allDefaults enumData allTableConstraints allTables (oid, TableName -> tName) = do + getTable allDefaults extensionTypeData enumData allTableConstraints allTables (oid, TableName -> tName) = do pgColumns <- Pg.query conn tableColumnsQ (Pg.Only oid) newTable <- Table (fromMaybe noTableConstraints (M.lookup tName allTableConstraints)) - <$> foldlM (getColumns tName enumData allDefaults) mempty pgColumns + <$> foldlM (getColumns tName extensionTypeData enumData allDefaults) mempty pgColumns pure $ M.insert tName newTable allTables getColumns :: TableName -> + Map Pg.Oid ExtensionTypeName -> Map Pg.Oid (EnumerationName, Enumeration) -> AllDefaults -> Columns -> - (ByteString, Pg.Oid, Int, Bool, ByteString) -> + (ByteString, Pg.Oid, Int, Int, Bool, ByteString) -> IO Columns - getColumns tName enumData defaultData c (attname, atttypid, atttypmod, attnotnull, format_type) = do + getColumns tName extensionTypeData enumData defaultData c (attname, atttypid, atttypmod, attndims, attnotnull, format_type) = do -- /NOTA BENE(adn)/: The atttypmod - 4 was originally taken from 'beam-migrate' -- (see: https://github.com/tathougies/beam/blob/d87120b58373df53f075d92ce12037a98ca709ab/beam-postgres/Database/Beam/Postgres/Migrate.hs#L343) -- but there are cases where this is not correct, for example in the case of bitstrings. @@ -302,8 +326,9 @@ getSchema conn = do M.lookup columnName x case asum - [ pgTypeToColumnType atttypid mbPrecision, - pgEnumTypeToColumnType enumData atttypid + [ pgTypeToColumnType extensionTypeData atttypid mbPrecision, + pgEnumTypeToColumnType enumData atttypid, + pgArrayTypeToColumnType extensionTypeData atttypid mbPrecision attndims ] of Just cType -> do let nullConstraint = if attnotnull then NotNull else Null @@ -330,8 +355,8 @@ pgEnumTypeToColumnType enumData oid = -- | Tries to convert from a Postgres' 'Oid' into 'ColumnType'. -- Mostly taken from [beam-migrate](Database.Beam.Postgres.Migrate). -pgTypeToColumnType :: Pg.Oid -> Maybe Int -> Maybe ColumnType -pgTypeToColumnType oid width +pgTypeToColumnType :: Map Pg.Oid ExtensionTypeName -> Pg.Oid -> Maybe Int -> Maybe ColumnType +pgTypeToColumnType extensionTypeData oid width | Pg.typoid Pg.int2 == oid = Just (SqlStdType smallIntType) | Pg.typoid Pg.int4 == oid = @@ -396,8 +421,18 @@ pgTypeToColumnType oid width Just (PgSpecificType PgUuid) | Pg.typoid Pg.oid == oid = Just (PgSpecificType PgOid) - | otherwise = - Nothing + | M.lookup oid extensionTypeData == Just "ltree" = + Just (PgSpecificType PgLTree) + | M.lookup oid extensionTypeData == Just "vector" = + Just (PgSpecificType . PgVector $ (+ 4) . fromIntegral <$> width) + | otherwise = Nothing + +pgArrayTypeToColumnType :: Map Pg.Oid ExtensionTypeName -> Pg.Oid -> Maybe Int -> Int -> Maybe ColumnType +pgArrayTypeToColumnType extensionTypeData oid width dims = case Pg.staticTypeInfo oid of + Just (Pg.Array _ _ _ _ subTypeInfo) -> case pgTypeToColumnType extensionTypeData (Pg.typoid subTypeInfo) width of + Just columnType -> Just $ SqlArrayType columnType (fromIntegral dims) + _ -> Nothing + _ -> Nothing -- -- Constraints discovery diff --git a/src/Database/Beam/AutoMigrate/Types.hs b/src/Database/Beam/AutoMigrate/Types.hs index 2533a2d..2093c5b 100644 --- a/src/Database/Beam/AutoMigrate/Types.hs +++ b/src/Database/Beam/AutoMigrate/Types.hs @@ -2,35 +2,36 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} module Database.Beam.AutoMigrate.Types where -import Control.DeepSeq import Control.Applicative +import Control.DeepSeq import Control.Exception +import Control.Lens (Lens', lens, to, _Right) +import Control.Lens (preview, set) +import Control.Lens.TH import Data.ByteString.Lazy (ByteString) import Data.Default.Class (Default(..)) import Data.Map (Map) +import Data.Map qualified as Map import Data.Maybe (fromMaybe) import Data.Set (Set) import Data.String import Data.String.Conv (toS) import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Map as Map +import Data.Text qualified as T import Data.Typeable import Database.Beam.Backend.SQL (BeamSqlBackendSyntax) -import qualified Database.Beam.Backend.SQL.AST as AST +import Database.Beam.Backend.SQL.AST qualified as AST import Database.Beam.Postgres (Pg, Postgres) -import qualified Database.Beam.Postgres.Syntax as Syntax +import Database.Beam.Postgres.Syntax qualified as Syntax import GHC.Generics hiding (to) -import Control.Lens (Lens', lens, to, _Right) -import Control.Lens (preview, set) - -import Control.Lens.TH +import Numeric.Natural (Natural) -- -- Types (sketched) @@ -138,14 +139,14 @@ instance IsString ColumnName where fromString = ColumnName . T.pack data NullableConstraint = Null | NotNull - deriving (Show, Eq, Generic) + deriving (Show, Eq, Ord, Generic) instance NFData NullableConstraint data ColumnConstraints = ColumnConstraints { columnNullable :: NullableConstraint, columnDefault :: Maybe DefaultConstraint - } deriving (Show, Eq, Generic) + } deriving (Show, Eq, Ord, Generic) instance NFData ColumnConstraints @@ -168,6 +169,8 @@ data ColumnType PgSpecificType PgDataType | -- | An enumeration implemented with text-based encoding. DbEnumeration EnumerationName Enumeration + | -- | Array type. + SqlArrayType ColumnType Word deriving (Show, Eq, Generic) data PgDataType @@ -182,6 +185,8 @@ data PgDataType | PgUuid | PgEnumeration EnumerationName | PgOid + | PgLTree + | PgVector (Maybe Natural) deriving instance Show PgDataType @@ -189,6 +194,14 @@ deriving instance Eq PgDataType deriving instance Generic PgDataType +newtype ExtensionTypeName = ExtensionTypeName + { extensionTypeName :: Text + } + deriving (Show, Eq, Ord, NFData, Generic) + +instance IsString ExtensionTypeName where + fromString = ExtensionTypeName . T.pack + -- Newtype wrapper to be able to derive appropriate 'HasDefaultSqlDataType' for /Postgres/ enum types. newtype PgEnum a = PgEnum a diff --git a/src/Database/Beam/AutoMigrate/Util.hs b/src/Database/Beam/AutoMigrate/Util.hs index fb3b3bb..03f5781 100644 --- a/src/Database/Beam/AutoMigrate/Util.hs +++ b/src/Database/Beam/AutoMigrate/Util.hs @@ -1,21 +1,23 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ImportQualifiedPost #-} module Database.Beam.AutoMigrate.Util where import Control.Applicative.Lift +import Control.Lens ((^.)) import Control.Monad.Except import Data.Char import Data.Functor.Constant import Data.Set (Set) -import qualified Data.Set as Set +import Data.Set qualified as Set import Data.String (fromString) import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T + import Database.Beam.AutoMigrate.Types (ColumnName(..), TableName(..)) -import qualified Database.Beam.Schema as Beam +import Database.Beam.Schema qualified as Beam import Database.Beam.Schema.Tables -import Control.Lens ((^.)) -- -- Retrieving all the column names for a beam entity.