-- | Definition of the DbImport typeclass.
-module TSN.DbImport
+module TSN.DbImport (
+ DbImport(..),
+ ImportResult(..),
+ dbimport_generic,
+ run_dbmigrate )
where
+-- System imports
import Control.Monad.IO.Class ( MonadIO )
import Database.Groundhog (
- defaultMigrationLogger,
- insert,
- migrate,
runMigration )
-import Database.Groundhog.Core ( PersistBackend, PersistEntity )
-import Text.XML.HXT.Core (
- XmlPickler,
- XmlTree,
- unpickleDoc,
- xpickle )
-
-
--- | The type that will be returned from every file import attempt. If
--- there was an error, its description will be wrapped in an Err. If
--- we successfully imported records, the number of records imported
--- will be wrapped in a Succ.
---
--- Anything else will be wrapped in a "Info" constructor;
--- i.e. somewhere between success and failure. This is like an
--- 'Either' with three choices. A "Info" return value means that
--- the XML document *was* processed, so it should be removed.
+import Database.Groundhog.Core ( Migration, 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.
--
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 Int -- ^ We did import records, and here's how many.
- | ImportUnsupported String -- ^ We didn't know how to process this file.
- -- The second field should contain info.
+
+ | 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 insert themselves into a
-- Groundhog database.
+--
class DbImport a where
- dbimport :: (MonadIO m, PersistBackend m)
- => a
- -> XmlTree
- -> m ImportResult
+ -- | 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.
+
+-- | The simplest possible implementation of 'dbimport', for types
+-- which happen to be members of the XmlImport typeclass.
--
-import_generic :: (XmlPickler a, MonadIO m, PersistEntity b, PersistBackend m)
- => (a -> [b]) -- ^ listings getter
- -> b -- ^ Dummy Listing instance needed for 'migrate'
- -> XmlTree
- -> m ImportResult -- ^ 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 -> return $
- ImportFailed "Could not unpickle document in import_generic."
- Just elt -> do
- ids <- mapM insert (g elt)
- return $ ImportSucceeded (length ids)
+dbimport_generic :: (XmlImport a, MonadIO m, PersistBackend m)
+ => a
+ -> m ImportResult
+dbimport_generic x = insert_xml x >> return ImportSucceeded
+
+
+-- | A migration runner that will use our normal info reporting
+-- mechanism.
+run_dbmigrate :: (MonadIO m, PersistBackend m) => Migration m -> m ()
+run_dbmigrate =
+ runMigration pretty_migration_logger
+ where
+ pretty_migration_logger x =
+ report_info ("Migration: " ++ x ++ ";")