fixup! Generate MD5 sums for migrations found at build time.

cardano-db-sync-extended/cardano-db-sync-extended.cabal

@@ -48,7 +48,7 @@ custom-setup
                         base
                       , Cabal
                       , filepath
-                      , cryptonite
+                      , cardano-crypto-class
                       , bytestring
 
 

cardano-db-sync/Setup.hs

@@ -1,7 +1,7 @@
 module Main where
 
 import           Control.Monad (forM)
-import           Crypto.Hash (Digest (..), MD5 (..), hashWith)
+import           Cardano.Crypto.Hash
 
 import qualified Data.ByteString.Char8 as BS
 
@@ -34,26 +34,27 @@ main = defaultMainWithHooks generateHooks
 
 generateMigrations :: LocalBuildInfo -> FilePath -> FilePath -> IO ()
 generateMigrations locInfo srcDir outDir = do
-  createDirectoryIfMissingVerbose normal True "gen"
-  let sqls = collectMigrationSql srcDir
-  sqls' <- forM sqls build
-  buildMigrationModule sqls'
+    createDirectoryIfMissingVerbose normal True "gen"
+    sqls <- forM (collectMigrationSql srcDir) build
+    buildMigrationModule sqls
   where
-    -- TODO Should we be more specific with the SQL files we pickup?
-    -- There is a naming convention of migration-1-0000-20190730.sql
-    --                                 migration-<major>-<minor>-<yyyymmdd>.sql
+
     collectMigrationSql :: FilePath -> [FilePath]
     collectMigrationSql path =
       filter ((== ".sql") . takeExtension) (extraSrcFiles $ localPkgDescr locInfo)
 
-    build :: FilePath -> IO (Digest MD5, FilePath)
+    hashAs :: ByteString -> Hash Blake2b_256 ByteString
+    hashAs = hashWith id
+
+    build :: FilePath -> IO (String, FilePath)
     build filepath = do
       file <- BS.readFile filepath
-      pure (hashWith MD5 file, filepath)
+      pure $ ((hashToStringAsHex . hashAs $ file), filepath)
+
 
-    buildMigrationModule :: [(Digest MD5, FilePath)] -> IO ()
+    buildMigrationModule :: [(String, FilePath)] -> IO ()
     buildMigrationModule sqls =
-      let buildLine (md5, filepath) = "    KnownMigration \"" ++ show md5 ++ "\" \"" ++ filepath ++ "\"" in
+      let buildLine (hashedFile, filepath) = "    KnownMigration \"" ++ hashedFile ++ "\" \"" ++ filepath ++ "\"" in
 
       rewriteFileEx normal "gen/MigrationValidations.hs" $
         unlines

cardano-db-sync/cardano-db-sync.cabal

@@ -47,7 +47,7 @@ custom-setup
                         base
                       , Cabal
                       , filepath
-                      , cryptonite
+                      , cardano-crypto-class
                       , bytestring
 
 library

cardano-db/cardano-db.cabal

@@ -53,13 +53,13 @@ library
                       , base                            >= 4.14         && < 4.16
                       , base16-bytestring
                       , bytestring
+                      , cardano-crypto-class
                       , cardano-ledger-core
                       , cardano-slotting
                       , containers
                       , conduit
                       , conduit-extra
                       , contra-tracer
-                      , cryptonite
                       , directory
                       , esqueleto
                       , extra

cardano-db/src/Cardano/Db/Migration.hs

@@ -12,11 +12,12 @@ module Cardano.Db.Migration
   , MigrationValidate (..)
   , MigrationValidateError (..)
   , validateMigrations
+  , hashMigrations
   , renderMigrationValidateError
   ) where
 
 import           Control.Exception (SomeException, handle)
-import           Control.Monad (forM, forM_, unless)
+import           Control.Monad (forM, forM_, unless, when)
 import           Control.Monad.IO.Class (liftIO)
 import           Control.Monad.Logger (NoLoggingT)
 import           Control.Monad.Trans.Except (ExceptT, throwE)
