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

diff --git a/src/TSN/DbImport.hs b/src/TSN/DbImport.hs
new file mode 100644
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)