src/TSN/DbImport.hs

   1 -- | Definition of the DbImport typeclass.
   2 --
   3 --   When we parse an XML tree, there are two functions that we would
   4 --   like to call on the result independent of its type. First, we
   5 --   would like to be able to run the database migrations for that
   6 --   type. The migrations are kept separate from insertion because, at
   7 --   some later point, it make make sense to disable automatic
   8 --   migrations.
   9 --
  10 --   Next we want to import the thing.
  11 --
  12 --   Neither of these should depend on the type -- we should just be
  13 --   able to call 'dbmigrate' followed by 'dbimport' on the
  14 --   datastructure and have the right thing happen. That is the
  15 --   purpose of the 'DbImport' typeclass. It allows the XML types to
  16 --   define their own \"migrate me\" and \"insert me\" functions that
  17 --   the rest of the application doesn't have to care about.
  18 --
  19 module TSN.DbImport (
  20   DbImport(..),
  21   ImportResult(..),
  22   run_dbmigrate )
  23 where
  24
  25 -- System imports
  26 import Control.Monad ( forM_ )
  27 import Control.Monad.IO.Class ( MonadIO( liftIO ) )
  28 import qualified Data.Map as Map ( elems )
  29 import Database.Groundhog ( executeRaw )
  30 import Database.Groundhog.Generic (
  31   createMigration,
  32   getQueries,
  33   mergeMigrations )
  34 import Database.Groundhog.Core ( Migration, NamedMigrations, PersistBackend )
  35 import Network.Services.TSN.Report ( report_info )
  36
  37
  38 -- | The type that will be returned from every file import attempt.
  39 --
  40 data ImportResult =
  41   ImportFailed String -- ^ Failure with an error message.
  42
  43   | ImportSkipped String -- ^ We processed the file, but didn't import it.
  44                          --   The reason is contained in the second field.
  45
  46   | ImportSucceeded      -- ^ We did import records.
  47
  48   | ImportUnsupported String -- ^ We didn't know how to process this file.
  49                              --   The second field should contain info.
  50
  51
  52 -- | Instances of this type know how to run their own database
  53 --   migrations and insert themselves into a database.
  54 --
  55 class DbImport a where
  56   -- | Import an instance of type @a@.
  57   dbimport :: (PersistBackend m) => a -> m ImportResult
  58
  59   -- | This must migrate *all* stuffs that can potentially be
  60   --   created/used by the type @a@.
  61   dbmigrate :: (MonadIO m, PersistBackend m) => a -> m ()
  62
  63
  64 -- | A migration runner that will use our normal info reporting
  65 --   mechanism. The top-level code was stolen from 'runMigration' in
  66 --   "Data.Groundhog.Generic" and the 'execute_pretty' code was stolen
  67 --   from 'executeMigration'' in the same module.
  68 --
  69 run_dbmigrate :: (MonadIO m, PersistBackend m) => Migration m -> m ()
  70 run_dbmigrate migration = createMigration migration >>= execute_pretty
  71   where
  72     execute_pretty :: (PersistBackend m, MonadIO m) => NamedMigrations -> m ()
  73     execute_pretty m = do
  74       let migs = getQueries False $ mergeMigrations $ Map.elems m
  75       case migs of
  76         Left errs -> fail $ unlines errs
  77         Right qs -> forM_ qs $ \q -> do
  78                          liftIO $ report_info ("Migration: " ++ q ++ ";")
  79                          executeRaw False q []