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