Remove MySQL, add PostgreSQL

Author: pbrisbin

dbmigrations.cabal

@@ -46,11 +46,6 @@ source-repository head
   type: git
   location: https://github.com/haskell-github-trust/dbmigrations
 
-flag mysql
-  description: Build the mysql executable (and tests) application
-  manual: False
-  default: False
-
 flag postgresql
   description: Build the postgresql executable (and tests) application
   manual: False
@@ -129,6 +124,49 @@ library
   if impl(ghc >= 8.10)
     ghc-options: -Wno-missing-safe-haskell-mode
 
+executable dbm-postgresql
+  main-is: Main.hs
+  other-modules:
+      Paths_dbmigrations
+  hs-source-dirs:
+      postgresql/app
+  default-extensions:
+      BangPatterns
+      DataKinds
+      DeriveAnyClass
+      DeriveFoldable
+      DeriveFunctor
+      DeriveGeneric
+      DeriveLift
+      DeriveTraversable
+      DerivingStrategies
+      FlexibleContexts
+      FlexibleInstances
+      GADTs
+      GeneralizedNewtypeDeriving
+      LambdaCase
+      MultiParamTypeClasses
+      NoImplicitPrelude
+      NoMonomorphismRestriction
+      OverloadedStrings
+      RankNTypes
+      ScopedTypeVariables
+      StandaloneDeriving
+      TypeApplications
+      TypeFamilies
+  ghc-options: -fwrite-ide-info -Weverything -Wno-all-missed-specialisations -Wno-missed-specialisations -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-safe -Wno-unsafe -threaded -rtsopts "-with-rtsopts=-N"
+  build-depends:
+      HDBC-postgresql
+    , base <5
+    , dbmigrations
+  default-language: GHC2021
+  if impl(ghc >= 9.2)
+    ghc-options: -Wno-missing-kind-signatures
+  if impl(ghc >= 8.10)
+    ghc-options: -Wno-missing-safe-haskell-mode
+  if !(flag(postgresql))
+    buildable: False
+
 executable dbm-sqlite
   main-is: Main.hs
   other-modules:
@@ -172,6 +210,52 @@ executable dbm-sqlite
   if !(flag(sqlite))
     buildable: False
 
+test-suite postgresql-spec
+  type: exitcode-stdio-1.0
+  main-is: Main.hs
+  other-modules:
+      Paths_dbmigrations
+  hs-source-dirs:
+      postgresql/tests
+  default-extensions:
+      BangPatterns
+      DataKinds
+      DeriveAnyClass
+      DeriveFoldable
+      DeriveFunctor
+      DeriveGeneric
+      DeriveLift
+      DeriveTraversable
+      DerivingStrategies
+      FlexibleContexts
+      FlexibleInstances
+      GADTs
+      GeneralizedNewtypeDeriving
+      LambdaCase
+      MultiParamTypeClasses
+      NoImplicitPrelude
+      NoMonomorphismRestriction
+      OverloadedStrings
+      RankNTypes
+      ScopedTypeVariables
+      StandaloneDeriving
+      TypeApplications
+      TypeFamilies
+  ghc-options: -fwrite-ide-info -Weverything -Wno-all-missed-specialisations -Wno-missed-specialisations -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-safe -Wno-unsafe -threaded -rtsopts "-with-rtsopts=-N"
+  build-depends:
+      HDBC
+    , HDBC-postgresql
+    , base <5
+    , dbmigrations
+    , hspec
+  default-language: GHC2021
+  if impl(ghc >= 9.2)
+    ghc-options: -Wno-missing-kind-signatures
+  if impl(ghc >= 8.10)
+    ghc-options: -Wno-missing-safe-haskell-mode
+  if !(flag(postgresql))
+    buildable: False
+
 test-suite spec
   type: exitcode-stdio-1.0
   main-is: Spec.hs

package.yaml

