src/TSN/XML/JFile.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 \"jfilexml.dtd\". There's a top-level
   9 --   \<message\>, containing a \<gamelist\>, containing
  10 --   \<game\>s. Those games contain a bunch of other stuff. The
  11 --   \<gamelist\> is pretty irrelevant; we ignore it and pretend that
  12 --   a message contains a bunch of games.
  13 --
  14 module TSN.XML.JFile (
  15   dtd,
  16   pickle_message,
  17   -- * Tests
  18   jfile_tests,
  19   -- * WARNING: these are private but exported to silence warnings
  20   JFileConstructor(..),
  21   JFileGameConstructor(..),
  22   JFileGame_TeamConstructor(..) )
  23 where
  24
  25 -- System imports
  26 import Control.Monad ( forM_ )
  27 import Data.List ( intercalate )
  28 import Data.String.Utils ( split )
  29 import Data.Time ( UTCTime(..) )
  30 import Data.Tuple.Curry ( uncurryN )
  31 import Database.Groundhog (
  32   countAll,
  33   deleteAll,
  34   insert_,
  35   migrate,
  36   runMigration,
  37   silentMigrationLogger )
  38 import Database.Groundhog.Core ( DefaultKey )
  39 import Database.Groundhog.Generic ( runDbConn )
  40 import Database.Groundhog.Sqlite ( withSqliteConn )
  41 import Database.Groundhog.TH (
  42   groundhog,
  43   mkPersist )
  44 import Test.Tasty ( TestTree, testGroup )
  45 import Test.Tasty.HUnit ( (@?=), testCase )
  46 import Text.XML.HXT.Core (
  47   PU,
  48   xpTriple,
  49   xp6Tuple,
  50   xp14Tuple,
  51   xp19Tuple,
  52   xpAttr,
  53   xpElem,
  54   xpInt,
  55   xpList,
  56   xpOption,
  57   xpPair,
  58   xpPrim,
  59   xpText,
  60   xpText0,
  61   xpWrap )
  62
  63
  64 -- Local imports
  65 import TSN.Codegen ( tsn_codegen_config )
  66 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  67 import TSN.Picklers (
  68   xp_date,
  69   xp_date_padded,
  70   xp_datetime,
  71   xp_time,
  72   xp_time_dots,
  73   xp_time_stamp )
  74 import TSN.Team ( Team(..) )
  75 import TSN.XmlImport (
  76   XmlImport(..),
  77   XmlImportFk(..) )
  78 import Xml (
  79   FromXml(..),
  80   FromXmlFk(..),
  81   ToDb(..),
  82   pickle_unpickle,
  83   unpickleable,
  84   unsafe_unpickle )
  85
  86
  87
  88 -- | The DTD to which this module corresponds. Used to invoke dbimport.
  89 --
  90 dtd :: String
  91 dtd = "jfilexml.dtd"
  92
  93 --
  94 -- DB/XML data types
  95 --
  96
  97 -- * JFile/Message
  98
  99 -- | Database representation of a 'Message'.
 100 --
 101 data JFile =
 102   JFile {
 103     db_xml_file_id :: Int,
 104     db_heading :: String,
 105     db_category :: String,
 106     db_sport :: String,
 107     db_time_stamp :: UTCTime }
 108
 109
 110
 111 -- | XML Representation of an 'JFile'.
 112 --
 113 data Message =
 114   Message {
 115     xml_xml_file_id :: Int,
 116     xml_heading :: String,
 117     xml_category :: String,
 118     xml_sport :: String,
 119     xml_gamelist :: JFileGameListXml,
 120     xml_time_stamp :: UTCTime }
 121   deriving (Eq, Show)
 122
 123
 124 instance ToDb Message where
 125   -- | The database analogue of a 'Message' is a 'JFile'.
 126   --
 127   type Db Message = JFile
 128
 129
 130 -- | The 'FromXml' instance for 'Message' is required for the
 131 --   'XmlImport' instance.
 132 --
 133 instance FromXml Message where
 134   -- | To convert a 'Message' to an 'JFile', we just drop
 135   --   the 'xml_gamelist'.
 136   --
 137   from_xml Message{..} =
 138     JFile {
 139       db_xml_file_id = xml_xml_file_id,
 140       db_heading = xml_heading,
 141       db_category = xml_category,
 142       db_sport = xml_sport,
 143       db_time_stamp = xml_time_stamp }
 144
 145
 146 -- | This allows us to insert the XML representation 'Message'
 147 --   directly.
 148 --
 149 instance XmlImport Message
 150
 151
 152 -- * JFileGameAwayTeamXml / JFileGameHomeTeamXml
 153
 154 -- | The XML representation of a JFile away team. Its corresponding
 155 --   database representation (along with that of the home team) is a
 156 --   TSN.Team, but their XML representations are different.
 157 data JFileGameAwayTeamXml =
 158   JFileGameAwayTeamXml {
 159     away_team_id :: String,
 160     away_team_abbreviation :: Maybe String,
 161     away_team_name :: Maybe String }
 162   deriving (Eq, Show)
 163
 164 instance ToDb JFileGameAwayTeamXml where
 165   -- | The database analogue of an 'JFileGameAwayTeamXml' is
 166   --   a 'Team'.
 167   --
 168   type Db JFileGameAwayTeamXml = Team
 169
 170 instance FromXml JFileGameAwayTeamXml where
 171   -- | To convert a 'JFileGameAwayTeamXml' to a 'Team', we do just
 172   --   about nothing.
 173   --
 174   from_xml JFileGameAwayTeamXml{..} =
 175     Team {
 176       team_id = away_team_id,
 177       team_abbreviation = away_team_abbreviation,
 178       team_name  = away_team_name }
 179
 180 -- | Allow us to import JFileGameAwayTeamXml directly.
 181 instance XmlImport JFileGameAwayTeamXml
 182
 183
 184 -- | The XML representation of a JFile home team. Its corresponding
 185 --   database representation (along with that of the away team) is a
 186 --   TSN.Team, but their XML representations are different.
 187 data JFileGameHomeTeamXml =
 188   JFileGameHomeTeamXml {
 189     home_team_id :: String,
 190     home_team_abbreviation :: Maybe String,
 191     home_team_name :: Maybe String }
 192   deriving (Eq, Show)
 193
 194 instance ToDb JFileGameHomeTeamXml where
 195   -- | The database analogue of an 'JFileGameHomeTeamXml' is
 196   --   a 'Team'.
 197   --
 198   type Db JFileGameHomeTeamXml = Team
 199
 200 instance FromXml JFileGameHomeTeamXml where
 201   -- | To convert a 'JFileGameHomeTeamXml' to a 'Team', we do just
 202   --   about nothing.
 203   --
 204   from_xml JFileGameHomeTeamXml{..} =
 205     Team {
 206       team_id = home_team_id,
 207       team_abbreviation = home_team_abbreviation,
 208       team_name  = home_team_name }
 209
 210 -- | Allow us to import JFileGameHomeTeamXml directly.
 211 instance XmlImport JFileGameHomeTeamXml
 212
 213
 214 -- * JFileGame/JFileGameXml
 215
 216 -- | This is an embedded type within each JFileGame. It has its own
 217 --   element, \<Odds_Info\>, but there's only one of them per game. So
 218 --   essentially all of these fields belong to a 'JFileGame'. Aaaannnd
 219 --   most of them are redundant. We'll (un)pickle them for good
 220 --   measure, but in the conversion to the database type, we can drop
 221 --   all of the redundant information.
 222 --
 223 --   All of these are optional because TSN does actually leave the
 224 --   whole thing empty from time to time.
 225 --
 226 data JFileGameOddsInfo =
 227   JFileGameOddsInfo {
 228     db_list_date :: Maybe UTCTime,
 229     db_home_team_id :: Maybe String, -- redundant (Team)
 230     db_away_team_id :: Maybe String, -- redundant (Team)
 231     db_home_abbr :: Maybe String, -- redundant (Team)
 232     db_away_abbr :: Maybe String, -- redundant (Team)
 233     db_home_team_name :: Maybe String, -- redundant (Team)
 234     db_away_team_name :: Maybe String, -- redundant (Team)
 235     db_home_starter :: Maybe String,
 236     db_away_starter :: Maybe String,
 237     db_game_date :: Maybe UTCTime, -- redundant (JFileGame)
 238     db_home_game_key :: Maybe Int,
 239     db_away_game_key :: Maybe Int,
 240     db_current_timestamp :: Maybe UTCTime,
 241     db_live :: Maybe Bool,
 242     db_notes :: String }
 243   deriving (Eq, Show)
 244
 245
 246 -- | Another embedded type within 'JFileGame'. These look like,
 247 --   \<status numeral=\"4\"\>FINAL\</status\> within the XML, but
 248 --   they're in one-to-one correspondence with the games.
 249 --
 250 data JFileGameStatus =
 251   JFileGameStatus {
 252     db_status_numeral :: Int,
 253     db_status  :: Maybe String }
 254   deriving (Eq, Show)
 255
 256
 257 -- | Database representation of a \<game\> contained within a
 258 --   \<message\>, and, implicitly, a \<gamelist\>.
 259 --
 260 --   We've left out the game date, opting instead to combine the
 261 --   date/time into the 'db_game_time' field.
 262 --
 263 data JFileGame =
 264   JFileGame {
 265     db_jfile_id :: DefaultKey JFile,
 266     db_game_id :: Int,
 267     db_schedule_id :: Int,
 268     db_odds_info :: JFileGameOddsInfo,
 269     db_season_type :: Maybe String,
 270     db_game_time :: UTCTime,
 271     db_vleague :: Maybe String,
 272     db_hleague :: Maybe String,
 273     db_vscore :: Int,
 274     db_hscore :: Int,
 275     db_time_remaining :: Maybe String,
 276     db_game_status :: JFileGameStatus }
 277
 278
 279 -- | XML representation of a \<game\> contained within a \<message\>,
 280 --   and a \<gamelist\>. The Away/Home teams seem to coincide with
 281 --   those of 'OddsGame', so we're reusing the DB type via the common
 282 --   'TSN.Team' structure. But the XML types are different, because
 283 --   they have different picklers!
 284 --
 285 data JFileGameXml =
 286   JFileGameXml {
 287     xml_game_id :: Int,
 288     xml_schedule_id :: Int,
 289     xml_odds_info :: JFileGameOddsInfo,
 290     xml_season_type :: Maybe String,
 291     xml_game_date :: UTCTime,
 292     xml_game_time :: UTCTime,
 293     xml_vteam :: JFileGameAwayTeamXml,
 294     xml_vleague :: Maybe String,
 295     xml_hteam :: JFileGameHomeTeamXml,
 296     xml_hleague :: Maybe String,
 297     xml_vscore :: Int,
 298     xml_hscore :: Int,
 299     xml_time_remaining :: Maybe String,
 300     xml_game_status :: JFileGameStatus }
 301   deriving (Eq, Show)
 302
 303
 304 -- * JFileGameListXml
 305
 306 -- | The XML representation of \<message\> -> \<gamelist\>. This
 307 --   element serves only to contain \<game\>s, so we don't store the
 308 --   intermediate table in the database.
 309 --
 310 newtype JFileGameListXml =
 311   JFileGameListXml {
 312     xml_games ::
 313       [JFileGameXml] }
 314   deriving (Eq, Show)
 315
 316
 317 instance ToDb JFileGameXml where
 318   -- | The database analogue of an 'JFileGameXml' is
 319   --   an 'JFileGame'.
 320   --
 321   type Db JFileGameXml = JFileGame
 322
 323 instance FromXmlFk JFileGameXml where
 324   -- | Each 'JFileGameXml' is contained in (i.e. has a foreign key to)
 325   --   a 'JFile'.
 326   --
 327   type Parent JFileGameXml = JFile
 328
 329   -- | To convert an 'JFileGameXml' to an 'JFileGame', we add the
 330   --   foreign key and drop the 'xml_vteam'/'xml_hteam'. We also mash
 331   --   the date/time together into one field.
 332   --
 333   from_xml_fk fk JFileGameXml{..} =
 334     JFileGame {
 335       db_jfile_id = fk,
 336       db_game_id = xml_game_id,
 337       db_schedule_id = xml_schedule_id,
 338       db_odds_info = xml_odds_info,
 339       db_season_type = xml_season_type,
 340       db_game_time = make_game_time xml_game_date xml_game_time,
 341       db_vleague = xml_vleague,
 342       db_hleague = xml_hleague,
 343       db_vscore = xml_vscore,
 344       db_hscore = xml_hscore,
 345       db_time_remaining = xml_time_remaining,
 346       db_game_status = xml_game_status }
 347     where
 348       -- | Make the database \"game time\" from the XML
 349       --   date/time. Simply take the day part from one and the time
 350       --   from the other.
 351       --
 352       make_game_time d t = UTCTime (utctDay d) (utctDayTime t)
 353
 354
 355 -- | This allows us to insert the XML representation
 356 --   'JFileGameXml' directly.
 357 --
 358 instance XmlImportFk JFileGameXml
 359
 360
 361 -- * JFileGame_Team
 362
 363 -- | Database mapping between games and their home/away teams.
 364 --
 365 data JFileGame_Team =
 366   JFileGame_Team {
 367     jgt_jfile_games_id :: DefaultKey JFileGame,
 368     jgt_away_team_id  :: DefaultKey Team,
 369     jgt_home_team_id  :: DefaultKey Team }
 370
 371
 372 ---
 373 --- Database stuff.
 374 ---
 375
 376 instance DbImport Message where
 377   dbmigrate _ =
 378     run_dbmigrate $ do
 379       migrate (undefined :: Team)
 380       migrate (undefined :: JFile)
 381       migrate (undefined :: JFileGame)
 382       migrate (undefined :: JFileGame_Team)
 383
 384   dbimport m = do
 385     -- Insert the top-level message
 386     msg_id <- insert_xml m
 387
 388     -- Now loop through the message's games
 389     forM_ (xml_games $ xml_gamelist m) $ \game -> do
 390
 391       -- Next, we insert the home and away teams. We do this before
 392       -- inserting the game itself because the game has two foreign keys
 393       -- pointing to "teams".
 394       away_team_id <- insert_xml_or_select (xml_vteam game)
 395       home_team_id <- insert_xml_or_select (xml_hteam game)
 396
 397       game_id <- insert_xml_fk msg_id game
 398
 399       -- Insert a record into jfile_games__teams mapping the
 400       -- home/away teams to this game. Use the full record syntax
 401       -- because the types would let us mix up the home/away teams.
 402       insert_ JFileGame_Team {
 403                 jgt_jfile_games_id = game_id,
 404                 jgt_away_team_id = away_team_id,
 405                 jgt_home_team_id = home_team_id }
 406
 407
 408     return ImportSucceeded
 409
 410
 411 mkPersist tsn_codegen_config [groundhog|
 412 - entity: JFile
 413   dbName: jfile
 414   constructors:
 415     - name: JFile
 416       uniques:
 417         - name: unique_jfile
 418           type: constraint
 419           # Prevent multiple imports of the same message.
 420           fields: [db_xml_file_id]
 421
 422 - embedded: JFileGameStatus
 423   fields:
 424     - name: db_status_numeral
 425       dbName: status_numeral
 426     - name: db_status
 427       dbName: status
 428
 429 # Many of the JFileGameOddsInfo fields are redundant and have
 430 # been left out.
 431 - embedded: JFileGameOddsInfo
 432   fields:
 433     - name: db_list_date
 434       dbName: list_date
 435     - name: db_home_starter
 436       dbName: home_starter
 437     - name: db_home_game_key
 438       dbName: home_game_key
 439     - name: db_away_game_key
 440       dbName: away_game_key
 441     - name: db_current_timestamp
 442       dbName: current_timestamp
 443     - name: db_live
 444       dbName: live
 445     - name: db_notes
 446       dbName: notes
 447
 448 - entity: JFileGame
 449   dbName: jfile_games
 450   constructors:
 451     - name: JFileGame
 452       fields:
 453         - name: db_jfile_id
 454           reference:
 455             onDelete: cascade
 456         - name: db_odds_info
 457           embeddedType:
 458             - {name: list_date, dbName: list_date}
 459             - {name: home_starter, dbName: home_starter}
 460             - {name: away_starter, dbName: away_starter}
 461             - {name: home_game_key, dbName: home_game_key}
 462             - {name: away_game_key, dbName: away_game_key}
 463             - {name: current_timestamp, dbName: current_timestamp}
 464             - {name: live, dbName: live}
 465             - {name: notes, dbName: notes}
 466         - name: db_game_status
 467           embeddedType:
 468             - {name: status_numeral, dbName: status_numeral}
 469             - {name: status, dbName: status}
 470
 471 - entity: JFileGame_Team
 472   dbName: jfile_games__teams
 473   constructors:
 474     - name: JFileGame_Team
 475       fields:
 476         - name: jgt_jfile_games_id
 477           reference:
 478             onDelete: cascade
 479         - name: jgt_away_team_id
 480           reference:
 481             onDelete: cascade
 482         - name: jgt_home_team_id
 483           reference:
 484             onDelete: cascade
 485 |]
 486
 487
 488
 489 ---
 490 --- Pickling
 491 ---
 492
 493 -- | Pickler for the top-level 'Message'.
 494 --
 495 pickle_message :: PU Message
 496 pickle_message =
 497   xpElem "message" $
 498     xpWrap (from_tuple, to_tuple) $
 499     xp6Tuple (xpElem "XML_File_ID" xpInt)
 500              (xpElem "heading" xpText)
 501              (xpElem "category" xpText)
 502              (xpElem "sport" xpText)
 503              pickle_gamelist
 504              (xpElem "time_stamp" xp_time_stamp)
 505   where
 506     from_tuple = uncurryN Message
 507     to_tuple m = (xml_xml_file_id m,
 508                   xml_heading m,
 509                   xml_category m,
 510                   xml_sport m,
 511                   xml_gamelist m,
 512                   xml_time_stamp m)
 513
 514 pickle_gamelist :: PU JFileGameListXml
 515 pickle_gamelist =
 516   xpElem "gamelist" $
 517     xpWrap (to_result, from_result) $ xpList pickle_game
 518   where
 519     to_result = JFileGameListXml
 520     from_result = xml_games
 521
 522
 523
 524
 525 pickle_game :: PU JFileGameXml
 526 pickle_game =
 527   xpElem "game" $
 528     xpWrap (from_tuple, to_tuple) $
 529     xp14Tuple (xpElem "game_id" xpInt)
 530               (xpElem "schedule_id" xpInt)
 531               pickle_odds_info
 532               (xpElem "seasontype" (xpOption xpText))
 533               (xpElem "Game_Date" xp_date_padded)
 534               (xpElem "Game_Time" xp_time)
 535               pickle_away_team
 536               (xpOption $ xpElem "vleague" xpText)
 537               pickle_home_team
 538               (xpOption $ xpElem "hleague" xpText)
 539               (xpElem "vscore" xpInt)
 540               (xpElem "hscore" xpInt)
 541               (xpOption $ xpElem "time_r" xpText)
 542               pickle_status
 543   where
 544     from_tuple = uncurryN JFileGameXml
 545     to_tuple m = (xml_game_id m,
 546                   xml_schedule_id m,
 547                   xml_odds_info m,
 548                   xml_season_type m,
 549                   xml_game_date m,
 550                   xml_game_time m,
 551                   xml_vteam m,
 552                   xml_vleague m,
 553                   xml_hteam m,
 554                   xml_hleague m,
 555                   xml_vscore m,
 556                   xml_hscore m,
 557                   xml_time_remaining m,
 558                   xml_game_status m)
 559
 560 pickle_odds_info :: PU JFileGameOddsInfo
 561 pickle_odds_info =
 562   xpElem "Odds_Info" $
 563     xpWrap (from_tuple, to_tuple) $
 564     xp19Tuple (xpElem "ListDate" (xpOption xp_date))
 565               (xpElem "HomeTeamID" (xpOption xpText))
 566               (xpElem "AwayTeamID" (xpOption xpText))
 567               (xpElem "HomeAbbr" (xpOption xpText))
 568               (xpElem "AwayAbbr" (xpOption xpText))
 569               (xpElem "HomeTeamName" (xpOption xpText))
 570               (xpElem "AwayTeamName" (xpOption xpText))
 571               (xpElem "HStarter" (xpOption xpText))
 572               (xpElem "AStarter" (xpOption xpText))
 573               (xpElem "GameDate" (xpOption xp_datetime))
 574               (xpElem "HGameKey" (xpOption xpInt))
 575               (xpElem "AGameKey" (xpOption xpInt))
 576               (xpElem "CurrentTimeStamp" (xpOption xp_time_dots))
 577               (xpElem "Live" (xpOption xpPrim))
 578               (xpElem "Notes1" xpText0)
 579               (xpElem "Notes2" xpText0)
 580               (xpElem "Notes3" xpText0)
 581               (xpElem "Notes4" xpText0)
 582               (xpElem "Notes5" xpText0)
 583   where
 584     from_tuple (x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,n1,n2,n3,n4,n5) =
 585       JFileGameOddsInfo x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 notes
 586       where
 587         notes = intercalate "\n" [n1,n2,n3,n4,n5]
 588
 589     to_tuple o = (db_list_date o,
 590                   db_home_team_id o,
 591                   db_away_team_id o,
 592                   db_home_abbr o,
 593                   db_away_abbr o,
 594                   db_home_team_name o,
 595                   db_away_team_name o,
 596                   db_home_starter o,
 597                   db_away_starter o,
 598                   db_game_date o,
 599                   db_home_game_key o,
 600                   db_away_game_key o,
 601                   db_current_timestamp o,
 602                   db_live o,
 603                   n1,n2,n3,n4,n5)
 604       where
 605         note_lines = split "\n" (db_notes o)
 606         n1 = case note_lines of
 607                (notes1:_) -> notes1
 608                _          -> ""
 609         n2 = case note_lines of
 610                (_:notes2:_) -> notes2
 611                _            -> ""
 612         n3 = case note_lines of
 613                (_:_:notes3:_) -> notes3
 614                _              -> ""
 615         n4 = case note_lines of
 616                (_:_:_:notes4:_) -> notes4
 617                _                -> ""
 618         n5 = case note_lines of
 619                (_:_:_:_:notes5:_) -> notes5
 620                _                  -> ""
 621
 622 pickle_home_team :: PU JFileGameHomeTeamXml
 623 pickle_home_team =
 624   xpElem "hteam" $
 625     xpWrap (from_tuple, to_tuple) $
 626     xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text.
 627              (xpAttr "abbr" (xpOption xpText)) -- Some are blank
 628              (xpOption xpText) -- Yup, some are nameless
 629   where
 630     from_tuple = uncurryN JFileGameHomeTeamXml
 631     to_tuple t = (home_team_id t,
 632                   home_team_abbreviation t,
 633                   home_team_name t)
 634
 635
 636 pickle_away_team :: PU JFileGameAwayTeamXml
 637 pickle_away_team =
 638   xpElem "vteam" $
 639     xpWrap (from_tuple, to_tuple) $
 640     xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text.
 641              (xpAttr "abbr" (xpOption xpText)) -- Some are blank
 642              (xpOption xpText) -- Yup, some are nameless
 643   where
 644     from_tuple = uncurryN JFileGameAwayTeamXml
 645     to_tuple t = (away_team_id t,
 646                   away_team_abbreviation t,
 647                   away_team_name t)
 648
 649
 650 pickle_status :: PU JFileGameStatus
 651 pickle_status =
 652   xpElem "status" $
 653     xpWrap (from_tuple, to_tuple) $
 654     xpPair (xpAttr "numeral" xpInt)
 655            (xpOption xpText)
 656   where
 657     from_tuple = uncurry JFileGameStatus
 658     to_tuple s = (db_status_numeral s,
 659                   db_status s)
 660
 661
 662
 663 --
 664 -- Tasty Tests
 665 --
 666
 667 -- | A list of all tests for this module.
 668 --
 669 jfile_tests :: TestTree
 670 jfile_tests =
 671   testGroup
 672     "JFile tests"
 673     [ test_on_delete_cascade,
 674       test_pickle_of_unpickle_is_identity,
 675       test_unpickle_succeeds ]
 676
 677
 678 -- | If we unpickle something and then pickle it, we should wind up
 679 --   with the same thing we started with. WARNING: success of this
 680 --   test does not mean that unpickling succeeded.
 681 --
 682 test_pickle_of_unpickle_is_identity :: TestTree
 683 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 684   [ check "pickle composed with unpickle is the identity"
 685           "test/xml/jfilexml.xml",
 686     check "pickle composed with unpickle is the identity (missing fields)"
 687           "test/xml/jfilexml-missing-fields.xml" ]
 688   where
 689     check desc path = testCase desc $ do
 690       (expected, actual) <- pickle_unpickle pickle_message path
 691       actual @?= expected
 692
 693
 694
 695 -- | Make sure we can actually unpickle these things.
 696 --
 697 test_unpickle_succeeds :: TestTree
 698 test_unpickle_succeeds = testGroup "unpickle tests"
 699   [ check "unpickling succeeds" "test/xml/jfilexml.xml",
 700     check "unpickling succeeds (missing fields)"
 701           "test/xml/jfilexml-missing-fields.xml" ]
 702   where
 703     check desc path = testCase desc $ do
 704     actual <- unpickleable path pickle_message
 705
 706     let expected = True
 707     actual @?= expected
 708
 709
 710
 711 -- | Make sure everything gets deleted when we delete the top-level
 712 --   record.
 713 --
 714 test_on_delete_cascade :: TestTree
 715 test_on_delete_cascade = testGroup "cascading delete tests"
 716   [ check "deleting auto_racing_results deletes its children"
 717           "test/xml/jfilexml.xml"
 718           20,
 719     check "deleting auto_racing_results deletes its children (missing fields)"
 720           "test/xml/jfilexml-missing-fields.xml"
 721           44 ]
 722   where
 723     check desc path expected = testCase desc $ do
 724       results <- unsafe_unpickle path pickle_message
 725       let a = undefined :: Team
 726       let b = undefined :: JFile
 727       let c = undefined :: JFileGame
 728       let d = undefined :: JFileGame_Team
 729
 730       actual <- withSqliteConn ":memory:" $ runDbConn $ do
 731                   runMigration silentMigrationLogger $ do
 732                     migrate a
 733                     migrate b
 734                     migrate c
 735                     migrate d
 736                   _ <- dbimport results
 737                   deleteAll b
 738                   count_a <- countAll a
 739                   count_b <- countAll b
 740                   count_c <- countAll c
 741                   count_d <- countAll d
 742                   return $ sum [count_a, count_b, count_c, count_d]
 743       actual @?= expected