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 where
  10
  11 import Database.Groundhog (
  12   AutoKey,
  13   DefaultKey,
  14   insert,
  15   insert_,
  16   insertByAll )
  17 import Database.Groundhog.Core ( PersistBackend, PersistEntity )
  18
  19 import Xml ( FromXml(..), FromXmlFk(..), ToDb(..) )
  20
  21
  22 -- | In Groundhog, there is a typeclass of things you can insert into
  23 --   the database. What we usually have, though, is an XML
  24 --   representation of something that has a Groundhog analogue that we
  25 --   could insert into the database. It would be real nice if we could
  26 --   just insert the XML thing and not have to convert back and
  27 --   forth. That's what the 'XmlImport' class lets you do.
  28 --
  29 --   Moreover, there is a contraint on the class that the type must
  30 --   also be a member of the 'FromXml' class. This allows us to define
  31 --   default implementations of \"insert me\" generically. Given any
  32 --   XML thing that can be converted to a database thing, we just do
  33 --   the conversion and then insert normally (however Groundhog would
  34 --   do it).
  35 --
  36 class (FromXml a, PersistEntity (Db a)) => XmlImport a where
  37   -- | This is similar to the signature for Groundhog's 'insert'
  38   --   function, except the 'AutoKey' we return is for our 'Db'
  39   --   counterpart.
  40   insert_xml :: (PersistBackend m) => a ->  m (AutoKey (Db a))
  41   insert_xml = insert . from_xml
  42
  43   -- | Identical to 'insert_xml', except it doesn't return anything.
  44   insert_xml_ :: (PersistBackend m) => a ->  m ()
  45   insert_xml_ = insert_ . from_xml
  46
  47   -- | Same rationale as 'insert_xml', except it uses 'insertByAll'.
  48   insertByAll_xml :: (PersistBackend m)
  49                   => a
  50                   -> m ( Either (AutoKey (Db a)) (AutoKey (Db a)) )
  51   insertByAll_xml = insertByAll . from_xml
  52
  53
  54   -- | Try to insert the given object and get its primary key
  55   --   back. Or, if there's a unique constraint violation, get the
  56   --   primary key of the unique thing already present.
  57   --
  58   --   Note: we can switch to using fmap here as soon as Functor is a
  59   --   superclass of Monad (PersistBackend is a Monad).
  60   --
  61   insert_xml_or_select :: (PersistBackend m)
  62                        => a
  63                        -> m (AutoKey (Db a))
  64   insert_xml_or_select x = do
  65     tmp <- insertByAll_xml x
  66     return $ (either id id) tmp
  67
  68
  69
  70 -- | A total copy of 'XmlImport' for instances of 'FromXmlFk'.
  71 --
  72 class (FromXmlFk a, PersistEntity (Db a)) => XmlImportFk a where
  73   insert_xml_fk :: (PersistBackend m)
  74                 => DefaultKey (Parent a)
  75                 -> a
  76                 ->  m (AutoKey (Db a))
  77   insert_xml_fk fk x = insert $ from_xml_fk fk x
  78
  79   insert_xml_fk_ :: (PersistBackend m) => DefaultKey (Parent a) -> a -> m ()
  80   insert_xml_fk_ fk x = insert_ $ from_xml_fk fk x
  81
  82   insertByAll_xml_fk :: (PersistBackend m)
  83                      => DefaultKey (Parent a)
  84                      -> a
  85                      -> m ( Either (AutoKey (Db a)) (AutoKey (Db a)) )
  86   insertByAll_xml_fk fk x = insertByAll $ from_xml_fk fk x
  87
  88   insert_xml_or_select_fk :: (PersistBackend m)
  89                           => DefaultKey (Parent a)
  90                           -> a
  91                           -> m (AutoKey (Db a))
  92   insert_xml_or_select_fk fk x = do
  93     tmp <- insertByAll_xml_fk fk x
  94     return $ (either id id) tmp