Merge branch 'develop' into cg/pre-post-hooks

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.

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

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

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

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

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:
 ---

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
 
 --

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)
 

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

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,13 +185,23 @@ data PgDataType
   | PgUuid
   | PgEnumeration EnumerationName
   | PgOid
+  | PgLTree
+  | PgVector (Maybe Natural)
 
 deriving instance Show PgDataType
 
 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