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