From 6d63c627758a430c17f373d9a1eaa98aa1008742 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= <honza.hrk@gmail.com>
Date: Wed, 4 Oct 2023 17:04:50 +0200
Subject: [PATCH 1/4] Fix SQL injection vulnerability

---
 .github/workflows/haskell-ci.yml            | 25 ++++++++++++---------
 postgresql-migration.cabal                  |  6 ++---
 src/Database/PostgreSQL/Simple/Migration.hs | 23 ++++++++++++-------
 src/Database/PostgreSQL/Simple/Util.hs      |  3 ++-
 stack.yaml                                  |  2 +-
 stack.yaml.lock                             |  8 +++----
 6 files changed, 39 insertions(+), 28 deletions(-)

diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml
index 6cf3240..8239d0a 100644
--- a/.github/workflows/haskell-ci.yml
+++ b/.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,15 +66,15 @@ 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:
           HCKIND: ${{ matrix.compilerKind }}
           HCNAME: ${{ matrix.compiler }}
           HCVER: ${{ matrix.compilerVersion }}
-
       - name: Set PATH and environment variables
         run: |
           echo "$HOME/.cabal/bin" >> $GITHUB_PATH
@@ -82,11 +82,14 @@ 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"
           echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"
diff --git a/postgresql-migration.cabal b/postgresql-migration.cabal
index 762598d..155afe3 100644
--- a/postgresql-migration.cabal
+++ b/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
diff --git a/src/Database/PostgreSQL/Simple/Migration.hs b/src/Database/PostgreSQL/Simple/Migration.hs
index a8b5561..a8493bc 100644
--- a/src/Database/PostgreSQL/Simple/Migration.hs
+++ b/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() "
@@ -215,7 +217,7 @@ executeValidation
 executeValidation con opts cmd = doStepTransaction opts con $
   case cmd of
     MigrationInitialization ->
-      existsTable con (BS8.unpack $ optTableName opts) <&> \r -> if r
+      existsTable con (migrationsTableName opts) <&> \r -> if r
         then MigrationSuccess
         else MigrationError ("No such table: " <> BS8.unpack (optTableName opts))
     MigrationDirectory path ->
@@ -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
 
diff --git a/src/Database/PostgreSQL/Simple/Util.hs b/src/Database/PostgreSQL/Simple/Util.hs
index 21935a1..92cd5c0 100644
--- a/src/Database/PostgreSQL/Simple/Util.hs
+++ b/src/Database/PostgreSQL/Simple/Util.hs
@@ -17,6 +17,7 @@ module Database.PostgreSQL.Simple.Util
     ) where
 
 import           Control.Exception ( finally )
+import           Database.PostgreSQL.Simple.Types (Identifier)
 import           Database.PostgreSQL.Simple ( Connection
                                             , Only (..)
                                             , begin
@@ -26,7 +27,7 @@ import           Database.PostgreSQL.Simple ( Connection
 import           GHC.Int (Int64)
 
 -- | Checks if the table with the given name exists in the database.
-existsTable :: Connection -> String -> IO Bool
+existsTable :: Connection -> Identifier -> IO Bool
 existsTable con table =
   checkRowCount <$> (query con q (Only table) :: IO [[Int64]])
   where
diff --git a/stack.yaml b/stack.yaml
index 8ed3709..9bd35a6 100644
--- a/stack.yaml
+++ b/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.
diff --git a/stack.yaml.lock b/stack.yaml.lock
index ae3d6f5..ea5a850 100644
--- a/stack.yaml.lock
+++ b/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

From 9e9e57f7d2afad3e3d46438268b700027a926a7b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= <honza.hrk@gmail.com>
Date: Wed, 4 Oct 2023 17:29:58 +0200
Subject: [PATCH 2/4] Fix

---
 .github/workflows/haskell-ci.yml            | 1 -
 src/Database/PostgreSQL/Simple/Migration.hs | 2 +-
 src/Database/PostgreSQL/Simple/Util.hs      | 3 +--
 3 files changed, 2 insertions(+), 4 deletions(-)

diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml
index 8239d0a..0efd555 100644
--- a/.github/workflows/haskell-ci.yml
+++ b/.github/workflows/haskell-ci.yml
@@ -89,7 +89,6 @@ jobs:
           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"
           echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"
diff --git a/src/Database/PostgreSQL/Simple/Migration.hs b/src/Database/PostgreSQL/Simple/Migration.hs
index a8493bc..0dea598 100644
--- a/src/Database/PostgreSQL/Simple/Migration.hs
+++ b/src/Database/PostgreSQL/Simple/Migration.hs
@@ -217,7 +217,7 @@ executeValidation
 executeValidation con opts cmd = doStepTransaction opts con $
   case cmd of
     MigrationInitialization ->
-      existsTable con (migrationsTableName opts) <&> \r -> if r
+      existsTable con (BS8.unpack $ optTableName opts) <&> \r -> if r
         then MigrationSuccess
         else MigrationError ("No such table: " <> BS8.unpack (optTableName opts))
     MigrationDirectory path ->
diff --git a/src/Database/PostgreSQL/Simple/Util.hs b/src/Database/PostgreSQL/Simple/Util.hs
index 92cd5c0..21935a1 100644
--- a/src/Database/PostgreSQL/Simple/Util.hs
+++ b/src/Database/PostgreSQL/Simple/Util.hs
@@ -17,7 +17,6 @@ module Database.PostgreSQL.Simple.Util
     ) where
 
 import           Control.Exception ( finally )
-import           Database.PostgreSQL.Simple.Types (Identifier)
 import           Database.PostgreSQL.Simple ( Connection
                                             , Only (..)
                                             , begin
@@ -27,7 +26,7 @@ import           Database.PostgreSQL.Simple ( Connection
 import           GHC.Int (Int64)
 
 -- | Checks if the table with the given name exists in the database.
-existsTable :: Connection -> Identifier -> IO Bool
+existsTable :: Connection -> String -> IO Bool
 existsTable con table =
   checkRowCount <$> (query con q (Only table) :: IO [[Int64]])
   where

From c9241b0ea370ce64c68504c1d72f23b32d8be179 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= <honza.hrk@gmail.com>
Date: Thu, 5 Oct 2023 07:57:29 +0200
Subject: [PATCH 3/4] Add reproducer

---
 .../Simple/TransactionPerStepTest.hs          | 21 ++++++++++++-------
 1 file changed, 13 insertions(+), 8 deletions(-)

diff --git a/test/Database/PostgreSQL/Simple/TransactionPerStepTest.hs b/test/Database/PostgreSQL/Simple/TransactionPerStepTest.hs
index 84a70df..1a95b55 100644
--- a/test/Database/PostgreSQL/Simple/TransactionPerStepTest.hs
+++ b/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); --\""
+        ]

From cc6ab825ad3e1f92eb9f040cd0757a75a6861a72 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= <honza.hrk@gmail.com>
Date: Thu, 5 Oct 2023 08:07:43 +0200
Subject: [PATCH 4/4] Undo spurious whitespace change

---
 .github/workflows/haskell-ci.yml | 1 +
 1 file changed, 1 insertion(+)

diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml
index 0efd555..1a04b0e 100644
--- a/.github/workflows/haskell-ci.yml
+++ b/.github/workflows/haskell-ci.yml
@@ -75,6 +75,7 @@ jobs:
           HCKIND: ${{ matrix.compilerKind }}
           HCNAME: ${{ matrix.compiler }}
           HCVER: ${{ matrix.compilerVersion }}
+
       - name: Set PATH and environment variables
         run: |
           echo "$HOME/.cabal/bin" >> $GITHUB_PATH