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