X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FDbImport.hs;h=066b5a0c36e7e8ec2a72dfc687224a03ff3b1b79;hb=cc0fa217e3d1b3505a34642a68950ef40d3b4007;hp=83092558bef6c2b52bd9bad479c02677c1b9bf51;hpb=e46de7e95112d4e35219b74c0b3efffe99c69c6a;p=dead%2Fhtsn-import.git

diff --git a/src/TSN/DbImport.hs b/src/TSN/DbImport.hs
index 8309255..066b5a0 100644
--- a/src/TSN/DbImport.hs
+++ b/src/TSN/DbImport.hs
@@ -1,47 +1,80 @@
 -- | Definition of the DbImport typeclass.
-module TSN.DbImport
+--
+--   When we parse an XML tree, there are two functions that we would
+--   like to call on the result independent of its type. First, we
+--   would like to be able to run the database migrations for that
+--   type. The migrations are kept separate from insertion because, at
+--   some later point, it make make sense to disable automatic
+--   migrations.
+--
+--   Next we want to import the thing.
+--
+--   Neither of these should depend on the type -- we should just be
+--   able to call 'dbmigrate' followed by 'dbimport' on the
+--   datastructure and have the right thing happen. That is the
+--   purpose of the 'DbImport' typeclass. It allows the XML types to
+--   define their own \"migrate me\" and \"insert me\" functions that
+--   the rest of the application doesn't have to care about.
+--
+module TSN.DbImport (
+  DbImport(..),
+  ImportResult(..),
+  run_dbmigrate )
 where
 
-import Control.Monad.IO.Class ( MonadIO, liftIO )
-import Database.Groundhog (
-  defaultMigrationLogger,
-  insert,
-  migrate,
-  runMigration )
-import Database.Groundhog.Core ( PersistBackend, PersistEntity )
-import Network.Services.TSN.Report ( report_error )
-import Text.XML.HXT.Core (
-  XmlPickler,
-  XmlTree,
-  unpickleDoc,
-  xpickle )
-
--- | Instances of this type know how to insert themselves into a
---   Groundhog database.
+-- System imports
+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.Core ( NamedMigrations )
+import Database.Groundhog.Generic (
+  createMigration,
+  getQueries,
+  mergeMigrations )
+import Database.Groundhog.Core ( Migration, PersistBackend )
+import Network.Services.TSN.Report ( report_info )
+
+
+-- | The type that will be returned from every file import attempt.
+--
+data ImportResult =
+  ImportFailed String -- ^ Failure with an error message.
+
+  | ImportSkipped String -- ^ We processed the file, but didn't import it.
+                         --   The reason is contained in the second field.
+
+  | ImportSucceeded      -- ^ We did import records.
+
+  | ImportUnsupported String -- ^ We didn't know how to process this file.
+                             --   The second field should contain info.
+
+
+-- | Instances of this type know how to run their own database
+--   migrations and insert themselves into a database.
+--
 class DbImport a where
-  dbimport :: (MonadIO m, PersistBackend m)
-           => a
-           -> XmlTree
-           -> m (Maybe Int)
+  -- | Import an instance of type @a@.
+  dbimport :: (PersistBackend m) => a -> m ImportResult
+
+  -- | This must migrate *all* stuffs that can potentially be
+  --   created/used by the type @a@.
+  dbmigrate :: (MonadIO m, PersistBackend m) => a -> m ()
 
 
--- | We put the 'Configuration' and 'XmlTree' arguments last so that
--- it's easy to eta reduce all of the import_foo functions that call
--- this.
+-- | A migration runner that will use our normal info reporting
+--   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.
 --
-import_generic :: (XmlPickler a, MonadIO m, PersistEntity b, PersistBackend m)
-               => (a -> [b]) -- ^ listings getter
-               -> b          -- ^ Dummy Listing instance needed for 'migrate'
-               -> XmlTree
-               -> m (Maybe Int) -- ^ Return the number of records inserted.
-import_generic g dummy xml = do
-  runMigration defaultMigrationLogger $ migrate dummy
-  let root_element = unpickleDoc xpickle xml
-  case root_element of
-    Nothing -> do
-      let msg = "Could not unpickle document in import_generic."
-      liftIO $ report_error msg
-      return Nothing
-    Just elt  -> do
-      ids <- mapM insert (g elt)
-      return $ Just (length ids)
+run_dbmigrate :: (MonadIO m, PersistBackend m) => Migration m -> m ()
+run_dbmigrate migration = createMigration migration >>= execute_pretty
+  where
+    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 []