@@ -102,6 +102,28 @@ executables:
       - condition: ! "!(flag(sqlite))"
         buildable: false
 
+  # dbm-mysql:
+  #   source-dirs: mysql/app
+  #   ghc-options: -threaded -rtsopts "-with-rtsopts=-N"
+  #   main: Main.hs
+  #   dependencies:
+  #     - HDBC-mysql
+  #     - dbmigrations
+  #   when:
+  #     - condition: ! "!(flag(mysql))"
+  #       buildable: false
+
+  dbm-postgresql:
+    source-dirs: postgresql/app
+    ghc-options: -threaded -rtsopts "-with-rtsopts=-N"
+    main: Main.hs
+    dependencies:
+      - HDBC-postgresql
+      - dbmigrations
+    when:
+      - condition: ! "!(flag(postgresql))"
+        buildable: false
+
 tests:
   spec:
     source-dirs: tests
@@ -133,16 +155,42 @@ tests:
       - condition: ! "!(flag(sqlite))"
         buildable: false
 
+  # mysql-spec:
+  #   source-dirs: mysql/tests
+  #   ghc-options: -threaded -rtsopts "-with-rtsopts=-N"
+  #   main: Main.hs
+  #   dependencies:
+  #     - HDBC
+  #     - HDBC-mysql
+  #     - dbmigrations
+  #     - hspec
+  #   when:
+  #     - condition: ! "!(flag(mysql))"
+  #       buildable: false
+
+  postgresql-spec:
+    source-dirs: postgresql/tests
+    ghc-options: -threaded -rtsopts "-with-rtsopts=-N"
+    main: Main.hs
+    dependencies:
+      - HDBC
+      - HDBC-postgresql
+      - dbmigrations
+      - hspec
+    when:
+      - condition: ! "!(flag(postgresql))"
+        buildable: false
+
 flags:
   sqlite:
     description: Build the sqlite executable (and tests)
     manual: false
     default: false
 
-  mysql:
-    description: Build the mysql executable (and tests) application
-    manual: false
-    default: false
+  # mysql:
+  #   description: Build the mysql executable (and tests) application
+  #   manual: false
+  #   default: false
 
   postgresql:
     description: Build the postgresql executable (and tests) application

postgresql/app/Main.hs

@@ -0,0 +1,9 @@
+module Main (main) where
+
+import Prelude
+
+import Database.HDBC.PostgreSQL (connectPostgreSQL)
+import Moo.Main
+
+main :: IO ()
+main = hdbcMain connectPostgreSQL

postgresql/tests/Main.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE DerivingVia #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Main (main) where
+
+import Prelude
+
+import Data.Maybe (fromMaybe)
+import Database.HDBC (IConnection (disconnect))
+import Database.HDBC.PostgreSQL (Connection, connectPostgreSQL)
+import Database.Schema.Migrations.Backend.HDBC
+import Database.Schema.Migrations.Test.BackendTest hiding (spec)
+import Database.Schema.Migrations.Test.BackendTest qualified as BackendTest
+import System.Environment (lookupEnv)
+import Test.Hspec
+
+deriving via (HDBCConnection Connection) instance BackendConnection Connection
+
+main :: IO ()
+main = hspec $ before setupPostgreSQL $ after disconnect BackendTest.spec
+
+setupPostgreSQL :: IO Connection
+setupPostgreSQL = do
+  url <- fromMaybe defaultDatabaseURL <$> lookupEnv "DATABASE_URL"
+  conn <- connectPostgreSQL url
+  conn <$ dropTables conn
+
+defaultDatabaseURL :: String
+defaultDatabaseURL = "postgres://postgres:password@localhost:5432"

sqlite/app/Main.hs

@@ -1,25 +1,9 @@
 module Main (main) where
 
-import Prelude hiding (lookup)
+import Prelude
 
 import Database.HDBC.Sqlite3 (connectSqlite3)
