X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FDbImport.hs;h=7a420d380afc38bbc2903b9f334fc4b253ae577e;hb=f9a9d6fdcdd2ee0e6bb1882ed2eba936535a52ac;hp=c584a9a0a88847dd75bcaaea812b331f9c02012a;hpb=170f8986a6466fc9dc803c7b60f3c716f21be053;p=dead%2Fhtsn-import.git

diff --git a/src/TSN/DbImport.hs b/src/TSN/DbImport.hs
index c584a9a..7a420d3 100644
--- a/src/TSN/DbImport.hs
+++ b/src/TSN/DbImport.hs
@@ -23,14 +23,17 @@ module TSN.DbImport (
 where
 
 -- System imports
-import Control.Monad.IO.Class ( MonadIO )
-import Database.Groundhog ( runMigration )
-import Database.Groundhog.Core ( Migration, PersistBackend )
+import Control.Monad ( forM_ )
+import Control.Monad.IO.Class ( MonadIO( liftIO ) )
+import qualified Data.Map as Map ( elems )
+import Database.Groundhog ( executeRaw )
+import Database.Groundhog.Generic (
+  createMigration,
+  getQueries,
+  mergeMigrations )
+import Database.Groundhog.Core ( Migration, NamedMigrations, PersistBackend )
 import Network.Services.TSN.Report ( report_info )
 
--- Local imports
-import TSN.XmlImport ( XmlImport(..) )
-
 
 -- | The type that will be returned from every file import attempt.
 --
@@ -59,11 +62,18 @@ class DbImport a where
 
 
 -- | A migration runner that will use our normal info reporting
---   mechanism.
+--   mechanism. The top-level code was stolen from 'runMigration' in
+--   "Data.Groundhog.Generic" and the 'execute_pretty' code was stolen
+--   from 'executeMigration'' in the same module.
 --
 run_dbmigrate :: (MonadIO m, PersistBackend m) => Migration m -> m ()
-run_dbmigrate =
-  runMigration pretty_migration_logger
+run_dbmigrate migration = createMigration migration >>= execute_pretty
   where
-    pretty_migration_logger x =
-      report_info ("Migration: " ++ x ++ ";")
+    execute_pretty :: (PersistBackend m, MonadIO m) => NamedMigrations -> m ()
+    execute_pretty m = do
+      let migs = getQueries False $ mergeMigrations $ Map.elems m
+      case migs of
+        Left errs -> fail $ unlines errs
+        Right qs -> forM_ qs $ \q -> do
+                         liftIO $ report_info ("Migration: " ++ q ++ ";")
+                         executeRaw False q []