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