-import Database.Schema.Migrations.Backend.HDBC (hdbcBackend)
-import Moo.Core
 import Moo.Main
-import System.Environment (getArgs)
-import System.Exit
 
 main :: IO ()
-main = do
-  args <- getArgs
-  (_, opts, _) <- procArgs args
-  loadedConf <- loadConfiguration $ _configFilePath opts
-  case loadedConf of
-    Left e -> putStrLn e >> exitFailure
-    Right conf -> do
-      let connectionString = _connectionString conf
-      connection <- connectSqlite3 connectionString
-      let
-        backend = hdbcBackend connection
-        parameters = makeParameters conf backend
-      mainWithParameters args parameters
+main = hdbcMain connectSqlite3

sqlite/tests/Main.hs

@@ -15,7 +15,7 @@ import Test.Hspec
 deriving via (HDBCConnection Connection) instance BackendConnection Connection
 
 main :: IO ()
-main =
-  hspec
-    . before (connectSqlite3 ":memory:")
-    $ after disconnect BackendTest.spec
+main = hspec $ before setupSQLite3 $ after disconnect BackendTest.spec
+
+setupSQLite3 :: IO Connection
+setupSQLite3 = connectSqlite3 ":memory:"

src/Database/Schema/Migrations/Backend.hs

@@ -1,11 +1,13 @@
 module Database.Schema.Migrations.Backend
   ( Backend (..)
   , rootMigrationName
+  , bootstrapIfNecessary
   )
 where
 
 import Prelude
 
+import Control.Monad (unless)
 import Data.Text (Text)
 import Database.Schema.Migrations.Migration (Migration (..))
 
@@ -16,9 +18,9 @@ rootMigrationName :: Text
 rootMigrationName = "root"
 
 -- | A Backend represents a database engine backend such as MySQL or
---  SQLite.  A Backend supplies relatively low-level functions for
+--  SQLite. A Backend supplies relatively low-level functions for
 --  inspecting the backend's state, applying migrations, and reverting
---  migrations.  A Backend also supplies the migration necessary to
+--  migrations. A Backend also supplies the migration necessary to
 --  "bootstrap" a backend so that it can track which migrations are
 --  installed.
 data Backend = Backend
@@ -67,3 +69,11 @@ data Backend = Backend
 
 instance Show Backend where
   show _ = "dbmigrations backend"
+
+bootstrapIfNecessary :: Backend -> IO ()
+bootstrapIfNecessary backend = do
+  x <- isBootstrapped backend
+
+  unless x $ do
+    bs <- getBootstrapMigration backend
+    applyMigration backend bs

src/Database/Schema/Migrations/Backend/HDBC.hs

@@ -6,14 +6,13 @@ where
 
 import Prelude
 
-import Control.Exception (catch)
 import Control.Monad (void)
+import Data.Foldable (traverse_)
 import Data.String.Conversions (cs)
 import Data.Text (Text)
 import Data.Time.Clock (getCurrentTime)
 import Database.HDBC
   ( IConnection (getTables, run, runRaw)
-  , SqlError
   , commit
   , disconnect
   , fromSql
@@ -83,9 +82,10 @@ newtype HDBCConnection a = HDBCConnection a
 
 instance IConnection a => BackendTest.BackendConnection (HDBCConnection a) where
   supportsTransactionalDDL = const True
-  makeBackend (HDBCConnection c) = hdbcBackend c
-  commit (HDBCConnection c) = commit c
   withTransaction (HDBCConnection c) transaction =
     withTransaction c (transaction . HDBCConnection)
   getTables (HDBCConnection c) = map cs <$> getTables c
-  catchAll (HDBCConnection _) act handler = act `catch` \(_ :: SqlError) -> handler
+  dropTables (HDBCConnection c) = do
+    ts <- getTables c
+    traverse_ (\t -> runRaw c (cs $ "DROP TABLE " <> t)) ts
+  makeBackend (HDBCConnection c) = hdbcBackend c