src/TSN/XmlImport.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE GADTs #-}
   3
   4 -- | Definition of the XmlImport class.
   5 --
   6 module TSN.XmlImport (
   7   XmlImport(..),
   8   XmlImportFk(..),
   9   XmlImportFkTeams(..) )
  10 where
  11
  12 -- System imports.
  13 import Database.Groundhog (
  14   AutoKey,
  15   DefaultKey,
  16   insert,
  17   insert_,
  18   insertByAll )
  19 import Database.Groundhog.Core ( PersistBackend, PersistEntity )
  20
  21
  22 -- Local imports.
  23 import TSN.Team ( FromXmlFkTeams(..), Team(..) )
  24 import Xml (
  25   Child(..),
  26   FromXml(..),
  27   FromXmlFk(..),
  28   ToDb(..) )
  29
  30
  31 -- | In Groundhog, there is a typeclass of things you can insert into
  32 --   the database. What we usually have, though, is an XML
  33 --   representation of something that has a Groundhog analogue that we
  34 --   could insert into the database. It would be real nice if we could
  35 --   just insert the XML thing and not have to convert back and
  36 --   forth. That's what the 'XmlImport' class lets you do.
  37 --
  38 --   Moreover, there is a contraint on the class that the type must
  39 --   also be a member of the 'FromXml' class. This allows us to define
  40 --   default implementations of \"insert me\" generically. Given any
  41 --   XML thing that can be converted to a database thing, we just do
  42 --   the conversion and then insert normally (however Groundhog would
  43 --   do it).
  44 --
  45 class (FromXml a, PersistEntity (Db a)) => XmlImport a where
  46   -- | This is similar to the signature for Groundhog's 'insert'
  47   --   function, except the 'AutoKey' we return is for our 'Db'
  48   --   counterpart.
  49   insert_xml :: (PersistBackend m) => a ->  m (AutoKey (Db a))
  50   insert_xml = insert . from_xml
  51
  52   -- | Identical to 'insert_xml', except it doesn't return anything.
  53   insert_xml_ :: (PersistBackend m) => a ->  m ()
  54   insert_xml_ = insert_ . from_xml
  55
  56   -- | Same rationale as 'insert_xml', except it uses 'insertByAll'.
  57   insertByAll_xml :: (PersistBackend m)
  58                   => a
  59                   -> m ( Either (AutoKey (Db a)) (AutoKey (Db a)) )
  60   insertByAll_xml = insertByAll . from_xml
  61
  62
  63   -- | Try to insert the given object and get its primary key
  64   --   back. Or, if there's a unique constraint violation, get the
  65   --   primary key of the unique thing already present.
  66   --
  67   --   Note: we can switch to using fmap here as soon as Functor is a
  68   --   superclass of Monad (PersistBackend is a Monad).
  69   --
  70   insert_xml_or_select :: (PersistBackend m)
  71                        => a
  72                        -> m (AutoKey (Db a))
  73   insert_xml_or_select x = do
  74     tmp <- insertByAll_xml x
  75     return $ (either id id) tmp
  76
  77
  78
  79 -- | A total copy of 'XmlImport' for instances of 'FromXmlFk'.
  80 --
  81 class (Child a, FromXmlFk a, PersistEntity (Db a)) => XmlImportFk a where
  82   insert_xml_fk :: (PersistBackend m)
  83                 => DefaultKey (Parent a)
  84                 -> a
  85                 ->  m (AutoKey (Db a))
  86   insert_xml_fk fk x = insert $ from_xml_fk fk x
  87
  88   insert_xml_fk_ :: (PersistBackend m) => DefaultKey (Parent a) -> a -> m ()
  89   insert_xml_fk_ fk x = insert_ $ from_xml_fk fk x
  90
  91   insertByAll_xml_fk :: (PersistBackend m)
  92                      => DefaultKey (Parent a)
  93                      -> a
  94                      -> m ( Either (AutoKey (Db a)) (AutoKey (Db a)) )
  95   insertByAll_xml_fk fk x = insertByAll $ from_xml_fk fk x
  96
  97   insert_xml_or_select_fk :: (PersistBackend m)
  98                           => DefaultKey (Parent a)
  99                           -> a
 100                           -> m (AutoKey (Db a))
 101   insert_xml_or_select_fk fk x = do
 102     tmp <- insertByAll_xml_fk fk x
 103     return $ (either id id) tmp
 104
 105
 106 -- | A total copy of 'XmlImport' for instances of 'FromXmlFkTeams'.
 107 --   This is a lot of duplicated boilerplate, but you don't have to
 108 --   think about it usually. What you're really worried about is that
 109 --   the dbimport code is understandable, and having these convenience
 110 --   classes makes the import much simpler since you don't have to do
 111 --   these conversions on-the-fly.
 112 --
 113 class (Child a,
 114        FromXmlFkTeams a,
 115        PersistEntity (Db a))
 116        => XmlImportFkTeams a where
 117   insert_xml_fk_teams :: (PersistBackend m)
 118                       => DefaultKey (Parent a)
 119                       -> DefaultKey Team -- ^ Away team FK
 120                       -> DefaultKey Team -- ^ Home team FK
 121                       -> a
 122                       ->  m (AutoKey (Db a))
 123   insert_xml_fk_teams fk fk_away fk_home x =
 124     insert $ from_xml_fk_teams fk fk_away fk_home x
 125
 126   insert_xml_fk_teams_ :: (PersistBackend m)
 127                        => DefaultKey (Parent a)
 128                        -> DefaultKey Team
 129                        -> DefaultKey Team
 130                        -> a
 131                        -> m ()
 132   insert_xml_fk_teams_ fk fk_away fk_home x =
 133     insert_ $ from_xml_fk_teams fk fk_away fk_home x
 134
 135   insertByAll_xml_fk_teams :: (PersistBackend m)
 136                            => DefaultKey (Parent a)
 137                            -> DefaultKey Team
 138                            -> DefaultKey Team
 139                            -> a
 140                            -> m ( Either (AutoKey (Db a)) (AutoKey (Db a)) )
 141   insertByAll_xml_fk_teams fk fk_away fk_home x =
 142     insertByAll $ from_xml_fk_teams fk fk_away fk_home x
 143
 144   insert_xml_or_select_fk_teams :: (PersistBackend m)
 145                                 => DefaultKey (Parent a)
 146                                 -> DefaultKey Team
 147                                 -> DefaultKey Team
 148                                 -> a
 149                                 -> m (AutoKey (Db a))
 150   insert_xml_or_select_fk_teams fk fk_away fk_home x = do
 151     tmp <- insertByAll_xml_fk_teams fk fk_away fk_home x
 152     return $ (either id id) tmp