DbImport.hs

-- | Definition of the DbImport typeclass.
--
--   When we parse an XML tree, there are two functions that we would
--   like to call on the result independent of its type. First, we
--   would like to be able to run the database migrations for that
--   type. The migrations are kept separate from insertion because, at
--   some later point, it make make sense to disable automatic
--   migrations.
--
--   Next we want to import the thing.
--
--   Neither of these should depend on the type -- we should just be
--   able to call 'dbmigrate' followed by 'dbimport' on the
--   datastructure and have the right thing happen. That is the
--   purpose of the 'DbImport' typeclass. It allows the XML types to
--   define their own \"migrate me\" and \"insert me\" functions that
--   the rest of the application doesn't have to care about.
--
module TSN.DbImport (
  DbImport(..),
  ImportResult(..),
  run_dbmigrate )
where

-- System imports
import Control.Monad ( forM_ )
import Control.Monad.IO.Class ( MonadIO( liftIO ) )
import qualified Data.Map as Map ( elems )
import Database.Groundhog ( executeRaw )
import Database.Groundhog.Generic (
  createMigration,
  getQueries,
  mergeMigrations )
import Database.Groundhog.Core ( Migration, NamedMigrations, PersistBackend )
import Network.Services.TSN.Report ( report_info )


-- | 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      -- ^ 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 run their own database
--   migrations and insert themselves into a database.
--
class DbImport a where
  -- | 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 ()


-- | A migration runner that will use our normal info reporting
--   mechanism. The top-level code was stolen from 'runMigration' in
--   "Data.Groundhog.Generic" and the 'execute_pretty' code was stolen
--   from 'executeMigration'' in the same module.
--
run_dbmigrate :: (MonadIO m, PersistBackend m) => Migration m -> m ()
run_dbmigrate migration = createMigration migration >>= execute_pretty
  where
    execute_pretty :: (PersistBackend m, MonadIO m) => NamedMigrations -> m ()
    execute_pretty m = do
      let migs = getQueries False $ mergeMigrations $ Map.elems m
      case migs of
        Left errs -> fail $ unlines errs
        Right qs -> forM_ qs $ \q -> do
                         liftIO $ report_info ("Migration: " ++ q ++ ";")
                         executeRaw False q []