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 where
   9
  10 import Database.Groundhog (
  11   AutoKey,
  12   insert,
  13   insertByAll )
  14 import Database.Groundhog.Core ( PersistBackend, PersistEntity )
  15
  16 import Xml ( FromXml(..) )
  17
  18
  19 -- | In Groundhog, there is a typeclass of things you can insert into
  20 --   the database. What we usually have, though, is an XML
  21 --   representation of something that has a Groundhog analogue that we
  22 --   could insert into the database. It would be real nice if we could
  23 --   just insert the XML thing and not have to convert back and
  24 --   forth. That's what the 'XmlImport' class lets you do.
  25 --
  26 --   Moreover, there is a contraint on the class that the type must
  27 --   also be a member of the 'FromXml' class. This allows us to define
  28 --   default implementations of \"insert me\" generically. Given any
  29 --   XML thing that can be converted to a database thing, we just do
  30 --   the conversion and then insert normally (however Groundhog would
  31 --   do it).
  32 --
  33 class (FromXml a, PersistEntity (Db a)) => XmlImport a where
  34   -- | This is similar to the signature for Groundhog's 'insert'
  35   --   function, except the 'AutoKey' we return is for our 'Db'
  36   --   counterpart.
  37   insert_xml :: (PersistBackend m) => a ->  m (AutoKey (Db a))
  38   insert_xml x = insert (from_xml x)
  39
  40   -- | Same rationale as 'insert_xml', except it uses 'insertByAll'.
  41   insertByAll_xml :: (PersistBackend m)
  42                   => a
  43                   -> m ( Either (AutoKey (Db a)) (AutoKey (Db a)) )
  44   insertByAll_xml x = insertByAll (from_xml x)
  45
  46
  47   -- | Try to insert the given object and get its primary key
  48   --   back. Or, if there's a unique constraint violation, get the
  49   --   primary key of the unique thing already present.
  50   --
  51   --   Note: we can switch to using fmap here as soon as Functor is a
  52   --   superclass of Monad (PersistBackend is a Monad).
  53   --
  54   insert_xml_or_select :: (PersistBackend m)
  55                        => a
  56                        -> m (AutoKey (Db a))
  57   insert_xml_or_select x = do
  58     tmp <- insertByAll_xml x
  59     return $ (either id id) tmp