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