Escape table name to prevent SQL injection via optTableName option

.github/workflows/haskell-ci.yml

@@ -29,19 +29,19 @@ jobs:
     strategy:
       matrix:
         include:
-          - compiler: ghc-9.6.1
+          - compiler: ghc-9.6.3
             compilerKind: ghc
-            compilerVersion: 9.6.1
+            compilerVersion: 9.6.3
             setup-method: ghcup
             allow-failure: false
-          - compiler: ghc-9.4.4
+          - compiler: ghc-9.4.7
             compilerKind: ghc
-            compilerVersion: 9.4.4
+            compilerVersion: 9.4.7
             setup-method: ghcup
             allow-failure: false
-          - compiler: ghc-9.2.7
+          - compiler: ghc-9.2.8
             compilerKind: ghc
-            compilerVersion: 9.2.7
+            compilerVersion: 9.2.8
             setup-method: ghcup
             allow-failure: false
           - compiler: ghc-9.0.2
@@ -66,8 +66,9 @@ jobs:
           apt-get update
           apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 postgresql-client
           mkdir -p "$HOME/.ghcup/bin"
-          curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup"
+          curl -sL https://downloads.haskell.org/ghcup/0.1.19.5/x86_64-linux-ghcup-0.1.19.5 > "$HOME/.ghcup/bin/ghcup"
           chmod a+x "$HOME/.ghcup/bin/ghcup"
+          "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml;
           "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)
           "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
         env:
@@ -82,10 +83,12 @@ jobs:
           echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV"
           echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV"
           HCDIR=/opt/$HCKIND/$HCVER
-          HC=$HOME/.ghcup/bin/$HCKIND-$HCVER
+          HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER")
+          HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#')
+          HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#')
           echo "HC=$HC" >> "$GITHUB_ENV"
-          echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV"
-          echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV"
+          echo "HCPKG=$HCPKG" >> "$GITHUB_ENV"
+          echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV"
           echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV"
           HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
           echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"

postgresql-migration.cabal

@@ -12,9 +12,9 @@ copyright:                  2014-2021, Andreas Meingast
 category:                   Database
 build-type:                 Simple
 description:                A PostgreSQL-simple schema migration utility
-tested-with:                GHC==9.6.1
-                            GHC==9.4.4
-                            GHC==9.2.7
+tested-with:                GHC==9.6.3
+                            GHC==9.4.7
+                            GHC==9.2.8
                             GHC==9.0.2
                             GHC==8.8.4
                             GHC==8.6.5

src/Database/PostgreSQL/Simple/Migration.hs

