XmlImport.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}

-- | Definition of the XmlImport class.
--
module TSN.XmlImport (
  XmlImport(..),
  XmlImportFk(..),
  XmlImportFkTeams(..) )
where

-- System imports.
import Database.Groundhog (
  AutoKey,
  DefaultKey,
  insert,
  insert_,
  insertByAll )
import Database.Groundhog.Core ( PersistBackend, PersistEntity )


-- Local imports.
import TSN.Team ( Team(..) )
import Xml (
  Child(..),
  FromXml(..),
  FromXmlFk(..),
  FromXmlFkTeams(..),
  ToDb(..) )


-- | In Groundhog, there is a typeclass of things you can insert into
--   the database. What we usually have, though, is an XML
--   representation of something that has a Groundhog analogue that we
--   could insert into the database. It would be real nice if we could
--   just insert the XML thing and not have to convert back and
--   forth. That's what the 'XmlImport' class lets you do.
--
--   Moreover, there is a contraint on the class that the type must
--   also be a member of the 'FromXml' class. This allows us to define
--   default implementations of \"insert me\" generically. Given any
--   XML thing that can be converted to a database thing, we just do
--   the conversion and then insert normally (however Groundhog would
--   do it).
--
class (FromXml a, PersistEntity (Db a)) => XmlImport a where
  -- | This is similar to the signature for Groundhog's 'insert'
  --   function, except the 'AutoKey' we return is for our 'Db'
  --   counterpart.
  insert_xml :: (PersistBackend m) => a ->  m (AutoKey (Db a))
  insert_xml = insert . from_xml

  -- | Identical to 'insert_xml', except it doesn't return anything.
  insert_xml_ :: (PersistBackend m) => a ->  m ()
  insert_xml_ = insert_ . from_xml

  -- | Same rationale as 'insert_xml', except it uses 'insertByAll'.
  insertByAll_xml :: (PersistBackend m)
                  => a
                  -> m ( Either (AutoKey (Db a)) (AutoKey (Db a)) )
  insertByAll_xml = insertByAll . from_xml


  -- | Try to insert the given object and get its primary key
  --   back. Or, if there's a unique constraint violation, get the
  --   primary key of the unique thing already present.
  --
  --   Note: we can switch to using fmap here as soon as Functor is a
  --   superclass of Monad (PersistBackend is a Monad).
  --
  insert_xml_or_select :: (PersistBackend m)
                       => a
                       -> m (AutoKey (Db a))
  insert_xml_or_select x = do
    tmp <- insertByAll_xml x
    return $ (either id id) tmp



-- | A total copy of 'XmlImport' for instances of 'FromXmlFk'.
--
class (Child a, FromXmlFk a, PersistEntity (Db a)) => XmlImportFk a where
  insert_xml_fk :: (PersistBackend m)
                => DefaultKey (Parent a)
                -> a
                ->  m (AutoKey (Db a))
  insert_xml_fk fk x = insert $ from_xml_fk fk x

  insert_xml_fk_ :: (PersistBackend m) => DefaultKey (Parent a) -> a -> m ()
  insert_xml_fk_ fk x = insert_ $ from_xml_fk fk x

  insertByAll_xml_fk :: (PersistBackend m)
                     => DefaultKey (Parent a)
                     -> a
                     -> m ( Either (AutoKey (Db a)) (AutoKey (Db a)) )
  insertByAll_xml_fk fk x = insertByAll $ from_xml_fk fk x

  insert_xml_or_select_fk :: (PersistBackend m)
                          => DefaultKey (Parent a)
                          -> a
                          -> m (AutoKey (Db a))
  insert_xml_or_select_fk fk x = do
    tmp <- insertByAll_xml_fk fk x
    return $ (either id id) tmp


-- | A total copy of 'XmlImport' for instances of 'FromXmlFkTeams'.
--   This is a lot of duplicated boilerplate, but you don't have to
--   think about it usually. What you're really worried about is that
--   the dbimport code is understandable, and having these convenience
--   classes makes the import much simpler since you don't have to do
--   these conversions on-the-fly.
--
class (Child a,
       FromXmlFkTeams a,
       PersistEntity (Db a))
       => XmlImportFkTeams a where
  insert_xml_fk_teams :: (PersistBackend m)
                      => DefaultKey (Parent a)
                      -> DefaultKey Team -- ^ Away team FK
                      -> DefaultKey Team -- ^ Home team FK
                      -> a
                      ->  m (AutoKey (Db a))
  insert_xml_fk_teams fk fk_away fk_home x =
    insert $ from_xml_fk_teams fk fk_away fk_home x

  insert_xml_fk_teams_ :: (PersistBackend m)
                       => DefaultKey (Parent a)
                       -> DefaultKey Team
                       -> DefaultKey Team
                       -> a
                       -> m ()
  insert_xml_fk_teams_ fk fk_away fk_home x =
    insert_ $ from_xml_fk_teams fk fk_away fk_home x

  insertByAll_xml_fk_teams :: (PersistBackend m)
                           => DefaultKey (Parent a)
                           -> DefaultKey Team
                           -> DefaultKey Team
                           -> a
                           -> m ( Either (AutoKey (Db a)) (AutoKey (Db a)) )
  insertByAll_xml_fk_teams fk fk_away fk_home x =
    insertByAll $ from_xml_fk_teams fk fk_away fk_home x

  insert_xml_or_select_fk_teams :: (PersistBackend m)
                                => DefaultKey (Parent a)
                                -> DefaultKey Team
                                -> DefaultKey Team
                                -> a
                                -> m (AutoKey (Db a))
  insert_xml_or_select_fk_teams fk fk_away fk_home x = do
    tmp <- insertByAll_xml_fk_teams fk fk_away fk_home x
    return $ (either id id) tmp