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