Add a DbImport class implementing the import interface.

[dead/htsn-import.git] / src / TSN / DbImport.hs

diff --git a/src/TSN/DbImport.hs b/src/TSN/DbImport.hs
new file mode 100644 (file)
index 0000000..8309255
--- /dev/null
+++ b/src/TSN/DbImport.hs
@@ -0,0 +1,47 @@
+-- | Definition of the DbImport typeclass.
+module TSN.DbImport
+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.
+class DbImport a where
+  dbimport :: (MonadIO m, PersistBackend m)
+           => a
+           -> XmlTree
+           -> m (Maybe Int)
+
+
+-- | 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.
+--
+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)