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