@@ -62,7 +62,7 @@ import           Database.PostgreSQL.Simple ( Connection
 import           Database.PostgreSQL.Simple.FromRow (FromRow (..), field)
 import           Database.PostgreSQL.Simple.ToField (ToField (..))
 import           Database.PostgreSQL.Simple.ToRow (ToRow (..))
-import           Database.PostgreSQL.Simple.Types (Query (..))
+import           Database.PostgreSQL.Simple.Types (Query (..), Identifier)
 import           Database.PostgreSQL.Simple.Util (existsTable)
 import           System.Directory (listDirectory)
 import           System.FilePath ((</>))
@@ -176,22 +176,24 @@ executeMigration con opts name contents = doStepTransaction opts con $ do
       when (verbose opts) $ optLogWriter opts $ Right ("Executing:\t" <> fromString name)
       void $ execute_ con (Query contents)
       when (verbose opts) $ optLogWriter opts $ Right ("Adding '" <> fromString name <> "' to schema_migrations with checksum '" <> fromString (show checksum) <> "'")
-      void $ execute con q (name, checksum)
+      void $ execute con q (migrationsTableName opts, name, checksum)
       when (verbose opts) $ optLogWriter opts $ Right ("Executed:\t" <> fromString name)
       pure MigrationSuccess
     ScriptModified eva -> do
       when (verbose opts) $ optLogWriter opts $ Left ("Fail:\t" <> fromString name <> "\n" <> scriptModifiedErrorMessage eva)
       pure (MigrationError name)
   where
-    q = "insert into " <> Query (optTableName opts) <> "(filename, checksum) values(?, ?)"
+    q = "insert into ? (filename, checksum) values(?, ?)"
 
 -- | Initializes the database schema with a helper table containing
 -- meta-information about executed migrations.
 initializeSchema :: Connection -> MigrationOptions -> IO ()
 initializeSchema con opts = do
   when (verbose opts) $ optLogWriter opts $ Right "Initializing schema"
-  void . doStepTransaction opts con . execute_ con $ mconcat
-      [ "create table if not exists " <> Query (optTableName opts) <> " "
+  void . doStepTransaction opts con $ execute con q (Only $ migrationsTableName opts)
+  where
+    q = mconcat
+      [ "create table if not exists ? "
       , "( filename varchar(512) not null"
       , ", checksum varchar(32) not null"
       , ", executed_at timestamp without time zone not null default now() "
@@ -252,7 +254,7 @@ executeValidation con opts cmd = doStepTransaction opts con $
 -- will be executed and its meta-information will be recorded.
 checkScript :: Connection -> MigrationOptions -> ScriptName -> Checksum -> IO CheckScriptResult
 checkScript con opts name fileChecksum =
-  query con q (Only name) >>= \case
+  query con q (migrationsTableName opts, name) >>= \case
     [] ->
       pure ScriptNotExecuted
     Only dbChecksum:_ | fileChecksum == dbChecksum ->
@@ -261,7 +263,7 @@ checkScript con opts name fileChecksum =
       pure $ ScriptModified (ExpectedVsActual {evaExpected = dbChecksum, evaActual = fileChecksum})
   where
     q = mconcat
-        [ "select checksum from " <> Query (optTableName opts) <> " "
+        [ "select checksum from ? "
         , "where filename = ? limit 1"
         ]
 
@@ -373,6 +375,11 @@ defaultOptions =
     , optTransactionControl = TransactionPerRun
     }
 
+-- Wrap the name of the table that stores migrations into Identifier,
+-- to ensure it's properly escaped (prevent SQL injection via optTableName)
+migrationsTableName :: MigrationOptions -> Identifier
+migrationsTableName = fromString . BS8.unpack . optTableName
+
 verbose :: MigrationOptions -> Bool
 verbose o = optVerbose o == Verbose
 

stack.yaml

@@ -17,7 +17,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: lts-20.21
+resolver: lts-20.26
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.

stack.yaml.lock

@@ -6,7 +6,7 @@
 packages: []
 snapshots:
 - completed:
-    sha256: 401a0e813162ba62f04517f60c7d25e93a0f867f94a902421ebf07d1fb5a8c46
-    size: 650044
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/21.yaml
-  original: lts-20.21
+    sha256: 5a59b2a405b3aba3c00188453be172b85893cab8ebc352b1ef58b0eae5d248a2
+    size: 650475
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/26.yaml
+  original: lts-20.26

test/Database/PostgreSQL/Simple/TransactionPerStepTest.hs

@@ -13,6 +13,7 @@
 
 module Database.PostgreSQL.Simple.TransactionPerStepTest where
 
+import           Data.Foldable                        (traverse_)
 import           Database.PostgreSQL.Simple           (Connection, execute_)
 import           Database.PostgreSQL.Simple.Migration (MigrationCommand (..),
                                                        MigrationOptions (..),
@@ -22,7 +23,7 @@ import           Database.PostgreSQL.Simple.Migration (MigrationCommand (..),
                                                        runMigrations,
                                                        defaultOptions)
 import           Database.PostgreSQL.Simple.Util      (existsTable)
-import           Test.Hspec                           (Spec, describe, it, shouldBe, shouldThrow, anyException, afterAll_)
+import           Test.Hspec                           (Spec, describe, it, shouldBe, shouldThrow, shouldReturn, anyException, afterAll_)
 
 migrationSpec :: Connection -> Spec
 migrationSpec con = afterAll_ cleanup $ describe "Migrations" $ do
@@ -61,15 +62,19 @@ migrationSpec con = afterAll_ cleanup $ describe "Migrations" $ do
     r <- existsTable con "trn2"
     r `shouldBe` True
 
+  it "does not allow SQL injection via table name option" $ do
+    let opts = defaultOptions{optTableName = "tricked_you (gotcha int); --"}
+    runMigrations con opts [MigrationInitialization] `shouldReturn` MigrationSuccess
+    existsTable con "tricked_you" `shouldReturn` False
+    existsTable con "tricked_you (gotcha int); --" `shouldReturn` True
 
   where
     runMigration' =
       runMigration con defaultOptions{optTransactionControl = NoNewTransaction}
 
-    -- Cleanup
-    cleanup = do
-      _ <- execute_ con "drop table if exists trn2"
-      _ <- execute_ con "drop table if exists schema_migrations"
-      pure ()
-
-
+    cleanup =
+      traverse_ (execute_ con)
+        [ "drop table if exists trn2"
+        , "drop table if exists schema_migrations"
+        , "drop table if exists \"tricked_you (gotcha int); --\""
+        ]