@@ -51,7 +52,7 @@ import           System.FilePath (takeFileName, (</>))
 import           System.IO (Handle, IOMode (AppendMode), hFlush, hPrint, hPutStrLn, stdout,
                    withFile)
 
-import           Crypto.Hash (MD5 (..), hashWith)
+import Cardano.Crypto.Hash
 
 newtype MigrationDir
   = MigrationDir FilePath
@@ -60,11 +61,14 @@ newtype LogFileDir
   = LogFileDir FilePath
 
 data MigrationValidate = MigrationValidate
-  { mvMD5 :: String
+  { mvHash :: String
   , mvFilepath :: String
   } deriving (Eq, Show)
 
-newtype MigrationValidateError = UnknownMigrationsFound [MigrationValidate] deriving (Eq, Show)
+data MigrationValidateError = UnknownMigrationsFound
+  { unknownMigrations :: [MigrationValidate]
+  , missingMigrations :: [MigrationValidate]
+  } deriving (Eq, Show)
 
 -- | Run the migrations in the provided 'MigrationDir' and write date stamped log file
 -- to 'LogFileDir'.
@@ -89,16 +93,18 @@ runMigrations pgconfig quiet migrationDir mLogfiledir = do
         . formatTime defaultTimeLocale ("migrate-" ++ iso8601DateFormat (Just "%H%M%S") ++ ".log")
         <$> getCurrentTime
 
--- Build MD5 for each file found in a directory.
-validateMigrations :: MigrationDir -> [(Text, Text)]-> ExceptT MigrationValidateError IO ()
+-- Build hash for each file found in a directory.
+validateMigrations :: MigrationDir -> [(Text, Text)] -> ExceptT MigrationValidateError IO ()
 validateMigrations migrationDir knownMigrations = do
-    let knownMigrations' = fmap (\(x,y) -> MigrationValidate (Text.unpack x) (Text.unpack y)) knownMigrations
+    let knownMigrations' = (\(x,y) -> MigrationValidate (Text.unpack x) (Text.unpack y)) <$> knownMigrations
     scripts <- liftIO $ hashMigrations migrationDir
 
-    unless (scripts == knownMigrations') $
+    when (scripts /= knownMigrations') $
       -- Error knownMigrations // scripts found [x] something
-      let unknown = scripts \\ knownMigrations' in
-      throwE $ UnknownMigrationsFound unknown
+      -- TODO Think these need to be flipped around, unknown -> missing based off diff between 2
+      let unknown = knownMigrations' \\ scripts in
+      let missing = scripts \\ knownMigrations' in
+      throwE $ UnknownMigrationsFound unknown missing
 
 applyMigration :: Bool -> PGConfig -> Maybe FilePath -> Handle -> (MigrationVersion, FilePath) -> IO ()
 applyMigration quiet pgconfig mLogFilename logHandle (version, script) = do
@@ -219,12 +225,15 @@ getMigrationScripts (MigrationDir location) = do
 hashMigrations :: MigrationDir -> IO [MigrationValidate]
 hashMigrations migrationDir = do
     scripts <- getMigrationScripts migrationDir
-    forM scripts $ \(_v, filepath) -> do
+    forM scripts $ \(_version, filepath) -> do
       file <- BS.readFile filepath
-      pure $ MigrationValidate (show . hashWith MD5 $ file) filepath
+      pure $ MigrationValidate (hashToStringAsHex . hashAs $ file) filepath
+  where
+    hashAs :: ByteString -> Hash Blake2b_256 ByteString
+    hashAs = hashWith id
 
 renderMigrationValidateError :: MigrationValidateError -> Text
 renderMigrationValidateError = \case
-    UnknownMigrationsFound migrations -> "Newer migrations found that were missing at compile time: " <> textShow migrations
+    UnknownMigrationsFound unknown missing -> "Newer migrations found that were missing at compile time: " <> textShow unknown <> " " <> textShow missing
 
 

cardano-db/test/Test/IO/Cardano/Db/Migration.hs

@@ -1,10 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}
-module Test.IO.Cardano.Db.Migration
-  ( tests
-  ) where
+module Test.IO.Cardano.Db.Migration where
 
 import           Cardano.Db
-
+import           Control.Monad.Trans.Except (runExceptT)
 import           Control.Monad (unless)
 
 import qualified Data.List as List
@@ -17,9 +15,68 @@ import           Test.Tasty.HUnit (testCase)
 tests :: TestTree
 tests =
   testGroup "Migration"
-    [ testCase "Migration is idempotent" migrationTest
+    [ -- testCase "Migration is idempotent" migrationTest
+    -- , 
+      testCase "Migration validation - unknown migration found" unknownMigrationValidate
+    , testCase "Migration validation - mismatched hash for migration" invalidHashMigrationValidate
+    , testCase "Migration validation - mismatched hash for migration 2" invalidHashMigrationValidate'
     ]
 
+unknownMigrationValidate :: IO ()
+unknownMigrationValidate = do
+  let schemaDir = MigrationDir "test" -- Point to empty migration directory
+  let knownMigrations = [("hash", "schema/migration-1-0000-20190730.sql")]
+  let expected = Left (UnknownMigrationsFound
+                        { unknownMigrations = [MigrationValidate {mvHash = "hash", mvFilepath = "schema/migration-1-0000-20190730.sql"} ]
+                        , missingMigrations = []
+                        }) :: Either MigrationValidateError ()
+  result <- runExceptT $ validateMigrations schemaDir knownMigrations
+  unless (result == expected) $
+    error $ mconcat
+            [ "Schema version mismatch. Expected "
+            , show expected
+            , " but got "
+            , show result
+            , "."
+            ]
+
+invalidHashMigrationValidate :: IO ()
+invalidHashMigrationValidate = do
+  let schemaDir = MigrationDir "test/schema" -- Migration directory with single migration
+  let knownMigrations = [("hash" -- Non-matching hash to file in test/schema/migration-1-0000-20190730.sql
+                         , "test/schema/migration-1-0000-20190730.sql")]
+  let expected = Left (UnknownMigrationsFound
+                       { unknownMigrations = [MigrationValidate { mvHash = "hash", mvFilepath = "test/schema/migration-1-0000-20190730.sql" }]
+                       , missingMigrations = [MigrationValidate { mvHash = "395187b4157ef5307b7d95e0150542e09bb19679055eee8017a34bcca89a691d"
+                                                                , mvFilepath = "test/schema/migration-1-0000-20190730.sql"}]}) :: Either MigrationValidateError ()
+  result <- runExceptT $ validateMigrations schemaDir knownMigrations
+  unless (result == expected) $
+    error $ mconcat
+            [ "Schema version mismatch. Expected "
+            , show expected
+            , " but got "
+            , show result
+            , "."
+            ]
+
+invalidHashMigrationValidate' :: IO ()
+invalidHashMigrationValidate' = do
+  let schemaDir = MigrationDir "test/schema" -- Migration directory with single migration
+  let knownMigrations = [] -- No known migrations from compiling
+  let expected = Left (UnknownMigrationsFound
+                       { unknownMigrations = []
+                       , missingMigrations = [MigrationValidate { mvHash = "395187b4157ef5307b7d95e0150542e09bb19679055eee8017a34bcca89a691d"
+                                                                , mvFilepath = "test/schema/migration-1-0000-20190730.sql"}]}) :: Either MigrationValidateError ()
+  result <- runExceptT $ validateMigrations schemaDir knownMigrations
+  unless (result == expected) $
+    error $ mconcat
+            [ "Schema version mismatch. Expected "
+            , show expected
+            , " but got "
+            , show result
+            , "."
+            ]
+
 -- Really just make sure that the migrations do actually run correctly.
 -- If they fail the file path of the log file (in /tmp) will be printed.
 migrationTest :: IO ()
@@ -63,3 +120,5 @@ readSchemaVersion migrationDir = do
 showSchemaVersion :: SchemaVersion -> String
 showSchemaVersion (SchemaVersion a b c) =
   List.intercalate "." [show a, show b, show c]
+
+

cardano-db/test/schema/migration-1-0000-20190730.sql

@@ -0,0 +1 @@
+dummy migration