src/TSN/DbImport.hs

   1 -- | Definition of the DbImport typeclass.
   2 module TSN.DbImport
   3 where
   4
   5 import Control.Monad.IO.Class ( MonadIO, liftIO )
   6 import Database.Groundhog (
   7   defaultMigrationLogger,
   8   insert,
   9   migrate,
  10   runMigration )
  11 import Database.Groundhog.Core ( PersistBackend, PersistEntity )
  12 import Network.Services.TSN.Report ( report_error )
  13 import Text.XML.HXT.Core (
  14   XmlPickler,
  15   XmlTree,
  16   unpickleDoc,
  17   xpickle )
  18
  19 -- | Instances of this type know how to insert themselves into a
  20 --   Groundhog database.
  21 class DbImport a where
  22   dbimport :: (MonadIO m, PersistBackend m)
  23            => a
  24            -> XmlTree
  25            -> m (Maybe Int)
  26
  27
  28 -- | We put the 'Configuration' and 'XmlTree' arguments last so that
  29 -- it's easy to eta reduce all of the import_foo functions that call
  30 -- this.
  31 --
  32 import_generic :: (XmlPickler a, MonadIO m, PersistEntity b, PersistBackend m)
  33                => (a -> [b]) -- ^ listings getter
  34                -> b          -- ^ Dummy Listing instance needed for 'migrate'
  35                -> XmlTree
  36                -> m (Maybe Int) -- ^ Return the number of records inserted.
  37 import_generic g dummy xml = do
  38   runMigration defaultMigrationLogger $ migrate dummy
  39   let root_element = unpickleDoc xpickle xml
  40   case root_element of
  41     Nothing -> do
  42       let msg = "Could not unpickle document in import_generic."
  43       liftIO $ report_error msg
  44       return Nothing
  45     Just elt  -> do
  46       ids <- mapM insert (g elt)
  47       return $ Just (length ids)