src/TSN/XML/Injuries.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE QuasiQuotes #-}
   5 {-# LANGUAGE RecordWildCards #-}
   6 {-# LANGUAGE TemplateHaskell #-}
   7 {-# LANGUAGE TypeFamilies #-}
   8
   9 -- | Parse TSN XML for the DTD "injuriesxml.dtd". Each document
  10 --   contains a root element \<message\> that in turn contains zero or
  11 --   more \<listing\>s.
  12 --
  13 --   The listings will be mapped to a database table called
  14 --   \"injuries_listings\" automatically. The root message is retained
  15 --   so that we can easily delete its associated listings based on its
  16 --   time_stamp.
  17 --
  18 module TSN.XML.Injuries (
  19   dtd,
  20   pickle_message,
  21   -- * Tests
  22   injuries_tests,
  23   -- * WARNING: these are private but exported to silence warnings
  24   InjuriesConstructor(..),
  25   InjuriesListingConstructor(..) )
  26 where
  27
  28 -- System imports.
  29 import Data.Data ( Data )
  30 import Data.Time ( UTCTime )
  31 import Data.Typeable ( Typeable )
  32 import Database.Groundhog (
  33   countAll,
  34   deleteAll,
  35   migrate,
  36   runMigration,
  37   silentMigrationLogger )
  38 import Database.Groundhog.Core ( DefaultKey )
  39 import Database.Groundhog.Generic ( runDbConn )
  40 import Database.Groundhog.TH (
  41   groundhog,
  42   mkPersist )
  43 import Database.Groundhog.Sqlite ( withSqliteConn )
  44 import Data.Tuple.Curry ( uncurryN )
  45 import Test.Tasty ( TestTree, testGroup )
  46 import Test.Tasty.HUnit ( (@?=), testCase )
  47 import Text.XML.HXT.Core (
  48   PU,
  49   xp4Tuple,
  50   xp6Tuple,
  51   xpAttrImplied,
  52   xpElem,
  53   xpInt,
  54   xpList,
  55   xpOption,
  56   xpPair,
  57   xpPrim,
  58   xpText,
  59   xpWrap )
  60
  61 -- Local imports.
  62 import TSN.Codegen ( tsn_codegen_config )
  63 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  64 import TSN.Picklers ( xp_time_stamp )
  65 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
  66 import Xml (
  67   FromXml(..),
  68   FromXmlFk(..),
  69   ToDb(..),
  70   pickle_unpickle,
  71   unpickleable,
  72   unsafe_unpickle )
  73
  74
  75
  76 -- | The DTD to which this module corresponds. Used to invoke dbimport.
  77 --
  78 dtd :: String
  79 dtd = "injuriesxml.dtd"
  80
  81 --
  82 -- DB/XML Data types
  83 --
  84
  85 -- * InjuriesTeam
  86
  87 -- | XML/Database representation of a team as they appear in the
  88 --   injuries documents.
  89 --
  90 data InjuriesTeam =
  91   InjuriesTeam {
  92     db_team_name :: String,
  93     db_team_league :: Maybe String }
  94   deriving (Data, Eq, Show, Typeable)
  95
  96
  97 -- * InjuriesListing/InjuriesListingXml
  98
  99 -- | XML representation of the injury listings.
 100 --
 101 data InjuriesListingXml =
 102   InjuriesListingXml {
 103     xml_team :: InjuriesTeam,
 104     xml_teamno :: Maybe Int,
 105     xml_injuries :: String,
 106     xml_updated :: Maybe Bool }
 107   deriving (Eq, Show)
 108
 109 -- | Database representation of a 'InjuriesListing'. It possesses a
 110 --   foreign key to an 'Injuries' object so that we can easily delete
 111 --   'InjuriesListing's based on the parent message's time_stamp.
 112 --
 113 data InjuriesListing =
 114   InjuriesListing {
 115     db_injuries_id :: DefaultKey Injuries,
 116     db_team :: InjuriesTeam,
 117     db_teamno :: Maybe Int,
 118     db_injuries :: String,
 119     db_updated :: Maybe Bool }
 120
 121 instance ToDb InjuriesListingXml where
 122   -- | The DB analogue of a 'InjuriesListingXml' is a 'InjuriesListing'
 123   type Db InjuriesListingXml = InjuriesListing
 124
 125 instance FromXmlFk InjuriesListingXml where
 126   -- | Our foreign key points to an 'Injuries'.
 127   type Parent InjuriesListingXml = Injuries
 128
 129   -- | To convert between a 'InjuriesListingXml' and a
 130   --   'InjuriesListing', we simply append the foreign key.
 131   from_xml_fk fk InjuriesListingXml{..} =
 132     InjuriesListing {
 133       db_injuries_id = fk,
 134       db_team = xml_team,
 135       db_teamno = xml_teamno,
 136       db_injuries = xml_injuries,
 137       db_updated = xml_updated }
 138
 139 -- | This allows us to insert the XML representation
 140 --   'InjuriesListingXml' directly.
 141 --
 142 instance XmlImportFk InjuriesListingXml
 143
 144
 145 -- * Injuries/Message
 146
 147 -- | XML representation of an injuriesxml \<message\>.
 148 --
 149 data Message =
 150   Message {
 151     xml_xml_file_id :: Int,
 152     xml_heading :: String,
 153     xml_category :: String,
 154     xml_sport :: String,
 155     xml_listings :: [InjuriesListingXml],
 156     xml_time_stamp :: UTCTime }
 157   deriving (Eq, Show)
 158
 159 -- | Database representation of a 'Message'.
 160 --
 161 data Injuries =
 162   Injuries {
 163     db_xml_file_id :: Int,
 164     db_sport :: String,
 165     db_time_stamp :: UTCTime }
 166
 167 instance ToDb Message where
 168   -- | The database analogue of a 'Message' is an 'Injuries'.
 169   type Db Message = Injuries
 170
 171 instance FromXml Message where
 172   -- | To convert from XML to DB, we simply drop the fields we don't
 173   --   care about.
 174   --
 175   from_xml Message{..} =
 176     Injuries {
 177       db_xml_file_id = xml_xml_file_id,
 178       db_sport = xml_sport,
 179       db_time_stamp = xml_time_stamp }
 180
 181 -- | This allows us to insert the XML representation 'Message'
 182 --   directly.
 183 --
 184 instance XmlImport Message
 185
 186
 187 --
 188 -- Database code
 189 --
 190
 191 instance DbImport Message where
 192   dbmigrate _ =
 193     run_dbmigrate $ do
 194       migrate (undefined :: Injuries)
 195       migrate (undefined :: InjuriesListing)
 196
 197   -- | We import a 'Message' by inserting all of its 'listings', but
 198   --   the listings require a foreign key to the parent 'Message'.
 199   --
 200   dbimport msg = do
 201     msg_id <- insert_xml msg
 202
 203     -- Convert each XML listing to a DB one using the message id and
 204     -- insert it (disregarding the result).
 205     mapM_ (insert_xml_fk_ msg_id) (xml_listings msg)
 206
 207     return ImportSucceeded
 208
 209
 210 mkPersist tsn_codegen_config [groundhog|
 211 - entity: Injuries
 212   constructors:
 213     - name: Injuries
 214       uniques:
 215         - name: unique_injuries
 216           type: constraint
 217           # Prevent multiple imports of the same message.
 218           fields: [db_xml_file_id]
 219
 220 - entity: InjuriesListing
 221   dbName: injuries_listings
 222   constructors:
 223     - name: InjuriesListing
 224       fields:
 225         - name: db_team
 226           embeddedType:
 227             - {name: team_name, dbName: team_name}
 228             - {name: team_league, dbName: team_league}
 229         - name: db_injuries_id
 230           reference:
 231             onDelete: cascade
 232
 233 - embedded: InjuriesTeam
 234   fields:
 235     - name: db_team_name
 236     - name: db_team_league
 237 |]
 238
 239
 240 --
 241 -- XML Picklers
 242 --
 243
 244
 245 -- | A pickler for 'InjuriesTeam's that can convert them to/from XML.
 246 --
 247 pickle_injuries_team :: PU InjuriesTeam
 248 pickle_injuries_team =
 249   xpElem "team" $
 250     xpWrap (from_tuple, to_tuple) $
 251     xpPair xpText (xpAttrImplied "league" xpText)
 252   where
 253     from_tuple = uncurryN InjuriesTeam
 254     to_tuple m = (db_team_name m, db_team_league m)
 255
 256
 257 -- | A pickler for 'InjuriesListingXml's that can convert them to/from
 258 --   XML.
 259 --
 260 pickle_listing :: PU InjuriesListingXml
 261 pickle_listing =
 262   xpElem "listing" $
 263     xpWrap (from_tuple, to_tuple) $
 264     xp4Tuple pickle_injuries_team
 265              (xpOption $ xpElem "teamno" xpInt)
 266              (xpElem "injuries" xpText)
 267              (xpOption $ xpElem "updated" xpPrim)
 268   where
 269     from_tuple = uncurryN InjuriesListingXml
 270     to_tuple l = (xml_team l, xml_teamno l, xml_injuries l, xml_updated l)
 271
 272
 273 -- | A pickler for 'Message's that can convert them to/from XML.
 274 --
 275 pickle_message :: PU Message
 276 pickle_message =
 277   xpElem "message" $
 278     xpWrap (from_tuple, to_tuple) $
 279     xp6Tuple (xpElem "XML_File_ID" xpInt)
 280              (xpElem "heading" xpText)
 281              (xpElem "category" xpText)
 282              (xpElem "sport" xpText)
 283              (xpList pickle_listing)
 284              (xpElem "time_stamp" xp_time_stamp)
 285   where
 286     from_tuple = uncurryN Message
 287     to_tuple m = (xml_xml_file_id m,
 288                   xml_heading m,
 289                   xml_category m,
 290                   xml_sport m,
 291                   xml_listings m,
 292                   xml_time_stamp m)
 293
 294
 295 --
 296 -- Tasty Tests
 297 --
 298
 299 -- | A list of all tests for this module.
 300 --
 301 injuries_tests :: TestTree
 302 injuries_tests =
 303   testGroup
 304     "Injuries tests"
 305     [ test_on_delete_cascade,
 306       test_pickle_of_unpickle_is_identity,
 307       test_unpickle_succeeds ]
 308
 309
 310 -- | If we unpickle something and then pickle it, we should wind up
 311 --   with the same thing we started with. WARNING: success of this
 312 --   test does not mean that unpickling succeeded.
 313 --
 314 test_pickle_of_unpickle_is_identity :: TestTree
 315 test_pickle_of_unpickle_is_identity =
 316   testCase "pickle composed with unpickle is the identity" $ do
 317     let path = "test/xml/injuriesxml.xml"
 318     (expected, actual) <- pickle_unpickle pickle_message path
 319     actual @?= expected
 320
 321
 322 -- | Make sure we can actually unpickle these things.
 323 --
 324 test_unpickle_succeeds :: TestTree
 325 test_unpickle_succeeds =
 326   testCase "unpickling succeeds" $ do
 327     let path = "test/xml/injuriesxml.xml"
 328     actual <- unpickleable path pickle_message
 329     let expected = True
 330     actual @?= expected
 331
 332
 333 -- | Make sure everything gets deleted when we delete the top-level
 334 --   record.
 335 --
 336 test_on_delete_cascade :: TestTree
 337 test_on_delete_cascade =
 338   testCase "deleting an injuries deletes its children" $ do
 339     let path = "test/xml/injuriesxml.xml"
 340     inj <- unsafe_unpickle path pickle_message
 341     let a = undefined :: Injuries
 342     let b = undefined :: InjuriesListing
 343     actual <- withSqliteConn ":memory:" $ runDbConn $ do
 344                 runMigration silentMigrationLogger $ do
 345                   migrate a
 346                   migrate b
 347                 _ <- dbimport inj
 348                 deleteAll a
 349                 count_a <- countAll a
 350                 count_b <- countAll b
 351                 return $ count_a + count_b
 352     let expected = 0
 353     actual @?= expected