src/TSN/XML/InjuriesDetail.hs

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