]> gitweb.michael.orlitzky.com - dead/htsn-import.git/blob - XML/Scores.hs
Allow "TBA" laps in TSN.XML.AutoRacingSchedule.
[dead/htsn-import.git] / XML / Scores.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 \"scoresxml.dtd\". Each document
10 -- contains a single \<game\> and some \<location\>s.
11 --
12 module TSN.XML.Scores (
13 dtd,
14 pickle_message,
15 -- * Tests
16 scores_tests,
17 -- * WARNING: these are private but exported to silence warnings
18 Score_LocationConstructor(..),
19 ScoreConstructor(..),
20 ScoreGameConstructor(..) )
21 where
22
23 -- System imports.
24 import Control.Monad ( join )
25 import Data.Data ( Data )
26 import Data.Time ( UTCTime )
27 import Data.Tuple.Curry ( uncurryN )
28 import Data.Typeable ( Typeable )
29 import Database.Groundhog (
30 countAll,
31 deleteAll,
32 insert_,
33 migrate,
34 runMigration,
35 silentMigrationLogger )
36 import Database.Groundhog.Core ( DefaultKey )
37 import Database.Groundhog.Generic ( runDbConn )
38 import Database.Groundhog.Sqlite ( withSqliteConn )
39 import Database.Groundhog.TH (
40 groundhog,
41 mkPersist )
42 import Test.Tasty ( TestTree, testGroup )
43 import Test.Tasty.HUnit ( (@?=), testCase )
44 import Text.XML.HXT.Core (
45 PU,
46 xp7Tuple,
47 xp11Tuple,
48 xpAttr,
49 xpElem,
50 xpInt,
51 xpList,
52 xpOption,
53 xpPrim,
54 xpText,
55 xpTriple,
56 xpWrap )
57
58 -- Local imports.
59 import TSN.Codegen ( tsn_codegen_config )
60 import TSN.Database ( insert_or_select )
61 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
62 import TSN.Location ( Location(..), pickle_location )
63 import TSN.Picklers ( xp_time_stamp )
64 import TSN.Team (
65 FromXmlFkTeams(..),
66 HTeam(..),
67 Team(..),
68 VTeam(..) )
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 = "scoresxml.dtd"
83
84
85 --
86 -- * DB/XML Data types
87 --
88
89
90 -- * Score / Message
91
92 -- | Database representation of a 'Message'. It lacks the
93 -- 'xml_locations' and 'xml_game' which are related via foreign keys
94 -- instead.
95 --
96 data Score =
97 Score {
98 db_xml_file_id :: Int,
99 db_heading :: String,
100 db_game_id :: Maybe Int, -- ^ We've seen an empty one
101 db_schedule_id :: Maybe Int, -- ^ We've seen an empty one
102 db_tsnupdate :: Maybe Bool,
103 db_category :: String,
104 db_sport :: String,
105 db_season_type :: Maybe String, -- ^ We've seen an empty one
106 db_time_stamp :: UTCTime }
107
108
109 -- | XML representation of the top level \<message\> element (i.e. a
110 -- 'Score').
111 --
112 data Message =
113 Message {
114 xml_xml_file_id :: Int,
115 xml_heading :: String,
116 xml_game_id :: Maybe Int, -- ^ We've seen an empty one
117 xml_schedule_id :: Maybe Int, -- ^ We've seen an empty one
118 xml_tsnupdate :: Maybe Bool,
119 xml_category :: String,
120 xml_sport :: String,
121 xml_locations :: [Location],
122 xml_season_type :: Maybe String, -- ^ We've seen an empty one
123 xml_game :: ScoreGameXml,
124 xml_time_stamp :: UTCTime }
125 deriving (Eq, Show)
126
127 instance ToDb Message where
128 -- | The database representation of a 'Message' is a 'Score'.
129 type Db Message = Score
130
131 instance FromXml Message where
132 -- | When converting from the XML representation to the database
133 -- one, we drop the list of locations which will be foreign-keyed to
134 -- us instead.
135 from_xml Message{..} =
136 Score {
137 db_xml_file_id = xml_xml_file_id,
138 db_heading = xml_heading,
139 db_game_id = xml_game_id,
140 db_schedule_id = xml_schedule_id,
141 db_tsnupdate = xml_tsnupdate,
142 db_category = xml_category,
143 db_sport = xml_sport,
144 db_season_type = xml_season_type,
145 db_time_stamp = xml_time_stamp }
146
147
148 -- | This lets us insert the XML representation 'Message' directly.
149 --
150 instance XmlImport Message
151
152
153 -- * ScoreGame / ScoreGameXml
154
155 -- | This is an embedded field within 'SportsGame'. Each \<status\>
156 -- element has two attributes, a numeral and a type. It also
157 -- contains some text. Rather than put these in their own table, we
158 -- include them in the parent 'SportsGame'.
159 --
160 data ScoreGameStatus =
161 ScoreGameStatus {
162 db_status_numeral :: Int,
163 db_status_type :: Maybe String, -- ^ These are probably only one-character,
164 -- long, but they all take the same
165 -- amount of space in Postgres.
166 db_status_text :: String }
167 deriving (Data, Eq, Show, Typeable)
168
169
170 -- | Database representation of a game.
171 --
172 data ScoreGame =
173 ScoreGame {
174 db_scores_id :: DefaultKey Score,
175 db_away_team_id :: DefaultKey Team,
176 db_home_team_id :: DefaultKey Team,
177 db_away_team_score :: Int,
178 db_home_team_score :: Int,
179 db_away_team_pitcher :: Maybe String, -- ^ Found in the child \<vteam\>
180 db_home_team_pitcher :: Maybe String, -- ^ Found in the child \<hteam\>
181 db_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
182 db_status :: ScoreGameStatus,
183 db_notes :: Maybe String }
184
185
186 -- | XML representation of a \<game\> element (i.e. a 'ScoreGame').
187 --
188 data ScoreGameXml =
189 ScoreGameXml {
190 xml_vteam :: VTeamXml,
191 xml_hteam :: HTeamXml,
192 xml_away_team_score :: Int,
193 xml_home_team_score :: Int,
194 xml_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
195 xml_status :: ScoreGameStatus,
196 xml_notes :: Maybe String }
197 deriving (Eq, Show)
198
199
200 instance ToDb ScoreGameXml where
201 -- | The database representation of a 'ScoreGameXml' is a
202 -- 'ScoreGame'.
203 --
204 type Db ScoreGameXml = ScoreGame
205
206
207 instance Child ScoreGameXml where
208 -- | Each 'ScoreGameXml' is contained in (i.e. has a foreign key to)
209 -- a 'Score'.
210 --
211 type Parent ScoreGameXml = Score
212
213
214 instance FromXmlFkTeams ScoreGameXml where
215 -- | To create a 'ScoreGame' from a 'ScoreGameXml', we need three
216 -- foreign keys: the parent message, and the away/home teams.
217 --
218 from_xml_fk_teams fk fk_away fk_home ScoreGameXml{..} =
219 ScoreGame {
220 db_scores_id = fk,
221 db_away_team_id = fk_away,
222 db_home_team_id = fk_home,
223 db_away_team_score = xml_away_team_score,
224 db_home_team_score = xml_home_team_score,
225 db_away_team_pitcher = xml_vpitcher xml_vteam,
226 db_home_team_pitcher = xml_hpitcher xml_hteam,
227 db_time_r = xml_time_r,
228 db_status = xml_status,
229 db_notes = xml_notes }
230
231 -- | This lets us import the database representation 'ScoreGameXml'
232 -- directly.
233 --
234 instance XmlImportFkTeams ScoreGameXml
235
236
237
238 -- * Score_Location
239
240 -- | Join each 'Score' with its 'Location's. Database-only. We use a
241 -- join table because the locations are kept unique but there are
242 -- multiple locations per 'Score'.
243 --
244 data Score_Location =
245 Score_Location
246 (DefaultKey Score)
247 (DefaultKey Location)
248
249
250 -- * HTeamXml / VTeamXml
251
252 -- | XML Representation of a home team. This document type is unusual
253 -- in that the \<hteam\> elements can have a pitcher attribute
254 -- attached to them. We still want to maintain the underlying 'Team'
255 -- representation, so we say that a home team is a 'Team' and
256 -- (maybe) a pitcher.
257 --
258 data HTeamXml =
259 HTeamXml {
260 xml_ht :: HTeam,
261 xml_hpitcher :: Maybe String }
262 deriving (Eq, Show)
263
264 instance ToDb HTeamXml where
265 -- | The database analogue of a 'HTeamXml' is its 'Team'.
266 type Db HTeamXml = Team
267
268 instance FromXml HTeamXml where
269 -- | The conversion from XML to database is simply the 'Team' accessor.
270 --
271 from_xml = hteam . xml_ht
272
273 -- | Allow import of the XML representation directly, without
274 -- requiring a manual conversion to the database type first.
275 --
276 instance XmlImport HTeamXml
277
278
279
280 -- | XML Representation of an away team. This document type is unusual
281 -- in that the \<hteam\> elements can have a pitcher attribute
282 -- attached to them. We still want to maintain the underlying 'Team'
283 -- representation, so we say that an away team is a 'Team' and
284 -- (maybe) a pitcher.
285 --
286 data VTeamXml =
287 VTeamXml {
288 xml_vt :: VTeam,
289 xml_vpitcher :: Maybe String }
290 deriving (Eq, Show)
291
292 instance ToDb VTeamXml where
293 -- | The database analogue of a 'VTeamXml' is its 'Team'.
294 type Db VTeamXml = Team
295
296 instance FromXml VTeamXml where
297 -- | The conversion from XML to database is simply the 'Team' accessor.
298 --
299 from_xml = vteam . xml_vt
300
301 -- | Allow import of the XML representation directly, without
302 -- requiring a manual conversion to the database type first.
303 --
304 instance XmlImport VTeamXml
305
306
307
308 instance DbImport Message where
309 dbmigrate _ =
310 run_dbmigrate $ do
311 migrate (undefined :: Location)
312 migrate (undefined :: Team)
313 migrate (undefined :: Score)
314 migrate (undefined :: ScoreGame)
315 migrate (undefined :: Score_Location)
316
317 dbimport m = do
318 -- Insert the message and get its ID.
319 msg_id <- insert_xml m
320
321 -- Insert all of the locations contained within this message and
322 -- collect their IDs in a list. We use insert_or_select because
323 -- most of the locations will already exist, and we just want to
324 -- get the ID of the existing location when there's a collision.
325 location_ids <- mapM insert_or_select (xml_locations m)
326
327 -- Now use that list to construct 'Score_ScoreLocation' objects,
328 -- and insert them.
329 mapM_ (insert_ . Score_Location msg_id) location_ids
330
331 -- Insert the hteam/vteams, noting the IDs.
332 vteam_id <- insert_xml_or_select (xml_vteam $ xml_game m)
333 hteam_id <- insert_xml_or_select (xml_hteam $ xml_game m)
334
335 -- Now use those along with the msg_id to construct the game.
336 insert_xml_fk_teams_ msg_id vteam_id hteam_id (xml_game m)
337
338 return ImportSucceeded
339
340
341
342 -- These types have fields with e.g. db_ and xml_ prefixes, so we
343 -- use our own codegen to peel those off before naming the columns.
344 mkPersist tsn_codegen_config [groundhog|
345 - entity: Score
346 dbName: scores
347 constructors:
348 - name: Score
349 uniques:
350 - name: unique_scores
351 type: constraint
352 # Prevent multiple imports of the same message.
353 fields: [db_xml_file_id]
354
355 - embedded: ScoreGameStatus
356 fields:
357 - name: db_status_numeral
358 dbName: status_numeral
359 - name: db_status_type
360 dbName: status_type
361 - name: db_status_text
362 dbName: status_text
363
364
365 - entity: ScoreGame
366 dbName: scores_games
367 constructors:
368 - name: ScoreGame
369 fields:
370 - name: db_scores_id
371 reference:
372 onDelete: cascade
373 - name: db_status
374 embeddedType:
375 - { name: status_numeral, dbName: status_numeral }
376 - { name: status_type, dbName: status_type }
377 - { name: status_text, dbName: status_text }
378
379
380 - entity: Score_Location
381 dbName: scores__locations
382 constructors:
383 - name: Score_Location
384 fields:
385 - name: score_Location0 # Default created by mkNormalFieldName
386 dbName: scores_id
387 reference:
388 onDelete: cascade
389 - name: score_Location1 # Default created by mkNormalFieldName
390 dbName: locations_id
391 reference:
392 onDelete: cascade
393 |]
394
395
396 --
397 -- Pickling
398 --
399
400 -- | Convert a 'Message' to/from \<message\>.
401 --
402 pickle_message :: PU Message
403 pickle_message =
404 xpElem "message" $
405 xpWrap (from_tuple, to_tuple) $
406 xp11Tuple (xpElem "XML_File_ID" xpInt)
407 (xpElem "heading" xpText)
408 (xpElem "game_id" (xpOption xpInt))
409 (xpElem "schedule_id" (xpOption xpInt))
410 (xpOption $ xpElem "tsnupdate" xpPrim)
411 (xpElem "category" xpText)
412 (xpElem "sport" xpText)
413 (xpList pickle_location)
414 (xpElem "seasontype" (xpOption xpText))
415 pickle_game
416 (xpElem "time_stamp" xp_time_stamp)
417 where
418 from_tuple = uncurryN Message
419 to_tuple m = (xml_xml_file_id m,
420 xml_heading m,
421 xml_game_id m,
422 xml_schedule_id m,
423 xml_tsnupdate m,
424 xml_category m,
425 xml_sport m,
426 xml_locations m,
427 xml_season_type m,
428 xml_game m,
429 xml_time_stamp m)
430
431
432
433
434 -- | Convert a 'ScoreGameStatus' to/from \<status\>.
435 --
436 pickle_status :: PU ScoreGameStatus
437 pickle_status =
438 xpElem "status" $
439 xpWrap (from_tuple, to_tuple) $
440 xpTriple (xpAttr "numeral" xpInt)
441 (xpOption $ xpAttr "type" xpText)
442 xpText
443 where
444 from_tuple = uncurryN ScoreGameStatus
445 to_tuple ScoreGameStatus{..} = (db_status_numeral,
446 db_status_type,
447 db_status_text)
448
449
450 -- | Convert a 'ScoreGameXml' to/from \<game\>.
451 --
452 pickle_game :: PU ScoreGameXml
453 pickle_game =
454 xpElem "game" $
455 xpWrap (from_tuple, to_tuple) $
456 xp7Tuple pickle_vteam
457 pickle_hteam
458 (xpElem "vscore" xpInt)
459 (xpElem "hscore" xpInt)
460 (xpOption $ xpElem "time_r" xpText)
461 pickle_status
462 (xpOption $ xpElem "notes" xpText)
463 where
464 from_tuple = uncurryN ScoreGameXml
465 to_tuple ScoreGameXml{..} = (xml_vteam,
466 xml_hteam,
467 xml_away_team_score,
468 xml_home_team_score,
469 xml_time_r,
470 xml_status,
471 xml_notes)
472
473
474 -- | Convert a 'VTeamXml' to/from \<vteam\>. The team names
475 -- always seem to be present here, but in the shared representation,
476 -- they're optional (because they show up blank elsewhere). So, we
477 -- pretend they're optional.
478 --
479 -- The \"pitcher\" attribute is a little bit funny. Usually, when
480 -- there's no pitcher, the attribute itself is missing. But once in
481 -- a blue moon, it will be present with no text. We want to treat
482 -- both cases the same, so what we really parse is a Maybe (Maybe
483 -- String), and then use the monad 'join' to collapse it into a single
484 -- Maybe.
485 --
486 pickle_vteam :: PU VTeamXml
487 pickle_vteam =
488 xpElem "vteam" $
489 xpWrap (from_tuple, to_tuple) $
490 xpTriple (xpAttr "id" xpText)
491 (xpOption $ xpAttr "pitcher" (xpOption xpText))
492 (xpOption xpText) -- Team name
493 where
494 from_tuple (x,y,z) = VTeamXml (VTeam (Team x Nothing z)) (join y)
495
496 to_tuple (VTeamXml (VTeam t) Nothing) = (team_id t, Nothing, name t)
497 to_tuple (VTeamXml (VTeam t) jvp) = (team_id t, Just jvp, name t)
498
499
500 -- | Convert a 'HTeamXml' to/from \<hteam\>. Identical to 'pickle_vteam'
501 -- modulo the \"h\" and \"v\". The team names always seem to be
502 -- present here, but in the shared representation, they're optional
503 -- (because they show up blank elsewhere). So, we pretend they're
504 -- optional.
505 --
506 -- The \"pitcher\" attribute is a little bit funny. Usually, when
507 -- there's no pitcher, the attribute itself is missing. But once in
508 -- a blue moon, it will be present with no text. We want to treat
509 -- both cases the same, so what we really parse is a Maybe (Maybe
510 -- String), and then use the monad 'join' to collapse it into a single
511 -- Maybe.
512 --
513 pickle_hteam :: PU HTeamXml
514 pickle_hteam =
515 xpElem "hteam" $
516 xpWrap (from_tuple, to_tuple) $
517 xpTriple (xpAttr "id" xpText)
518 (xpOption $ xpAttr "pitcher" (xpOption xpText))
519 (xpOption xpText) -- Team name
520 where
521 from_tuple (x,y,z)= HTeamXml (HTeam (Team x Nothing z)) (join y)
522 to_tuple (HTeamXml (HTeam t) Nothing) = (team_id t, Nothing, name t)
523 to_tuple (HTeamXml (HTeam t) jhp) = (team_id t, Just jhp, name t)
524
525
526
527 --
528 -- * Tasty tests
529 --
530
531 -- | A list of all tests for this module.
532 --
533 scores_tests :: TestTree
534 scores_tests =
535 testGroup
536 "Scores tests"
537 [ test_on_delete_cascade,
538 test_pickle_of_unpickle_is_identity,
539 test_unpickle_succeeds ]
540
541
542 -- | If we unpickle something and then pickle it, we should wind up
543 -- with the same thing we started with. WARNING: success of this
544 -- test does not mean that unpickling succeeded.
545 --
546 test_pickle_of_unpickle_is_identity :: TestTree
547 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
548 [ check "pickle composed with unpickle is the identity"
549 "test/xml/scoresxml.xml",
550
551 check "pickle composed with unpickle is the identity (no locations)"
552 "test/xml/scoresxml-no-locations.xml",
553
554 check "pickle composed with unpickle is the identity (pitcher, no type)"
555 "test/xml/scoresxml-pitcher-no-type.xml"]
556 where
557 check desc path = testCase desc $ do
558 (expected, actual) <- pickle_unpickle pickle_message path
559 actual @?= expected
560
561
562 -- | Make sure we can actually unpickle these things.
563 --
564 test_unpickle_succeeds :: TestTree
565 test_unpickle_succeeds = testGroup "unpickle tests"
566 [ check "unpickling succeeds"
567 "test/xml/scoresxml.xml",
568
569 check "unpickling succeeds (no locations)"
570 "test/xml/scoresxml-no-locations.xml",
571
572 check "unpickling succeeds (pitcher, no type)"
573 "test/xml/scoresxml-pitcher-no-type.xml" ]
574 where
575 check desc path = testCase desc $ do
576 actual <- unpickleable path pickle_message
577 let expected = True
578 actual @?= expected
579
580
581 -- | Make sure everything gets deleted when we delete the top-level
582 -- record.
583 --
584 test_on_delete_cascade :: TestTree
585 test_on_delete_cascade = testGroup "cascading delete tests"
586 [ check "unpickling succeeds"
587 "test/xml/scoresxml.xml"
588 4, -- 2 teams, 2 locations
589
590 check "unpickling succeeds (no locations)"
591 "test/xml/scoresxml-no-locations.xml"
592 2, -- 2 teams, 0 locations
593
594 check "unpickling succeeds (pitcher, no type)"
595 "test/xml/scoresxml-pitcher-no-type.xml"
596 3 -- 2 teams, 1 location
597 ]
598 where
599 check desc path expected = testCase desc $ do
600 score <- unsafe_unpickle path pickle_message
601 let a = undefined :: Location
602 let b = undefined :: Team
603 let c = undefined :: Score
604 let d = undefined :: ScoreGame
605 let e = undefined :: Score_Location
606 actual <- withSqliteConn ":memory:" $ runDbConn $ do
607 runMigration silentMigrationLogger $ do
608 migrate a
609 migrate b
610 migrate c
611 migrate d
612 migrate e
613 _ <- dbimport score
614 -- No idea how 'delete' works, so do this instead.
615 deleteAll c
616 count_a <- countAll a
617 count_b <- countAll b
618 count_c <- countAll c
619 count_d <- countAll d
620 count_e <- countAll e
621 return $ sum [count_a, count_b, count_c,
622 count_d, count_e ]
623 actual @?= expected