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