]> gitweb.michael.orlitzky.com - dead/htsn-import.git/blob - XML/Odds.hs
Allow "TBA" laps in TSN.XML.AutoRacingSchedule.
[dead/htsn-import.git] / XML / Odds.hs
1 {-# LANGUAGE DeriveDataTypeable #-}
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 \"Odds_XML.dtd\". Each document
10 -- contains a root element \<message\> that contains a bunch of
11 -- other... disorganized... information.
12 --
13 module TSN.XML.Odds (
14 dtd,
15 pickle_message,
16 -- * Tests
17 odds_tests,
18 -- * WARNING: these are private but exported to silence warnings
19 OddsCasinoConstructor(..),
20 OddsConstructor(..),
21 OddsGameConstructor(..),
22 OddsGameLineConstructor(..) )
23 where
24
25 -- System imports.
26 import Control.Applicative ( (<$>) )
27 import Control.Monad ( forM_, join )
28 import Data.Time ( UTCTime(..) )
29 import Data.Tuple.Curry ( uncurryN )
30 import Database.Groundhog (
31 (=.),
32 (==.),
33 countAll,
34 deleteAll,
35 insert_,
36 migrate,
37 runMigration,
38 silentMigrationLogger,
39 update )
40 import Database.Groundhog.Core ( DefaultKey )
41 import Database.Groundhog.Generic ( runDbConn )
42 import Database.Groundhog.Sqlite ( withSqliteConn )
43 import Database.Groundhog.TH (
44 groundhog,
45 mkPersist )
46 import Test.Tasty ( TestTree, testGroup )
47 import Test.Tasty.HUnit ( (@?=), testCase )
48 import Text.Read ( readMaybe )
49 import Text.XML.HXT.Core (
50 PU,
51 xp6Tuple,
52 xp8Tuple,
53 xpAttr,
54 xpElem,
55 xpInt,
56 xpList,
57 xpOption,
58 xpPair,
59 xpText,
60 xpTriple,
61 xpWrap )
62
63 -- Local imports.
64 import TSN.Codegen (
65 tsn_codegen_config )
66 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
67 import TSN.Picklers ( xp_date_padded, xp_time, xp_time_stamp )
68 import TSN.Team ( Team(..) )
69 import TSN.XmlImport ( XmlImport(..), XmlImportFkTeams(..) )
70 import Xml (
71 Child(..),
72 FromXml(..),
73 FromXmlFkTeams(..),
74 ToDb(..),
75 pickle_unpickle,
76 unpickleable,
77 unsafe_unpickle )
78
79
80 -- | The DTD to which this module corresponds. Used to invoke dbimport.
81 --
82 dtd :: String
83 dtd = "Odds_XML.dtd"
84
85
86 --
87 -- DB/XML data types
88 --
89
90 -- * OddsGameCasino/OddsGameCasinoXml
91
92
93 -- | The casinos should have their own table, but the lines don't
94 -- belong in that table (there is a separate table for
95 -- 'OddsGameLine' which associates the two).
96 --
97 -- We drop the \"Game\" prefix because the casinos really aren't
98 -- children of the games; the XML just makes it seem that way.
99 --
100 data OddsCasino =
101 OddsCasino {
102 casino_client_id :: Int,
103 casino_name :: String }
104 deriving (Eq, Show)
105
106
107 -- | The home/away lines are 'Double's, but the over/under lines are
108 -- textual. If we want to use one data type for both, we have to go
109 -- with a 'String' and then attempt to 'read' a 'Double' later when we
110 -- go to insert the thing.
111 --
112 data OddsGameCasinoXml =
113 OddsGameCasinoXml {
114 xml_casino_client_id :: Int,
115 xml_casino_name :: String,
116 xml_casino_line :: Maybe String }
117 deriving (Eq, Show)
118
119
120 -- | Try to get a 'Double' out of the 'xml_casino_line' which is a
121 -- priori textual (because it might be an over/under line).
122 --
123 home_away_line :: OddsGameCasinoXml -> Maybe Double
124 home_away_line = join . (fmap readMaybe) . xml_casino_line
125
126
127
128 instance ToDb OddsGameCasinoXml where
129 -- | The database representation of an 'OddsGameCasinoXml' is an
130 -- 'OddsCasino'.
131 --
132 type Db OddsGameCasinoXml = OddsCasino
133
134
135 instance FromXml OddsGameCasinoXml where
136 -- | We convert from XML to the database by dropping the line field.
137 --
138 from_xml OddsGameCasinoXml{..} =
139 OddsCasino {
140 casino_client_id = xml_casino_client_id,
141 casino_name = xml_casino_name }
142
143
144 -- | This allows us to insert the XML representation 'OddsGameCasinoXml'
145 -- directly.
146 --
147 instance XmlImport OddsGameCasinoXml
148
149
150 -- * OddsGameTeamXml / OddsGameTeamStarterXml
151
152 -- | The XML representation of a \"starter\". It contains both an ID
153 -- and a name. The ID does not appear to be optional, but the name
154 -- can be absent. When the name is absent, the ID has always been
155 -- set to \"0\". This occurs even though the entire starter element
156 -- is optional (see 'OddsGameTeamXml' below).
157 --
158 data OddsGameTeamStarterXml =
159 OddsGameTeamStarterXml {
160 xml_starter_id :: Int,
161 xml_starter_name :: Maybe String }
162 deriving (Eq, Show)
163
164
165 -- | The XML representation of a \<HomeTeam\> or \<AwayTeam\>, as
166 -- found in \<Game\>s. We can't use the 'Team' representation
167 -- directly because there are some other fields we need to parse.
168 --
169 data OddsGameTeamXml =
170 OddsGameTeamXml {
171 xml_team_id :: String, -- ^ The home/away team IDs
172 -- are three characters but
173 -- Postgres imposes no
174 -- performance penalty on
175 -- lengthless text fields,
176 -- so we ignore the probable
177 -- upper bound of three
178 -- characters.
179 xml_team_rotation_number :: Maybe Int,
180 xml_team_abbr :: String,
181 xml_team_name :: String,
182 xml_team_starter :: Maybe OddsGameTeamStarterXml,
183 xml_team_casinos :: [OddsGameCasinoXml] }
184 deriving (Eq, Show)
185
186 instance ToDb OddsGameTeamXml where
187 -- | The database representation of an 'OddsGameTeamXml' is an
188 -- 'OddsGameTeam'.
189 --
190 type Db OddsGameTeamXml = Team
191
192 instance FromXml OddsGameTeamXml where
193 -- | We convert from XML to the database by dropping the lines and
194 -- rotation number (which are specific to the games, not the teams
195 -- themselves).
196 --
197 from_xml OddsGameTeamXml{..} =
198 Team {
199 team_id = xml_team_id,
200 abbreviation = Just xml_team_abbr,
201 name = Just xml_team_name }
202
203 -- | This allows us to insert the XML representation
204 -- 'OddsGameTeamXml' directly.
205 --
206 instance XmlImport OddsGameTeamXml where
207
208
209
210
211 -- * OddsGameOverUnderXml
212
213 -- | XML representation of the over/under. A wrapper around a bunch of
214 -- casino elements.
215 --
216 newtype OddsGameOverUnderXml =
217 OddsGameOverUnderXml { xml_casinos :: [OddsGameCasinoXml] }
218 deriving (Eq, Show)
219
220
221 -- * OddsGameLine
222
223 -- | This database representation of the casino lines can't be
224 -- constructed from the one in the XML. The casinos within
225 -- Game-\>HomeTeam, Game-\>AwayTeam, and Game-\>Over_Under are all more or
226 -- less the same. We don't need a bajillion different tables to
227 -- store that, just one tying the casino/game pair to the three
228 -- lines.
229 --
230 -- The one small difference between the over/under casinos and the
231 -- home/away ones is that the home/away lines are all 'Double's, but
232 -- the over/under lines appear to be textual.
233 --
234 data OddsGameLine =
235 OddsGameLine {
236 ogl_odds_games_id :: DefaultKey OddsGame,
237 ogl_odds_casinos_id :: DefaultKey OddsCasino,
238 ogl_over_under :: Maybe String,
239 ogl_away_line :: Maybe Double,
240 ogl_home_line :: Maybe Double }
241
242
243 -- * OddsGame/OddsGameXml
244
245 -- | Database representation of a game. We retain the rotation number
246 -- of the home/away teams, since those are specific to the game and
247 -- not the teams.
248 --
249 data OddsGame =
250 OddsGame {
251 db_odds_id :: DefaultKey Odds,
252 db_away_team_id :: DefaultKey Team,
253 db_home_team_id :: DefaultKey Team,
254 db_game_id :: Int,
255 db_game_time :: UTCTime, -- ^ Contains both the date and time.
256 db_away_team_rotation_number :: Maybe Int,
257 db_home_team_rotation_number :: Maybe Int,
258 db_away_team_starter_id :: Maybe Int,
259 db_away_team_starter_name :: Maybe String,
260 db_home_team_starter_id :: Maybe Int,
261 db_home_team_starter_name :: Maybe String }
262
263
264 -- | XML representation of an 'OddsGame'.
265 --
266 data OddsGameXml =
267 OddsGameXml {
268 xml_game_id :: Int,
269 xml_game_date :: UTCTime, -- ^ Contains only the date
270 xml_game_time :: UTCTime, -- ^ Contains only the time
271 xml_away_team :: OddsGameTeamXml,
272 xml_home_team :: OddsGameTeamXml,
273 xml_over_under :: OddsGameOverUnderXml }
274 deriving (Eq, Show)
275
276 -- | Pseudo-field that lets us get the 'OddsGameCasinoXml's out of
277 -- xml_over_under.
278 --
279 xml_over_under_casinos :: OddsGameXml -> [OddsGameCasinoXml]
280 xml_over_under_casinos = xml_casinos . xml_over_under
281
282
283 instance ToDb OddsGameXml where
284 -- | The database representation of an 'OddsGameXml' is an
285 -- 'OddsGame'.
286 --
287 type Db OddsGameXml = OddsGame
288
289
290 instance Child OddsGameXml where
291 -- | Each 'OddsGameXml' is contained in an 'Odds'. In other words
292 -- the foreign key for 'OddsGame' points to an 'Odds'.
293 --
294 type Parent OddsGameXml = Odds
295
296
297 instance FromXmlFkTeams OddsGameXml where
298 -- | To convert from the XML representation to the database one, we
299 -- drop the casino lines, but retain the home/away rotation
300 -- numbers and the starters. The foreign keys to 'Odds' and the
301 -- home/away teams are passed in.
302 --
303 from_xml_fk_teams fk fk_away fk_home OddsGameXml{..} =
304 OddsGame {
305 db_odds_id = fk,
306 db_away_team_id = fk_away,
307 db_home_team_id = fk_home,
308 db_game_id = xml_game_id,
309
310 db_game_time = UTCTime
311 (utctDay xml_game_date) -- Take the day part from one,
312 (utctDayTime xml_game_time), -- the time from the other.
313
314 db_away_team_rotation_number =
315 (xml_team_rotation_number xml_away_team),
316
317 db_home_team_rotation_number =
318 (xml_team_rotation_number xml_home_team),
319
320 db_away_team_starter_id =
321 (xml_starter_id <$> xml_team_starter xml_away_team),
322
323 -- Sometimes the starter element is present but the name isn't,
324 -- so we combine the two maybes with join.
325 db_away_team_starter_name = join
326 (xml_starter_name <$> xml_team_starter xml_away_team),
327
328 db_home_team_starter_id =
329 (xml_starter_id <$> xml_team_starter xml_home_team),
330
331 -- Sometimes the starter element is present but the name isn't,
332 -- so we combine the two maybes with join.
333 db_home_team_starter_name = join
334 (xml_starter_name <$> xml_team_starter xml_home_team) }
335
336
337 -- | This lets us insert the XML representation 'OddsGameXml' directly.
338 --
339 instance XmlImportFkTeams OddsGameXml
340
341
342 -- * OddsGameWithNotes
343
344 -- | This is our best guess at what occurs in the Odds_XML
345 -- documents. It looks like each consecutive set of games can
346 -- optionally have some notes appear before it. Each \"note\" comes
347 -- as its own \<Notes\>...\</Notes\> element.
348 --
349 -- The notes are ignored completely in the database; we only bother
350 -- with them to ensure that we're (un)pickling correctly.
351 --
352 -- We can't group the notes with a \"set\" of 'OddsGame's, because
353 -- that leads to ambiguity in parsing. Since we're going to ignore
354 -- the notes anyway, we just stick them with an arbitrary
355 -- game. C'est la vie.
356 --
357 -- We have to take the same approach with the league. The
358 -- \<League_Name\> elements are sitting outside of the games, and
359 -- are presumably supposed to be interpreted in \"chronological\"
360 -- order; i.e. the current league stays the same until we see
361 -- another \<League_Name\> element. Unfortunately, that's not how
362 -- XML works. So we're forced to ignore the league in the database
363 -- and pull the same trick, pairing them with games.
364 --
365 data OddsGameWithNotes =
366 OddsGameWithNotes {
367 league :: Maybe String,
368 notes :: [String],
369 game :: OddsGameXml }
370 deriving (Eq, Show)
371
372
373 -- * Odds/Message
374
375 -- | Database representation of a 'Message'.
376 --
377 data Odds =
378 Odds {
379 db_xml_file_id :: Int,
380 db_sport :: String,
381 db_title :: String,
382 db_line_time :: String, -- ^ We don't parse these as a 'UTCTime'
383 -- because their timezones are ambiguous
384 -- (and the date is less than useful when
385 -- it might be off by an hour).
386 db_time_stamp :: UTCTime }
387
388
389 -- | The XML representation of 'Odds'.
390 --
391 data Message =
392 Message {
393 xml_xml_file_id :: Int,
394 xml_heading :: String,
395 xml_category :: String,
396 xml_sport :: String,
397 xml_title :: String,
398 xml_line_time :: String,
399 xml_games_with_notes :: [OddsGameWithNotes],
400 xml_time_stamp :: UTCTime }
401 deriving (Eq, Show)
402
403 -- | Pseudo-field that lets us get the 'OddsGame's out of
404 -- 'xml_games_with_notes'.
405 --
406 xml_games :: Message -> [OddsGameXml]
407 xml_games m = map game (xml_games_with_notes m)
408
409
410 instance ToDb Message where
411 -- | The database representation of a 'Message' is 'Odds'.
412 --
413 type Db Message = Odds
414
415 instance FromXml Message where
416 -- | To convert from the XML representation to the database one, we
417 -- just drop a bunch of fields.
418 --
419 from_xml Message{..} =
420 Odds {
421 db_xml_file_id = xml_xml_file_id,
422 db_sport = xml_sport,
423 db_title = xml_title,
424 db_line_time = xml_line_time,
425 db_time_stamp = xml_time_stamp }
426
427 -- | This lets us insert the XML representation 'Message' directly.
428 --
429 instance XmlImport Message
430
431
432 --
433 -- Database code
434 --
435
436 -- Groundhog database schema. This must come before the DbImport
437 -- instance definition. Don't know why.
438 mkPersist tsn_codegen_config [groundhog|
439 - entity: Odds
440 constructors:
441 - name: Odds
442 uniques:
443 - name: unique_odds
444 type: constraint
445 # Prevent multiple imports of the same message.
446 fields: [db_xml_file_id]
447
448 - entity: OddsCasino
449 dbName: odds_casinos
450 constructors:
451 - name: OddsCasino
452 uniques:
453 - name: unique_odds_casino
454 type: constraint
455 fields: [casino_client_id]
456
457 - entity: OddsGame
458 dbName: odds_games
459 constructors:
460 - name: OddsGame
461 fields:
462 - name: db_odds_id
463 reference:
464 onDelete: cascade
465 - name: db_away_team_id
466 reference:
467 onDelete: cascade
468 - name: db_home_team_id
469 reference:
470 onDelete: cascade
471
472 - entity: OddsGameLine
473 dbName: odds_games_lines
474 constructors:
475 - name: OddsGameLine
476 fields:
477 - name: ogl_odds_games_id
478 reference:
479 onDelete: cascade
480 - name: ogl_odds_casinos_id
481 reference:
482 onDelete: cascade
483
484 |]
485
486 instance DbImport Message where
487 dbmigrate _=
488 run_dbmigrate $ do
489 migrate (undefined :: Team)
490 migrate (undefined :: Odds)
491 migrate (undefined :: OddsCasino)
492 migrate (undefined :: OddsGame)
493 migrate (undefined :: OddsGameLine)
494
495 dbimport m = do
496 -- Insert the root "odds" element and acquire its primary key (id).
497 odds_id <- insert_xml m
498
499 forM_ (xml_games m) $ \game -> do
500 -- First we insert the home and away teams.
501 away_team_id <- insert_xml_or_select (xml_away_team game)
502 home_team_id <- insert_xml_or_select (xml_home_team game)
503
504 -- Now insert the game, keyed to the "odds" and its teams.
505 game_id <- insert_xml_fk_teams odds_id away_team_id home_team_id game
506
507 -- Finally, we insert the lines. The over/under entries for this
508 -- game and the lines for the casinos all wind up in the same
509 -- table, odds_games_lines. We can insert the over/under entries
510 -- freely with empty away/home lines:
511 forM_ (xml_over_under_casinos game) $ \c -> do
512 -- Start by inderting the casino.
513 ou_casino_id <- insert_xml_or_select c
514
515 -- Now add the over/under entry with the casino's id.
516 let ogl = OddsGameLine {
517 ogl_odds_games_id = game_id,
518 ogl_odds_casinos_id = ou_casino_id,
519 ogl_over_under = (xml_casino_line c),
520 ogl_away_line = Nothing,
521 ogl_home_line = Nothing }
522
523 insert_ ogl
524
525 -- ...but then when we insert the home/away team lines, we
526 -- prefer to update the existing entry rather than overwrite it
527 -- or add a new record.
528 forM_ (xml_team_casinos $ xml_away_team game) $ \c -> do
529 -- insert, or more likely retrieve the existing, casino
530 a_casino_id <- insert_xml_or_select c
531
532 -- Get a Maybe Double instead of the Maybe String that's in there.
533 let away_line = home_away_line c
534
535 -- Unconditionally update that casino's away team line with ours.
536 update [Ogl_Away_Line =. away_line] $ -- WHERE
537 Ogl_Odds_Casinos_Id ==. a_casino_id
538
539 -- Repeat all that for the home team.
540 forM_ (xml_team_casinos $ xml_home_team game) $ \c ->do
541 h_casino_id <- insert_xml_or_select c
542 let home_line = home_away_line c
543 update [Ogl_Home_Line =. home_line] $ -- WHERE
544 Ogl_Odds_Casinos_Id ==. h_casino_id
545
546 return game_id
547
548 return ImportSucceeded
549
550
551 --
552 -- Pickling
553 --
554
555 -- | Pickler for an 'OddsGame' optionally preceded by some notes.
556 --
557 pickle_game_with_notes :: PU OddsGameWithNotes
558 pickle_game_with_notes =
559 xpWrap (from_pair, to_pair) $
560 xpTriple
561 (xpOption $ xpElem "League_Name" xpText)
562 (xpList $ xpElem "Notes" xpText)
563 pickle_game
564 where
565 from_pair = uncurryN OddsGameWithNotes
566 to_pair OddsGameWithNotes{..} = (league, notes, game)
567
568
569 -- | Pickler for an 'OddsGameCasinoXml'.
570 --
571 pickle_casino :: PU OddsGameCasinoXml
572 pickle_casino =
573 xpElem "Casino" $
574 xpWrap (from_tuple, to_tuple) $
575 xpTriple
576 (xpAttr "ClientID" xpInt)
577 (xpAttr "Name" xpText)
578 (xpOption xpText)
579 where
580 from_tuple = uncurryN OddsGameCasinoXml
581 -- Use record wildcards to avoid unused field warnings.
582 to_tuple OddsGameCasinoXml{..} = (xml_casino_client_id,
583 xml_casino_name,
584 xml_casino_line)
585
586
587 -- | Pickler for an 'OddsGameTeamXml'.
588 --
589 pickle_home_team :: PU OddsGameTeamXml
590 pickle_home_team =
591 xpElem "HomeTeam" $
592 xpWrap (from_tuple, to_tuple) $
593 xp6Tuple
594 (xpElem "HomeTeamID" xpText)
595 (xpElem "HomeRotationNumber" (xpOption xpInt))
596 (xpElem "HomeAbbr" xpText)
597 (xpElem "HomeTeamName" xpText)
598 (xpOption pickle_home_starter)
599 (xpList pickle_casino)
600 where
601 from_tuple = uncurryN OddsGameTeamXml
602
603 -- Use record wildcards to avoid unused field warnings.
604 to_tuple OddsGameTeamXml{..} = (xml_team_id,
605 xml_team_rotation_number,
606 xml_team_abbr,
607 xml_team_name,
608 xml_team_starter,
609 xml_team_casinos)
610
611
612 -- | Portion of the 'OddsGameTeamStarterXml' pickler that is not
613 -- specific to the home/away teams.
614 --
615 pickle_starter :: PU OddsGameTeamStarterXml
616 pickle_starter =
617 xpWrap (from_tuple, to_tuple) $
618 xpPair (xpAttr "ID" xpInt) (xpOption xpText)
619 where
620 from_tuple = uncurry OddsGameTeamStarterXml
621 to_tuple OddsGameTeamStarterXml{..} = (xml_starter_id,
622 xml_starter_name)
623
624 -- | Pickler for an home team 'OddsGameTeamStarterXml'
625 --
626 pickle_home_starter :: PU OddsGameTeamStarterXml
627 pickle_home_starter = xpElem "HStarter" $ pickle_starter
628
629
630 -- | Pickler for an away team 'OddsGameTeamStarterXml'
631 --
632 pickle_away_starter :: PU OddsGameTeamStarterXml
633 pickle_away_starter = xpElem "AStarter" $ pickle_starter
634
635
636
637 -- | Pickler for an 'OddsGameTeamXml'.
638 --
639 pickle_away_team :: PU OddsGameTeamXml
640 pickle_away_team =
641 xpElem "AwayTeam" $
642 xpWrap (from_tuple, to_tuple) $
643 xp6Tuple
644 (xpElem "AwayTeamID" xpText)
645 (xpElem "AwayRotationNumber" (xpOption xpInt))
646 (xpElem "AwayAbbr" xpText)
647 (xpElem "AwayTeamName" xpText)
648 (xpOption pickle_away_starter)
649 (xpList pickle_casino)
650 where
651 from_tuple = uncurryN OddsGameTeamXml
652
653 -- Use record wildcards to avoid unused field warnings.
654 to_tuple OddsGameTeamXml{..} = (xml_team_id,
655 xml_team_rotation_number,
656 xml_team_abbr,
657 xml_team_name,
658 xml_team_starter,
659 xml_team_casinos)
660
661
662
663 -- | Pickler for an 'OddsGameOverUnderXml'.
664 --
665 pickle_over_under :: PU OddsGameOverUnderXml
666 pickle_over_under =
667 xpElem "Over_Under" $
668 xpWrap (to_newtype, from_newtype) $
669 xpList pickle_casino
670 where
671 from_newtype (OddsGameOverUnderXml cs) = cs
672 to_newtype = OddsGameOverUnderXml
673
674
675 -- | Pickler for an 'OddsGameXml'.
676 --
677 pickle_game :: PU OddsGameXml
678 pickle_game =
679 xpElem "Game" $
680 xpWrap (from_tuple, to_tuple) $
681 xp6Tuple
682 (xpElem "GameID" xpInt)
683 (xpElem "Game_Date" xp_date_padded)
684 (xpElem "Game_Time" xp_time)
685 pickle_away_team
686 pickle_home_team
687 pickle_over_under
688 where
689 from_tuple = uncurryN OddsGameXml
690 -- Use record wildcards to avoid unused field warnings.
691 to_tuple OddsGameXml{..} = (xml_game_id,
692 xml_game_date,
693 xml_game_time,
694 xml_away_team,
695 xml_home_team,
696 xml_over_under)
697
698
699 -- | Pickler for the top-level 'Message'.
700 --
701 pickle_message :: PU Message
702 pickle_message =
703 xpElem "message" $
704 xpWrap (from_tuple, to_tuple) $
705 xp8Tuple (xpElem "XML_File_ID" xpInt)
706 (xpElem "heading" xpText)
707 (xpElem "category" xpText)
708 (xpElem "sport" xpText)
709 (xpElem "Title" xpText)
710 (xpElem "Line_Time" xpText)
711 (xpList pickle_game_with_notes)
712 (xpElem "time_stamp" xp_time_stamp)
713 where
714 from_tuple = uncurryN Message
715 to_tuple m = (xml_xml_file_id m,
716 xml_heading m,
717 xml_category m,
718 xml_sport m,
719 xml_title m,
720 xml_line_time m,
721 xml_games_with_notes m,
722 xml_time_stamp m)
723
724
725 --
726 -- Tasty Tests
727 --
728
729 -- | A list of all tests for this module.
730 --
731 odds_tests :: TestTree
732 odds_tests =
733 testGroup
734 "Odds tests"
735 [ test_on_delete_cascade,
736 test_pickle_of_unpickle_is_identity,
737 test_unpickle_succeeds ]
738
739
740 -- | If we unpickle something and then pickle it, we should wind up
741 -- with the same thing we started with. WARNING: success of this
742 -- test does not mean that unpickling succeeded.
743 --
744 test_pickle_of_unpickle_is_identity :: TestTree
745 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
746 [ check "pickle composed with unpickle is the identity"
747 "test/xml/Odds_XML.xml",
748
749 check "pickle composed with unpickle is the identity (non-int team_id)"
750 "test/xml/Odds_XML-noninteger-team-id.xml",
751
752 check "pickle composed with unpickle is the identity (positive(+) line)"
753 "test/xml/Odds_XML-positive-line.xml",
754
755 check "pickle composed with unpickle is the identity (large file)"
756 "test/xml/Odds_XML-largefile.xml",
757
758 check "pickle composed with unpickle is the identity (league name)"
759 "test/xml/Odds_XML-league-name.xml",
760
761 check "pickle composed with unpickle is the identity (missing starters)"
762 "test/xml/Odds_XML-missing-starters.xml" ]
763 where
764 check desc path = testCase desc $ do
765 (expected, actual) <- pickle_unpickle pickle_message path
766 actual @?= expected
767
768
769 -- | Make sure we can actually unpickle these things.
770 --
771 test_unpickle_succeeds :: TestTree
772 test_unpickle_succeeds = testGroup "unpickle tests"
773 [ check "unpickling succeeds"
774 "test/xml/Odds_XML.xml",
775
776 check "unpickling succeeds (non-int team_id)"
777 "test/xml/Odds_XML-noninteger-team-id.xml",
778
779 check "unpickling succeeds (positive(+) line)"
780 "test/xml/Odds_XML-positive-line.xml",
781
782 check "unpickling succeeds (large file)"
783 "test/xml/Odds_XML-largefile.xml",
784
785 check "unpickling succeeds (league name)"
786 "test/xml/Odds_XML-league-name.xml",
787
788 check "unpickling succeeds (missing starters)"
789 "test/xml/Odds_XML-missing-starters.xml" ]
790 where
791 check desc path = testCase desc $ do
792 actual <- unpickleable path pickle_message
793 let expected = True
794 actual @?= expected
795
796
797 -- | Make sure everything gets deleted when we delete the top-level
798 -- record. The casinos and teams should be left behind.
799 --
800 test_on_delete_cascade :: TestTree
801 test_on_delete_cascade = testGroup "cascading delete tests"
802 [ check "deleting odds deletes its children"
803 "test/xml/Odds_XML.xml"
804 13 -- 5 casinos, 8 teams
805 ,
806
807 check "deleting odds deletes its children (non-int team_id)"
808 "test/xml/Odds_XML-noninteger-team-id.xml"
809 51 -- 5 casinos, 46 teams
810 ,
811
812 check "deleting odds deleted its children (positive(+) line)"
813 "test/xml/Odds_XML-positive-line.xml"
814 17 -- 5 casinos, 12 teams
815 ,
816
817 check "deleting odds deleted its children (large file)"
818 "test/xml/Odds_XML-largefile.xml"
819 189 -- 5 casinos, 184 teams
820 ,
821 check "deleting odds deleted its children (league name)"
822 "test/xml/Odds_XML-league-name.xml"
823 35 -- 5 casinos, 30 teams
824 ,
825 check "deleting odds deleted its children (missing starters)"
826 "test/xml/Odds_XML-missing-starters.xml"
827 7 -- 5 casinos, 2 teams
828 ]
829 where
830 check desc path expected = testCase desc $ do
831 odds <- unsafe_unpickle path pickle_message
832 let a = undefined :: Team
833 let b = undefined :: Odds
834 let c = undefined :: OddsCasino
835 let d = undefined :: OddsGame
836 let e = undefined :: OddsGameLine
837 actual <- withSqliteConn ":memory:" $ runDbConn $ do
838 runMigration silentMigrationLogger $ do
839 migrate a
840 migrate b
841 migrate c
842 migrate d
843 migrate e
844 _ <- dbimport odds
845 deleteAll b
846 count_a <- countAll a
847 count_b <- countAll b
848 count_c <- countAll c
849 count_d <- countAll d
850 count_e <- countAll e
851 return $ sum [count_a, count_b, count_c,
852 count_d, count_e ]
853 actual @?= expected