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