src/TSN/XML/InjuriesDetail.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE QuasiQuotes #-}
   4 {-# LANGUAGE RecordWildCards #-}
   5 {-# LANGUAGE TemplateHaskell #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7
   8 -- | Parse TSN XML for the DTD "Injuries_Detail_XML.dtd". Each
   9 --   document contains a root element \<message\> that in turn
  10 --   contains zero or more \<Listing\>s (note: capitalization). The
  11 --   \<Listing\>s contain \<PlayerListing\>s which then contain the
  12 --   real meat.
  13 --
  14 module TSN.XML.InjuriesDetail (
  15   dtd,
  16   pickle_message,
  17   -- * Tests
  18   injuries_detail_tests,
  19   -- * WARNING: these are private but exported to silence warnings
  20   InjuriesDetailConstructor(..),
  21   InjuriesDetailListingConstructor(..),
  22   InjuriesDetailListingPlayerListingConstructor(..) )
  23 where
  24
  25 -- System imports.
  26 import Control.Monad ( forM_ )
  27 import Data.Time ( UTCTime )
  28 import Data.Tuple.Curry ( uncurryN )
  29 import Database.Groundhog (
  30   DefaultKey,
  31   countAll,
  32   deleteAll,
  33   migrate,
  34   runMigration,
  35   silentMigrationLogger )
  36 import Database.Groundhog.Generic ( runDbConn )
  37 import Database.Groundhog.Sqlite ( withSqliteConn )
  38 import Database.Groundhog.TH (
  39   groundhog,
  40   mkPersist )
  41 import Test.Tasty ( TestTree, testGroup )
  42 import Test.Tasty.HUnit ( (@?=), testCase )
  43 import Text.XML.HXT.Core (
  44   PU,
  45   xpTriple,
  46   xp6Tuple,
  47   xp10Tuple,
  48   xpElem,
  49   xpInt,
  50   xpList,
  51   xpOption,
  52   xpPrim,
  53   xpText,
  54   xpWrap )
  55
  56 -- Local imports.
  57 import TSN.Codegen ( tsn_codegen_config )
  58 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  59 import TSN.Picklers( xp_date, xp_time_stamp )
  60 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
  61 import Xml (
  62   Child(..),
  63   FromXml(..),
  64   FromXmlFk(..),
  65   ToDb(..),
  66   pickle_unpickle,
  67   unpickleable,
  68   unsafe_unpickle )
  69
  70
  71
  72 -- | The DTD to which this module corresponds. Used to invoke dbimport.
  73 --
  74 dtd :: String
  75 dtd = "Injuries_Detail_XML.dtd"
  76
  77
  78 --
  79 -- Data types
  80 --
  81
  82
  83 -- * InjuriesDetail/Message
  84
  85
  86 -- | XML representation of the top-level \<message\> element. These
  87 --   are not stored; the data type is used only for parsing.
  88 --
  89 data Message =
  90   Message {
  91     xml_xml_file_id :: Int,
  92     xml_heading :: String,
  93     xml_category :: String,
  94     xml_sport :: String,
  95     xml_listings :: [InjuriesDetailListingXml],
  96     xml_time_stamp :: UTCTime }
  97   deriving (Eq, Show)
  98
  99 -- | Database representation of a 'Message'.
 100 --
 101 data InjuriesDetail =
 102   InjuriesDetail {
 103     db_xml_file_id :: Int,
 104     db_sport :: String,
 105     db_time_stamp :: UTCTime }
 106   deriving (Eq, Show)
 107
 108 instance ToDb Message where
 109   -- | The database representation of a 'Message' is an
 110   --   'InjuriesDetail'.
 111   --
 112   type Db Message = InjuriesDetail
 113
 114 instance FromXml Message where
 115   -- | To convert a 'Message' into an 'InjuriesDetail', we simply drop
 116   --   a few fields.
 117   --
 118   from_xml Message{..} =
 119     InjuriesDetail {
 120       db_xml_file_id = xml_xml_file_id,
 121       db_sport = xml_sport,
 122       db_time_stamp = xml_time_stamp }
 123
 124
 125 -- | This allows us to insert the XML representation 'Message'
 126 --   directly.
 127 --
 128 instance XmlImport Message
 129
 130
 131
 132 -- * InjuriesDetailListing/InjuriesDetailListingXml
 133
 134 -- | Database representation of a \<Listing\> element. It has a
 135 --   foreign key pointing to its parent 'InjuriesDetail', and does not
 136 --   contain the list of 'xml_player_listings' (which get their own
 137 --   table).
 138 --
 139 data InjuriesDetailListing =
 140   InjuriesDetailListing {
 141     db_injuries_detail_id :: DefaultKey InjuriesDetail,
 142     db_team_id :: String,
 143     db_full_name :: String }
 144
 145
 146 -- | XML incarnation of a \<Listing\> element. We don't store these;
 147 --   the data type is used only for parsing.
 148 --
 149 data InjuriesDetailListingXml =
 150   InjuriesDetailListingXml {
 151     xml_team_id :: String, -- ^ TeamIDs are (apparently) three
 152                            --   characters long and not necessarily
 153                            --   numeric.
 154
 155     xml_full_name :: String, -- ^ Team full name
 156     xml_player_listings :: [InjuriesDetailListingPlayerListingXml] }
 157   deriving (Eq, Show)
 158
 159 instance ToDb InjuriesDetailListingXml where
 160   -- | The database analogue of an 'InjuriesDetailListingXml' is a
 161   --   'InjuriesDetailListing'.
 162   type Db InjuriesDetailListingXml = InjuriesDetailListing
 163
 164
 165 instance Child InjuriesDetailListingXml where
 166   -- | Each 'InjuriesDetailListingXml' is contained in an
 167   --   'InjuriesDetail'.
 168   type Parent InjuriesDetailListingXml = InjuriesDetail
 169
 170
 171 instance FromXmlFk InjuriesDetailListingXml where
 172   -- | Construct a 'InjuriesDetailListing' from a
 173   --   'InjuriesDetailListingXml' and a foreign key to a
 174   --   'InjuriesDetail'.
 175   --
 176   from_xml_fk fk InjuriesDetailListingXml{..} =
 177     InjuriesDetailListing {
 178       db_injuries_detail_id = fk,
 179       db_team_id = xml_team_id,
 180       db_full_name = xml_full_name }
 181
 182 -- | This allows us to insert the XML representation
 183 --   'InjuriesDetailListingXml' directly.
 184 --
 185 instance XmlImportFk InjuriesDetailListingXml
 186
 187
 188 -- * InjuriesDetailListingPlayerListing
 189
 190 -- | XML representation of a \<PlayerListing\>, the main type of
 191 --   element contains in Injuries_Detail_XML messages.
 192 --
 193 data InjuriesDetailListingPlayerListingXml =
 194   InjuriesDetailListingPlayerListingXml {
 195     xml_player_team_id :: String, -- ^ TeamIDs are (apparently) three
 196                                   --   characters long and not
 197                                   --   necessarily numeric. Postgres
 198                                   --   imposes no performance penalty
 199                                   --   on a lengthless text field, so
 200                                   --   we ignore the likely upper
 201                                   --   bound of three characters.
 202                                   --   We add the \"player\" to avoid conflict
 203                                   --   with 'InjuriesDetailListingXml'.
 204     xml_player_id :: Int,
 205     xml_date      :: UTCTime,
 206     xml_pos       :: String,
 207     xml_name      :: String,
 208     xml_injury    :: String,
 209     xml_status    :: String,
 210     xml_fantasy   :: Maybe String, -- ^ Nobody knows what this is.
 211     xml_injured     :: Bool,
 212     xml_type :: String }
 213   deriving (Eq, Show)
 214
 215
 216
 217 -- | Database representation of a
 218 --   'InjuriesDetailListingPlayerListingXml'. We drop the team_id
 219 --   because it's redundant.
 220 --
 221 data InjuriesDetailListingPlayerListing =
 222   InjuriesDetailListingPlayerListing {
 223     db_injuries_detail_listings_id :: DefaultKey InjuriesDetailListing,
 224     db_player_id :: Int,
 225     db_date      :: UTCTime,
 226     db_pos       :: String,
 227     db_name      :: String,
 228     db_injury    :: String,
 229     db_status    :: String,
 230     db_fantasy   :: Maybe String, -- ^ Nobody knows what this is.
 231     db_injured     :: Bool,
 232     db_type :: String }
 233
 234
 235 instance ToDb InjuriesDetailListingPlayerListingXml where
 236   -- | The DB analogue of a 'InjuriesDetailListingPlayerListingXml' is
 237   --   'InjuriesDetailListingPlayerListing'.
 238   type Db InjuriesDetailListingPlayerListingXml =
 239     InjuriesDetailListingPlayerListing
 240
 241
 242 instance Child InjuriesDetailListingPlayerListingXml where
 243   -- | Each 'InjuriesDetailListingPlayerListingXml' is contained in an
 244   --   'InjuriesDetailListing'.
 245   --
 246   type Parent InjuriesDetailListingPlayerListingXml = InjuriesDetailListing
 247
 248
 249 instance FromXmlFk InjuriesDetailListingPlayerListingXml where
 250   -- | To construct a 'InjuriesDetailListingPlayerListing' from a
 251   --   'InjuriesDetailListingPlayerListingXml' we need to supply a
 252   --   foreign key to an 'InjuriesDetailListing'.
 253   --
 254   from_xml_fk fk InjuriesDetailListingPlayerListingXml{..} =
 255     InjuriesDetailListingPlayerListing {
 256       db_injuries_detail_listings_id = fk,
 257       db_player_id = xml_player_id,
 258       db_date = xml_date,
 259       db_pos = xml_pos,
 260       db_name = xml_name,
 261       db_injury = xml_injury,
 262       db_status = xml_status,
 263       db_fantasy = xml_fantasy,
 264       db_injured = xml_injured,
 265       db_type = xml_type }
 266
 267 -- | This lets us insert the XML representation
 268 --   'InjuriesDetailListingPlayerListingXml' directly.
 269 --
 270 instance XmlImportFk InjuriesDetailListingPlayerListingXml
 271
 272
 273 --
 274 -- Database stuff
 275 --
 276
 277 instance DbImport Message where
 278   dbmigrate _ =
 279     run_dbmigrate $ do
 280       migrate (undefined :: InjuriesDetail)
 281       migrate (undefined :: InjuriesDetailListing)
 282       migrate (undefined :: InjuriesDetailListingPlayerListing)
 283
 284   -- | To import a 'Message', we import all of its
 285   --   'InjuriesDetailListingPlayerListingXml's, which we have to dig
 286   --   out of its 'Listing's.
 287   --
 288   dbimport msg = do
 289     msg_id <- insert_xml msg
 290
 291     forM_ (xml_listings msg) $ \listing -> do
 292       l_id <- insert_xml_fk msg_id listing
 293       mapM_ (insert_xml_fk_ l_id) (xml_player_listings listing)
 294
 295     return ImportSucceeded
 296
 297
 298 mkPersist tsn_codegen_config [groundhog|
 299 - entity: InjuriesDetail
 300   dbName: injuries_detail
 301   constructors:
 302     - name: InjuriesDetail
 303       uniques:
 304         - name: unique_injuries_detail
 305           type: constraint
 306           # Prevent multiple imports of the same message.
 307           fields: [db_xml_file_id]
 308
 309 - entity: InjuriesDetailListing
 310   dbName: injuries_detail_listings
 311   constructors:
 312     - name: InjuriesDetailListing
 313       fields:
 314         - name: db_injuries_detail_id
 315           reference:
 316             onDelete: cascade
 317
 318 - entity: InjuriesDetailListingPlayerListing
 319   dbName: injuries_detail_listings_player_listings
 320   constructors:
 321     - name: InjuriesDetailListingPlayerListing
 322       fields:
 323         - name: db_injuries_detail_listings_id
 324           reference:
 325             onDelete: cascade
 326 |]
 327
 328
 329
 330 --
 331 -- Pickling
 332 --
 333
 334 -- | Convert 'InjuriesDetailListingPlayerListingXml's to/from XML.
 335 --
 336 pickle_player_listing :: PU InjuriesDetailListingPlayerListingXml
 337 pickle_player_listing =
 338   xpElem "PlayerListing" $
 339     xpWrap (from_tuple, to_tuple) $
 340     xp10Tuple (xpElem "TeamID" xpText)
 341               (xpElem "PlayerID" xpInt)
 342               (xpElem "Date" xp_date)
 343               (xpElem "Pos" xpText)
 344               (xpElem "Name" xpText)
 345               (xpElem "Injury" xpText)
 346               (xpElem "Status" xpText)
 347               (xpElem "Fantasy" $ xpOption xpText)
 348               (xpElem "Injured" xpPrim)
 349               (xpElem "Type" xpText)
 350   where
 351     from_tuple = uncurryN InjuriesDetailListingPlayerListingXml
 352     to_tuple pl = (xml_player_team_id pl,
 353                    xml_player_id pl,
 354                    xml_date pl,
 355                    xml_pos pl,
 356                    xml_name pl,
 357                    xml_injury pl,
 358                    xml_status pl,
 359                    xml_fantasy pl,
 360                    xml_injured pl,
 361                    xml_type pl)
 362
 363
 364 -- | Convert 'Listing's to/from XML.
 365 --
 366 pickle_listing :: PU InjuriesDetailListingXml
 367 pickle_listing =
 368   xpElem "Listing" $
 369     xpWrap (from_tuple, to_tuple) $
 370     xpTriple (xpElem "TeamID" xpText)
 371              (xpElem "FullName" xpText)
 372              (xpList pickle_player_listing)
 373   where
 374     from_tuple = uncurryN InjuriesDetailListingXml
 375     to_tuple l = (xml_team_id l,
 376                   xml_full_name l,
 377                   xml_player_listings l)
 378
 379
 380 -- | Convert 'Message's to/from XML.
 381 --
 382 pickle_message :: PU Message
 383 pickle_message =
 384   xpElem "message" $
 385     xpWrap (from_tuple, to_tuple) $
 386     xp6Tuple (xpElem "XML_File_ID" xpInt)
 387              (xpElem "heading" xpText)
 388              (xpElem "category" xpText)
 389              (xpElem "sport" xpText)
 390              (xpList pickle_listing)
 391              (xpElem "time_stamp" xp_time_stamp)
 392   where
 393     from_tuple = uncurryN Message
 394     to_tuple m = (xml_xml_file_id m,
 395                   xml_heading m,
 396                   xml_category m,
 397                   xml_sport m,
 398                   xml_listings m,
 399                   xml_time_stamp m)
 400
 401
 402 --
 403 -- Tasty Tests
 404 --
 405
 406 -- | A list of all tests for this module.
 407 --
 408 injuries_detail_tests :: TestTree
 409 injuries_detail_tests =
 410   testGroup
 411     "InjuriesDetail tests"
 412     [ test_on_delete_cascade,
 413       test_pickle_of_unpickle_is_identity,
 414       test_unpickle_succeeds ]
 415
 416
 417 -- | If we unpickle something and then pickle it, we should wind up
 418 --   with the same thing we started with. WARNING: success of this
 419 --   test does not mean that unpickling succeeded.
 420 --
 421 test_pickle_of_unpickle_is_identity :: TestTree
 422 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 423   [ check "pickle composed with unpickle is the identity"
 424           "test/xml/Injuries_Detail_XML.xml",
 425
 426     check "pickle composed with unpickle is the identity (non-int team_id)"
 427           "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
 428   where
 429     check desc path = testCase desc $ do
 430       (expected, actual) <- pickle_unpickle pickle_message path
 431       actual @?= expected
 432
 433
 434 -- | Make sure we can actually unpickle these things.
 435 --
 436 test_unpickle_succeeds :: TestTree
 437 test_unpickle_succeeds = testGroup "unpickle tests"
 438   [ check "unpickling succeeds"
 439           "test/xml/Injuries_Detail_XML.xml",
 440
 441     check "unpickling succeeds (non-int team_id)"
 442           "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
 443   where
 444     check desc path = testCase desc $ do
 445       actual <- unpickleable path pickle_message
 446       let expected = True
 447       actual @?= expected
 448
 449
 450 -- | Make sure everything gets deleted when we delete the top-level
 451 --   record.
 452 --
 453 test_on_delete_cascade :: TestTree
 454 test_on_delete_cascade = testGroup "cascading delete tests"
 455   [ check "delete of injuries_detail deletes its children"
 456           "test/xml/Injuries_Detail_XML.xml",
 457
 458     check "delete of injuries_detail deletes its children (non-int team_id)"
 459           "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
 460   where
 461     check desc path = testCase desc $ do
 462       inj <- unsafe_unpickle path pickle_message
 463       let a = undefined :: InjuriesDetail
 464       let b = undefined :: InjuriesDetailListing
 465       let c = undefined :: InjuriesDetailListingPlayerListing
 466       actual <- withSqliteConn ":memory:" $ runDbConn $ do
 467                   runMigration silentMigrationLogger $ do
 468                     migrate a
 469                     migrate b
 470                     migrate c
 471                   _ <- dbimport inj
 472                   deleteAll a
 473                   count_a <- countAll a
 474                   count_b <- countAll b
 475                   count_c <- countAll c
 476                   return $ count_a + count_b + count_c
 477       let expected = 0
 478       actual @?= expected