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