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