Support for the migration framework in beam-duckdb (#812)

Author: LaurentRDC

beam-duckdb/CHANGELOG.md

@@ -2,6 +2,10 @@
 
 ## 0.3.1.0 -- unreleased
 
+* Added support for `beam-migrate`: the new `Database.Beam.DuckDB.Migrate`
+  module exposes a `migrationBackend :: BeamMigrationBackend DuckDB DuckDBM`
+  value, along with other utilities. This brings DuckDB on par with `beam-postgres`
+  and `beam-sqlite` for schema verification and migration script generation.
 * Added file-mode `COPY ... TO 'file'` / `COPY ... FROM 'file'` support
   via the new `MonadBeamCopyTo` / `MonadBeamCopyFrom` instances on
   `DuckDBM`. Smart constructors `copyToCSV` / `copyToParquet` /

beam-duckdb/beam-duckdb.cabal

@@ -36,9 +36,11 @@ common common
                  -Wredundant-constraints
                  -fhide-source-paths
                  -Wpartial-fields
+                 -Wunused-packages
 library
     import:           common
     exposed-modules:  Database.Beam.DuckDB
+                      Database.Beam.DuckDB.Migrate
     other-modules:    Database.Beam.DuckDB.Backend
                       Database.Beam.DuckDB.Connection
                       Database.Beam.DuckDB.Syntax
@@ -47,7 +49,8 @@ library
                       Database.Beam.DuckDB.Syntax.Extensions.Copy
                       Database.Beam.DuckDB.Syntax.Extensions.DataSource
                       Database.Beam.DuckDB.Syntax.Extensions.InsertOnConflict
-    build-depends:    base >=4.11 && <5
+    build-depends:    aeson >=1.0 && <2.3
+                    , base >=4.11 && <5
                     , beam-core >=0.11.1 && <0.12
                     , beam-migrate ^>=0.6
                     , bytestring >=0.10 && <0.13
@@ -56,6 +59,7 @@ library
                     , duckdb-simple (>=0.1.2 && <0.1.5) || (>=0.1.5.1 && <0.1.6)
                     , dlist >=0.8 && <1.1
                     , free >=4.12 && <5.3
+                    , hashable >=1.1 && <1.6
                     , scientific ^>=0.3
                     , text >=1.0 && <2.2
                     , time >=1.6 && <1.17
@@ -70,13 +74,16 @@ test-suite beam-duckdb-test
                       Database.Beam.DuckDB.Test.Extensions.DataSource
                       Database.Beam.DuckDB.Test.Extensions.InsertOnConflict
                       Database.Beam.DuckDB.Test.Extensions.Returning
+                      Database.Beam.DuckDB.Test.Migrate
                       Database.Beam.DuckDB.Test.Query
     type:             exitcode-stdio-1.0
     hs-source-dirs:   tests
     main-is:          Main.hs
     build-depends:    base >=4.11 && <5
                     , beam-core
                     , beam-duckdb
+                    , beam-migrate
+                    , bytestring
                     , duckdb-simple
                     , hedgehog
                     , tasty
@@ -85,3 +92,4 @@ test-suite beam-duckdb-test
                     , temporary
                     , text
                     , time
+                    , uuid-types

beam-duckdb/examples/ExamScores.hs

@@ -2,38 +2,39 @@
 {- cabal:
   build-depends: base >= 4, beam-core, beam-duckdb, duckdb-simple, time, text
 -}
-
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE ExplicitForAll #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module Main where
 
+import Data.Function
 import Data.Int
 import qualified Data.List.NonEmpty as NonEmpty
 import Data.Text (Text)
 import Data.Time
 import Database.Beam
 import Database.Beam.DuckDB
 import Database.DuckDB.Simple
-import Data.Function
 
 data ExamT f = Exam
   { _examId :: Columnar f Int32,
     _examName :: Columnar f Text,
     _examScore :: Columnar f Double,
     _examDate :: Columnar f Day
-  } deriving (Generic, Beamable)
+  }
+  deriving (Generic, Beamable)
 
 type Exam = ExamT Identity
 
 deriving instance Show (ExamT Identity)
+
 deriving instance Eq (ExamT Identity)
 
 instance Table ExamT where
