src/TSN/XML/InjuriesDetail.hs

   1 {-# LANGUAGE DeriveGeneric #-}
   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 "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 qualified GHC.Generics as GHC ( Generic )
  43 import Test.Tasty ( TestTree, testGroup )
  44 import Test.Tasty.HUnit ( (@?=), testCase )
  45 import Text.XML.HXT.Core (
  46   PU,
  47   xpTriple,
  48   xp6Tuple,
  49   xp10Tuple,
  50   xpElem,
  51   xpInt,
  52   xpList,
  53   xpOption,
  54   xpPrim,
  55   xpText,
  56   xpWrap )
  57
  58 -- Local imports.
  59 import Generics ( Generic(..), to_tuple )
  60 import TSN.Codegen ( tsn_codegen_config )
  61 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  62 import TSN.Picklers( xp_date, xp_time_stamp )
  63 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
  64 import Xml (
  65   Child(..),
  66   FromXml(..),
  67   FromXmlFk(..),
  68   ToDb(..),
  69   pickle_unpickle,
  70   unpickleable,
  71   unsafe_unpickle )
  72
  73
  74
  75 -- | The DTD to which this module corresponds. Used to invoke dbimport.
  76 --
  77 dtd :: String
  78 dtd = "Injuries_Detail_XML.dtd"
  79
  80
  81 --
  82 -- Data types
  83 --
  84
  85
  86 -- * InjuriesDetail/Message
  87
  88
  89 -- | XML representation of the top-level \<message\> element. These
  90 --   are not stored; the data type is used only for parsing.
  91 --
  92 data Message =
  93   Message {
  94     xml_xml_file_id :: Int,
  95     xml_heading :: String,
  96     xml_category :: String,
  97     xml_sport :: String,
  98     xml_listings :: [InjuriesDetailListingXml],
  99     xml_time_stamp :: UTCTime }
 100   deriving (Eq, GHC.Generic, Show)
 101
 102
 103 -- | For 'Generics.to_tuple'.
 104 --
 105 instance Generic Message
 106
 107
 108 -- | Database representation of a 'Message'.
 109 --
 110 data InjuriesDetail =
 111   InjuriesDetail {
 112     db_xml_file_id :: Int,
 113     db_sport :: String,
 114     db_time_stamp :: UTCTime }
 115   deriving (Eq, Show)
 116
 117 instance ToDb Message where
 118   -- | The database representation of a 'Message' is an
 119   --   'InjuriesDetail'.
 120   --
 121   type Db Message = InjuriesDetail
 122
 123 instance FromXml Message where
 124   -- | To convert a 'Message' into an 'InjuriesDetail', we simply drop
 125   --   a few fields.
 126   --
 127   from_xml Message{..} =
 128     InjuriesDetail {
 129       db_xml_file_id = xml_xml_file_id,
 130       db_sport = xml_sport,
 131       db_time_stamp = xml_time_stamp }
 132
 133
 134 -- | This allows us to insert the XML representation 'Message'
 135 --   directly.
 136 --
 137 instance XmlImport Message
 138
 139
 140
 141 -- * InjuriesDetailListing/InjuriesDetailListingXml
 142
 143 -- | Database representation of a \<Listing\> element. It has a
 144 --   foreign key pointing to its parent 'InjuriesDetail', and does not
 145 --   contain the list of 'xml_player_listings' (which get their own
 146 --   table).
 147 --
 148 data InjuriesDetailListing =
 149   InjuriesDetailListing {
 150     db_injuries_detail_id :: DefaultKey InjuriesDetail,
 151     db_team_id :: String,
 152     db_full_name :: String }
 153
 154
 155 -- | XML incarnation of a \<Listing\> element. We don't store these;
 156 --   the data type is used only for parsing.
 157 --
 158 data InjuriesDetailListingXml =
 159   InjuriesDetailListingXml {
 160     xml_team_id :: String, -- ^ TeamIDs are (apparently) three
 161                            --   characters long and not necessarily
 162                            --   numeric.
 163
 164     xml_full_name :: String, -- ^ Team full name
 165     xml_player_listings :: [InjuriesDetailListingPlayerListingXml] }
 166   deriving (Eq, GHC.Generic, Show)
 167
 168
 169 -- | For 'Generics.to_tuple'.
 170 --
 171 instance Generic InjuriesDetailListingXml
 172
 173
 174 instance ToDb InjuriesDetailListingXml where
 175   -- | The database analogue of an 'InjuriesDetailListingXml' is a
 176   --   'InjuriesDetailListing'.
 177   type Db InjuriesDetailListingXml = InjuriesDetailListing
 178
 179
 180 instance Child InjuriesDetailListingXml where
 181   -- | Each 'InjuriesDetailListingXml' is contained in an
 182   --   'InjuriesDetail'.
 183   type Parent InjuriesDetailListingXml = InjuriesDetail
 184
 185
 186 instance FromXmlFk InjuriesDetailListingXml where
 187   -- | Construct a 'InjuriesDetailListing' from a
 188   --   'InjuriesDetailListingXml' and a foreign key to a
 189   --   'InjuriesDetail'.
 190   --
 191   from_xml_fk fk InjuriesDetailListingXml{..} =
 192     InjuriesDetailListing {
 193       db_injuries_detail_id = fk,
 194       db_team_id = xml_team_id,
 195       db_full_name = xml_full_name }
 196
 197 -- | This allows us to insert the XML representation
 198 --   'InjuriesDetailListingXml' directly.
 199 --
 200 instance XmlImportFk InjuriesDetailListingXml
 201
 202
 203 -- * InjuriesDetailListingPlayerListing
 204
 205 -- | XML representation of a \<PlayerListing\>, the main type of
 206 --   element contains in Injuries_Detail_XML messages.
 207 --
 208 data InjuriesDetailListingPlayerListingXml =
 209   InjuriesDetailListingPlayerListingXml {
 210     xml_player_team_id :: String, -- ^ TeamIDs are (apparently) three
 211                                   --   characters long and not
 212                                   --   necessarily numeric. Postgres
 213                                   --   imposes no performance penalty
 214                                   --   on a lengthless text field, so
 215                                   --   we ignore the likely upper
 216                                   --   bound of three characters.
 217                                   --   We add the \"player\" to avoid conflict
 218                                   --   with 'InjuriesDetailListingXml'.
 219     xml_player_id :: Int,
 220     xml_date      :: UTCTime,
 221     xml_pos       :: String,
 222     xml_name      :: String,
 223     xml_injury    :: String,
 224     xml_status    :: String,
 225     xml_fantasy   :: Maybe String, -- ^ Nobody knows what this is.
 226     xml_injured     :: Bool,
 227     xml_type :: String }
 228   deriving (Eq, GHC.Generic, Show)
 229
 230
 231 -- | For 'Generics.to_tuple'.
 232 --
 233 instance Generic InjuriesDetailListingPlayerListingXml
 234
 235
 236 -- | Database representation of a
 237 --   'InjuriesDetailListingPlayerListingXml'. We drop the team_id
 238 --   because it's redundant.
 239 --
 240 data InjuriesDetailListingPlayerListing =
 241   InjuriesDetailListingPlayerListing {
 242     db_injuries_detail_listings_id :: DefaultKey InjuriesDetailListing,
 243     db_player_id :: Int,
 244     db_date      :: UTCTime,
 245     db_pos       :: String,
 246     db_name      :: String,
 247     db_injury    :: String,
 248     db_status    :: String,
 249     db_fantasy   :: Maybe String, -- ^ Nobody knows what this is.
 250     db_injured     :: Bool,
 251     db_type :: String }
 252
 253
 254 instance ToDb InjuriesDetailListingPlayerListingXml where
 255   -- | The DB analogue of a 'InjuriesDetailListingPlayerListingXml' is
 256   --   'InjuriesDetailListingPlayerListing'.
 257   type Db InjuriesDetailListingPlayerListingXml =
 258     InjuriesDetailListingPlayerListing
 259
 260
 261 instance Child InjuriesDetailListingPlayerListingXml where
 262   -- | Each 'InjuriesDetailListingPlayerListingXml' is contained in an
 263   --   'InjuriesDetailListing'.
 264   --
 265   type Parent InjuriesDetailListingPlayerListingXml = InjuriesDetailListing
 266
 267
 268 instance FromXmlFk InjuriesDetailListingPlayerListingXml where
 269   -- | To construct a 'InjuriesDetailListingPlayerListing' from a
 270   --   'InjuriesDetailListingPlayerListingXml' we need to supply a
 271   --   foreign key to an 'InjuriesDetailListing'.
 272   --
 273   from_xml_fk fk InjuriesDetailListingPlayerListingXml{..} =
 274     InjuriesDetailListingPlayerListing {
 275       db_injuries_detail_listings_id = fk,
 276       db_player_id = xml_player_id,
 277       db_date = xml_date,
 278       db_pos = xml_pos,
 279       db_name = xml_name,
 280       db_injury = xml_injury,
 281       db_status = xml_status,
 282       db_fantasy = xml_fantasy,
 283       db_injured = xml_injured,
 284       db_type = xml_type }
 285
 286 -- | This lets us insert the XML representation
 287 --   'InjuriesDetailListingPlayerListingXml' directly.
 288 --
 289 instance XmlImportFk InjuriesDetailListingPlayerListingXml
 290
 291
 292 --
 293 -- Database stuff
 294 --
 295
 296 instance DbImport Message where
 297   dbmigrate _ =
 298     run_dbmigrate $ do
 299       migrate (undefined :: InjuriesDetail)
 300       migrate (undefined :: InjuriesDetailListing)
 301       migrate (undefined :: InjuriesDetailListingPlayerListing)
 302
 303   -- | To import a 'Message', we import all of its
 304   --   'InjuriesDetailListingPlayerListingXml's, which we have to dig
 305   --   out of its 'Listing's.
 306   --
 307   dbimport msg = do
 308     msg_id <- insert_xml msg
 309
 310     forM_ (xml_listings msg) $ \listing -> do
 311       l_id <- insert_xml_fk msg_id listing
 312       mapM_ (insert_xml_fk_ l_id) (xml_player_listings listing)
 313
 314     return ImportSucceeded
 315
 316
 317 mkPersist tsn_codegen_config [groundhog|
 318 - entity: InjuriesDetail
 319   dbName: injuries_detail
 320   constructors:
 321     - name: InjuriesDetail
 322       uniques:
 323         - name: unique_injuries_detail
 324           type: constraint
 325           # Prevent multiple imports of the same message.
 326           fields: [db_xml_file_id]
 327
 328 - entity: InjuriesDetailListing
 329   dbName: injuries_detail_listings
 330   constructors:
 331     - name: InjuriesDetailListing
 332       fields:
 333         - name: db_injuries_detail_id
 334           reference:
 335             onDelete: cascade
 336
 337 - entity: InjuriesDetailListingPlayerListing
 338   dbName: injuries_detail_listings_player_listings
 339   constructors:
 340     - name: InjuriesDetailListingPlayerListing
 341       fields:
 342         - name: db_injuries_detail_listings_id
 343           reference:
 344             onDelete: cascade
 345 |]
 346
 347
 348
 349 --
 350 -- Pickling
 351 --
 352
 353 -- | Convert 'InjuriesDetailListingPlayerListingXml's to/from XML.
 354 --
 355 pickle_player_listing :: PU InjuriesDetailListingPlayerListingXml
 356 pickle_player_listing =
 357   xpElem "PlayerListing" $
 358     xpWrap (from_tuple, to_tuple) $
 359     xp10Tuple (xpElem "TeamID" xpText)
 360               (xpElem "PlayerID" xpInt)
 361               (xpElem "Date" xp_date)
 362               (xpElem "Pos" xpText)
 363               (xpElem "Name" xpText)
 364               (xpElem "Injury" xpText)
 365               (xpElem "Status" xpText)
 366               (xpElem "Fantasy" $ xpOption xpText)
 367               (xpElem "Injured" xpPrim)
 368               (xpElem "Type" xpText)
 369   where
 370     from_tuple = uncurryN InjuriesDetailListingPlayerListingXml
 371
 372
 373 -- | Convert 'Listing's to/from XML.
 374 --
 375 pickle_listing :: PU InjuriesDetailListingXml
 376 pickle_listing =
 377   xpElem "Listing" $
 378     xpWrap (from_tuple, to_tuple) $
 379     xpTriple (xpElem "TeamID" xpText)
 380              (xpElem "FullName" xpText)
 381              (xpList pickle_player_listing)
 382   where
 383     from_tuple = uncurryN InjuriesDetailListingXml
 384
 385
 386 -- | Convert 'Message's to/from XML.
 387 --
 388 pickle_message :: PU Message
 389 pickle_message =
 390   xpElem "message" $
 391     xpWrap (from_tuple, to_tuple) $
 392     xp6Tuple (xpElem "XML_File_ID" xpInt)
 393              (xpElem "heading" xpText)
 394              (xpElem "category" xpText)
 395              (xpElem "sport" xpText)
 396              (xpList pickle_listing)
 397              (xpElem "time_stamp" xp_time_stamp)
 398   where
 399     from_tuple = uncurryN Message
 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