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