{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
+-- | Definition of the XmlImport class.
+--
module TSN.XmlImport (
- XmlImport(..) )
+ XmlImport(..),
+ XmlImportFk(..),
+ XmlImportFkTeams(..) )
where
+-- System imports.
import Database.Groundhog (
AutoKey,
+ DefaultKey,
insert,
+ insert_,
insertByAll )
import Database.Groundhog.Core ( PersistBackend, PersistEntity )
-import Xml ( FromXml(..) )
+-- Local imports.
+import TSN.Team ( FromXmlFkTeams(..), Team(..) )
+import Xml (
+ Child(..),
+ FromXml(..),
+ FromXmlFk(..),
+ 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 x = insert (from_xml x)
+ 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 x = insertByAll (from_xml x)
+ 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
projects / dead / htsn-import.git / blobdiff