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       abbreviation = away_team_abbreviation,
 178       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       abbreviation = home_team_abbreviation,
 208       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       -- First insert the game, keyed to the "jfile",
 391       game_id <- insert_xml_fk msg_id game
 392
 393       -- Next, we insert the home and away 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       -- Insert a record into jfile_games__teams mapping the
 398       -- home/away teams to this game. Use the full record syntax
 399       -- because the types would let us mix up the home/away teams.
 400       insert_ JFileGame_Team {
 401                 jgt_jfile_games_id = game_id,
 402                 jgt_away_team_id = away_team_id,
 403                 jgt_home_team_id = home_team_id }
 404
 405
 406     return ImportSucceeded
 407
 408
 409 mkPersist tsn_codegen_config [groundhog|
 410 - entity: JFile
 411   dbName: jfile
 412   constructors:
 413     - name: JFile
 414       uniques:
 415         - name: unique_jfile
 416           type: constraint
 417           # Prevent multiple imports of the same message.
 418           fields: [db_xml_file_id]
 419
 420 - embedded: JFileGameStatus
 421   fields:
 422     - name: db_status_numeral
 423       dbName: status_numeral
 424     - name: db_status
 425       dbName: status
 426
 427 # Many of the JFileGameOddsInfo fields are redundant and have
 428 # been left out.
 429 - embedded: JFileGameOddsInfo
 430   fields:
 431     - name: db_list_date
 432       dbName: list_date
 433     - name: db_home_starter
 434       dbName: home_starter
 435     - name: db_home_game_key
 436       dbName: home_game_key
 437     - name: db_away_game_key
 438       dbName: away_game_key
 439     - name: db_current_timestamp
 440       dbName: current_timestamp
 441     - name: db_live
 442       dbName: live
 443     - name: db_notes
 444       dbName: notes
 445
 446 - entity: JFileGame
 447   dbName: jfile_games
 448   constructors:
 449     - name: JFileGame
 450       fields:
 451         - name: db_jfile_id
 452           reference:
 453             onDelete: cascade
 454         - name: db_odds_info
 455           embeddedType:
 456             - {name: list_date, dbName: list_date}
 457             - {name: home_starter, dbName: home_starter}
 458             - {name: away_starter, dbName: away_starter}
 459             - {name: home_game_key, dbName: home_game_key}
 460             - {name: away_game_key, dbName: away_game_key}
 461             - {name: current_timestamp, dbName: current_timestamp}
 462             - {name: live, dbName: live}
 463             - {name: notes, dbName: notes}
 464         - name: db_game_status
 465           embeddedType:
 466             - {name: status_numeral, dbName: status_numeral}
 467             - {name: status, dbName: status}
 468
 469 - entity: JFileGame_Team
 470   dbName: jfile_games__teams
 471   constructors:
 472     - name: JFileGame_Team
 473       fields:
 474         - name: jgt_jfile_games_id
 475           reference:
 476             onDelete: cascade
 477         - name: jgt_away_team_id
 478           reference:
 479             onDelete: cascade
 480         - name: jgt_home_team_id
 481           reference:
 482             onDelete: cascade
 483 |]
 484
 485
 486
 487 ---
 488 --- Pickling
 489 ---
 490
 491 -- | Pickler for the top-level 'Message'.
 492 --
 493 pickle_message :: PU Message
 494 pickle_message =
 495   xpElem "message" $
 496     xpWrap (from_tuple, to_tuple) $
 497     xp6Tuple (xpElem "XML_File_ID" xpInt)
 498              (xpElem "heading" xpText)
 499              (xpElem "category" xpText)
 500              (xpElem "sport" xpText)
 501              pickle_gamelist
 502              (xpElem "time_stamp" xp_time_stamp)
 503   where
 504     from_tuple = uncurryN Message
 505     to_tuple m = (xml_xml_file_id m,
 506                   xml_heading m,
 507                   xml_category m,
 508                   xml_sport m,
 509                   xml_gamelist m,
 510                   xml_time_stamp m)
 511
 512 pickle_gamelist :: PU JFileGameListXml
 513 pickle_gamelist =
 514   xpElem "gamelist" $
 515     xpWrap (to_result, from_result) $ xpList pickle_game
 516   where
 517     to_result = JFileGameListXml
 518     from_result = xml_games
 519
 520
 521
 522
 523 pickle_game :: PU JFileGameXml
 524 pickle_game =
 525   xpElem "game" $
 526     xpWrap (from_tuple, to_tuple) $
 527     xp14Tuple (xpElem "game_id" xpInt)
 528               (xpElem "schedule_id" xpInt)
 529               pickle_odds_info
 530               (xpElem "seasontype" (xpOption xpText))
 531               (xpElem "Game_Date" xp_date_padded)
 532               (xpElem "Game_Time" xp_time)
 533               pickle_away_team
 534               (xpOption $ xpElem "vleague" xpText)
 535               pickle_home_team
 536               (xpOption $ xpElem "hleague" xpText)
 537               (xpElem "vscore" xpInt)
 538               (xpElem "hscore" xpInt)
 539               (xpOption $ xpElem "time_r" xpText)
 540               pickle_status
 541   where
 542     from_tuple = uncurryN JFileGameXml
 543     to_tuple m = (xml_game_id m,
 544                   xml_schedule_id m,
 545                   xml_odds_info m,
 546                   xml_season_type m,
 547                   xml_game_date m,
 548                   xml_game_time m,
 549                   xml_vteam m,
 550                   xml_vleague m,
 551                   xml_hteam m,
 552                   xml_hleague m,
 553                   xml_vscore m,
 554                   xml_hscore m,
 555                   xml_time_remaining m,
 556                   xml_game_status m)
 557
 558 pickle_odds_info :: PU JFileGameOddsInfo
 559 pickle_odds_info =
 560   xpElem "Odds_Info" $
 561     xpWrap (from_tuple, to_tuple) $
 562     xp19Tuple (xpElem "ListDate" (xpOption xp_date))
 563               (xpElem "HomeTeamID" (xpOption xpText))
 564               (xpElem "AwayTeamID" (xpOption xpText))
 565               (xpElem "HomeAbbr" (xpOption xpText))
 566               (xpElem "AwayAbbr" (xpOption xpText))
 567               (xpElem "HomeTeamName" (xpOption xpText))
 568               (xpElem "AwayTeamName" (xpOption xpText))
 569               (xpElem "HStarter" (xpOption xpText))
 570               (xpElem "AStarter" (xpOption xpText))
 571               (xpElem "GameDate" (xpOption xp_datetime))
 572               (xpElem "HGameKey" (xpOption xpInt))
 573               (xpElem "AGameKey" (xpOption xpInt))
 574               (xpElem "CurrentTimeStamp" (xpOption xp_time_dots))
 575               (xpElem "Live" (xpOption xpPrim))
 576               (xpElem "Notes1" xpText0)
 577               (xpElem "Notes2" xpText0)
 578               (xpElem "Notes3" xpText0)
 579               (xpElem "Notes4" xpText0)
 580               (xpElem "Notes5" xpText0)
 581   where
 582     from_tuple (x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,n1,n2,n3,n4,n5) =
 583       JFileGameOddsInfo x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 notes
 584       where
 585         notes = intercalate "\n" [n1,n2,n3,n4,n5]
 586
 587     to_tuple o = (db_list_date o,
 588                   db_home_team_id o,
 589                   db_away_team_id o,
 590                   db_home_abbr o,
 591                   db_away_abbr o,
 592                   db_home_team_name o,
 593                   db_away_team_name o,
 594                   db_home_starter o,
 595                   db_away_starter o,
 596                   db_game_date o,
 597                   db_home_game_key o,
 598                   db_away_game_key o,
 599                   db_current_timestamp o,
 600                   db_live o,
 601                   n1,n2,n3,n4,n5)
 602       where
 603         note_lines = split "\n" (db_notes o)
 604         n1 = case note_lines of
 605                (notes1:_) -> notes1
 606                _          -> ""
 607         n2 = case note_lines of
 608                (_:notes2:_) -> notes2
 609                _            -> ""
 610         n3 = case note_lines of
 611                (_:_:notes3:_) -> notes3
 612                _              -> ""
 613         n4 = case note_lines of
 614                (_:_:_:notes4:_) -> notes4
 615                _                -> ""
 616         n5 = case note_lines of
 617                (_:_:_:_:notes5:_) -> notes5
 618                _                  -> ""
 619
 620 pickle_home_team :: PU JFileGameHomeTeamXml
 621 pickle_home_team =
 622   xpElem "hteam" $
 623     xpWrap (from_tuple, to_tuple) $
 624     xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text.
 625              (xpAttr "abbr" (xpOption xpText)) -- Some are blank
 626              (xpOption xpText) -- Yup, some are nameless
 627   where
 628     from_tuple = uncurryN JFileGameHomeTeamXml
 629     to_tuple t = (home_team_id t,
 630                   home_team_abbreviation t,
 631                   home_team_name t)
 632
 633
 634 pickle_away_team :: PU JFileGameAwayTeamXml
 635 pickle_away_team =
 636   xpElem "vteam" $
 637     xpWrap (from_tuple, to_tuple) $
 638     xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text.
 639              (xpAttr "abbr" (xpOption xpText)) -- Some are blank
 640              (xpOption xpText) -- Yup, some are nameless
 641   where
 642     from_tuple = uncurryN JFileGameAwayTeamXml
 643     to_tuple t = (away_team_id t,
 644                   away_team_abbreviation t,
 645                   away_team_name t)
 646
 647
 648 pickle_status :: PU JFileGameStatus
 649 pickle_status =
 650   xpElem "status" $
 651     xpWrap (from_tuple, to_tuple) $
 652     xpPair (xpAttr "numeral" xpInt)
 653            (xpOption xpText)
 654   where
 655     from_tuple = uncurry JFileGameStatus
 656     to_tuple s = (db_status_numeral s,
 657                   db_status s)
 658
 659
 660
 661 --
 662 -- Tasty Tests
 663 --
 664
 665 -- | A list of all tests for this module.
 666 --
 667 jfile_tests :: TestTree
 668 jfile_tests =
 669   testGroup
 670     "JFile tests"
 671     [ test_on_delete_cascade,
 672       test_pickle_of_unpickle_is_identity,
 673       test_unpickle_succeeds ]
 674
 675
 676 -- | If we unpickle something and then pickle it, we should wind up
 677 --   with the same thing we started with. WARNING: success of this
 678 --   test does not mean that unpickling succeeded.
 679 --
 680 test_pickle_of_unpickle_is_identity :: TestTree
 681 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 682   [ check "pickle composed with unpickle is the identity"
 683           "test/xml/jfilexml.xml",
 684     check "pickle composed with unpickle is the identity (missing fields)"
 685           "test/xml/jfilexml-missing-fields.xml" ]
 686   where
 687     check desc path = testCase desc $ do
 688       (expected, actual) <- pickle_unpickle pickle_message path
 689       actual @?= expected
 690
 691
 692
 693 -- | Make sure we can actually unpickle these things.
 694 --
 695 test_unpickle_succeeds :: TestTree
 696 test_unpickle_succeeds = testGroup "unpickle tests"
 697   [ check "unpickling succeeds" "test/xml/jfilexml.xml",
 698     check "unpickling succeeds (missing fields)"
 699           "test/xml/jfilexml-missing-fields.xml" ]
 700   where
 701     check desc path = testCase desc $ do
 702     actual <- unpickleable path pickle_message
 703
 704     let expected = True
 705     actual @?= expected
 706
 707
 708
 709 -- | Make sure everything gets deleted when we delete the top-level
 710 --   record.
 711 --
 712 test_on_delete_cascade :: TestTree
 713 test_on_delete_cascade = testGroup "cascading delete tests"
 714   [ check "deleting auto_racing_results deletes its children"
 715           "test/xml/jfilexml.xml"
 716           20,
 717     check "deleting auto_racing_results deletes its children (missing fields)"
 718           "test/xml/jfilexml-missing-fields.xml"
 719           44 ]
 720   where
 721     check desc path expected = testCase desc $ do
 722       results <- unsafe_unpickle path pickle_message
 723       let a = undefined :: Team
 724       let b = undefined :: JFile
 725       let c = undefined :: JFileGame
 726       let d = undefined :: JFileGame_Team
 727
 728       actual <- withSqliteConn ":memory:" $ runDbConn $ do
 729                   runMigration silentMigrationLogger $ do
 730                     migrate a
 731                     migrate b
 732                     migrate c
 733                     migrate d
 734                   _ <- dbimport results
 735                   deleteAll b
 736                   count_a <- countAll a
 737                   count_b <- countAll b
 738                   count_c <- countAll c
 739                   count_d <- countAll d
 740                   return $ sum [count_a, count_b, count_c, count_d]
 741       actual @?= expected