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