@@ -42,7 +43,7 @@ instance Table ExamT where
   primaryKey = ExamKey <$> _examId
 
 data ScoresDB f = ScoresDB
-  { _scores :: f (DataSourceEntity ExamT) }
+  {_scores :: f (DataSourceEntity ExamT)}
   deriving (Generic)
 
 deriving instance Database DuckDB ScoresDB
@@ -63,11 +64,12 @@ scoresDb =
       }
 
 main = do
-  Just maxScore <- withConnection ":memory:"
-    $ \conn -> runBeamDuckDB conn
-      $ runSelectReturningOne
-        $ select
-          $ aggregate_
+  Just maxScore <- withConnection ":memory:" $
+    \conn ->
+      runBeamDuckDB conn $
+        runSelectReturningOne $
+          select $
+            aggregate_
               (max_ . _examScore)
               (allFromDataSource_ (_scores scoresDb))
 

beam-duckdb/src/Database/Beam/DuckDB/Backend.hs

@@ -17,6 +17,7 @@ import Data.Functor (($>), (<&>))
 import Data.Int (Int16, Int32, Int64, Int8)
 import Data.Scientific (Scientific, scientific)
 import Data.Text (Text)
+import qualified Data.Text as Text
 import Data.Time (Day, LocalTime, TimeOfDay, UTCTime)
 import Data.UUID.Types (UUID)
 import Data.Word (Word16, Word32, Word64, Word8)
@@ -42,6 +43,7 @@ import Database.Beam.DuckDB.Syntax.Builder
     parens,
   )
 import Database.Beam.DuckDB.Syntax.Extensions.Copy (DuckDBCopyFromSyntax, DuckDBCopyToSyntax)
+import Database.Beam.Migrate.SQL (BeamMigrateOnlySqlBackend)
 import Database.Beam.Query.SQL92 (buildSql92Query')
 import Database.Beam.Query.Types (HasQBuilder (..))
 import Database.DuckDB.Simple (Null)
@@ -53,6 +55,8 @@ type instance BeamSqlBackendSyntax DuckDB = DuckDBCommandSyntax
 
 instance BeamSqlBackend DuckDB
 
+instance BeamMigrateOnlySqlBackend DuckDB
+
 type instance BeamSqlBackendCopyToSyntax DuckDB = DuckDBCopyToSyntax
 
 type instance BeamSqlBackendCopyFromSyntax DuckDB = DuckDBCopyFromSyntax
@@ -109,6 +113,13 @@ instance FromBackendRow DuckDB Word64
 
 instance FromBackendRow DuckDB Text
 
+instance FromBackendRow DuckDB Char where
+  fromBackendRow = do
+    t <- fromBackendRow @DuckDB @Text
+    case Text.uncons t of
+      Just (c, _) -> pure c
+      Nothing -> fail "Need string of size one to parse Char"
+
 instance FromBackendRow DuckDB ByteString
 
 instance FromBackendRow DuckDB UUID

beam-duckdb/src/Database/Beam/DuckDB/Connection.hs

@@ -16,6 +16,7 @@ module Database.Beam.DuckDB.Connection
     runBeamDuckDB,
     runBeamDuckDBDebug,
     runBeamDuckDBDebugString,
+    liftIOWithHandle,
     BeamDuckDBParams (..),
     BeamDuckDBRow (..),
   )
@@ -88,6 +89,12 @@ runBeamDuckDBDebug debug conn action =
 runBeamDuckDBDebugString :: (String -> IO ()) -> Connection -> DuckDBM a -> IO a
 runBeamDuckDBDebugString debug = runBeamDuckDBDebug (debug . Text.unpack)
 
+-- | Run an IO action with access to the underlying DuckDB 'Connection'.
+-- This is mostly useful for migrate-backend implementors who need to issue
+-- raw queries against the connection.
+liftIOWithHandle :: (Connection -> IO a) -> DuckDBM a
+liftIOWithHandle f = DuckDBM $ ReaderT $ \(_, conn) -> f conn
+
 newtype BeamDuckDBParams = BeamDuckDBParams [SomeField]
 
 instance ToRow BeamDuckDBParams where