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.Core ( NamedMigrations )
  31 import Database.Groundhog.Generic (
  32   createMigration,
  33   getQueries,
  34   mergeMigrations )
  35 import Database.Groundhog.Core ( Migration, PersistBackend )
  36 import Network.Services.TSN.Report ( report_info )
  37
  38
  39 -- | The type that will be returned from every file import attempt.
  40 --
  41 data ImportResult =
  42   ImportFailed String -- ^ Failure with an error message.
  43
  44   | ImportSkipped String -- ^ We processed the file, but didn't import it.
  45                          --   The reason is contained in the second field.
  46
  47   | ImportSucceeded      -- ^ We did import records.
  48
  49   | ImportUnsupported String -- ^ We didn't know how to process this file.
  50                              --   The second field should contain info.
  51
  52
  53 -- | Instances of this type know how to run their own database
  54 --   migrations and insert themselves into a database.
  55 --
  56 class DbImport a where
  57   -- | Import an instance of type @a@.
  58   dbimport :: (PersistBackend m) => a -> m ImportResult
  59
  60   -- | This must migrate *all* stuffs that can potentially be
  61   --   created/used by the type @a@.
  62   dbmigrate :: (MonadIO m, PersistBackend m) => a -> m ()
  63
  64
  65 -- | A migration runner that will use our normal info reporting
  66 --   mechanism. The top-level code was stolen from 'runMigration' in
  67 --   "Data.Groundhog.Generic" and the 'execute_pretty' code was stolen
  68 --   from 'executeMigration'' in the same module.
  69 --
  70 run_dbmigrate :: (MonadIO m, PersistBackend m) => Migration m -> m ()
  71 run_dbmigrate migration = createMigration migration >>= execute_pretty
  72   where
  73     execute_pretty :: (PersistBackend m, MonadIO m) => NamedMigrations -> m ()
  74     execute_pretty m = do
  75       let migs = getQueries False $ mergeMigrations $ Map.elems m
  76       case migs of
  77         Left errs -> fail $ unlines errs
  78         Right qs -> forM_ qs $ \q -> do
  79                          liftIO $ report_info ("Migration: " ++ q ++ ";")
  80                          executeRaw False q []