src/TSN/DbImport.hs

   1 -- | Definition of the DbImport typeclass.
   2 module TSN.DbImport
   3 where
   4
   5 import Control.Monad.IO.Class ( MonadIO )
   6 import Database.Groundhog (
   7   defaultMigrationLogger,
   8   insert,
   9   migrate,
  10   runMigration )
  11 import Database.Groundhog.Core ( PersistBackend, PersistEntity )
  12 import Text.XML.HXT.Core (
  13   XmlPickler,
  14   XmlTree,
  15   unpickleDoc,
  16   xpickle )
  17
  18
  19 -- | The type that will be returned from every file import attempt. If
  20 --   there was an error, its description will be wrapped in an Err. If
  21 --   we successfully imported records, the number of records imported
  22 --   will be wrapped in a Succ.
  23 --
  24 --   Anything else will be wrapped in a "Info" constructor;
  25 --   i.e. somewhere between success and failure. This is like an
  26 --   'Either' with three choices. A "Info" return value means that
  27 --   the XML document *was* processed, so it should be removed.
  28 --
  29 data ImportResult =
  30   ImportFailed String -- ^ Failure with an error message.
  31     | ImportSkipped String -- ^ We processed the file, but didn't import it.
  32                            --   The reason is contained in the second field.
  33     | ImportSucceeded Int  -- ^ We did import records, and here's how many.
  34     | ImportUnsupported String -- ^ We didn't know how to process this file.
  35                                --   The second field should contain info.
  36
  37 -- | Instances of this type know how to insert themselves into a
  38 --   Groundhog database.
  39 class DbImport a where
  40   dbimport :: (MonadIO m, PersistBackend m)
  41            => a
  42            -> XmlTree
  43            -> m ImportResult
  44
  45
  46 -- | We put the 'Configuration' and 'XmlTree' arguments last so that
  47 -- it's easy to eta reduce all of the import_foo functions that call
  48 -- this.
  49 --
  50 import_generic :: (XmlPickler a, MonadIO m, PersistEntity b, PersistBackend m)
  51                => (a -> [b]) -- ^ listings getter
  52                -> b          -- ^ Dummy Listing instance needed for 'migrate'
  53                -> XmlTree
  54                -> m ImportResult -- ^ Return the number of records inserted.
  55 import_generic g dummy xml = do
  56   runMigration defaultMigrationLogger $ migrate dummy
  57   let root_element = unpickleDoc xpickle xml
  58   case root_element of
  59     Nothing -> return $
  60                  ImportFailed "Could not unpickle document in import_generic."
  61     Just elt  -> do
  62       ids <- mapM insert (g elt)
  63       return $ ImportSucceeded (length ids)