]> gitweb.michael.orlitzky.com - dead/htsn-import.git/blob - src/TSN/XML/Scores.hs
Add a minor TODO note.
[dead/htsn-import.git] / src / TSN / 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_ScoreLocationConstructor(..),
19 ScoreConstructor(..),
20 ScoreGameConstructor(..),
21 ScoreGameTeamConstructor(..),
22 ScoreLocationConstructor(..),
23 ScoreGame_ScoreGameTeamConstructor(..) )
24 where
25
26 -- System imports.
27 import Data.Data ( Data )
28 import Data.Time ( UTCTime )
29 import Data.Tuple.Curry ( uncurryN )
30 import Data.Typeable ( Typeable )
31 import Database.Groundhog (
32 countAll,
33 deleteAll,
34 insert,
35 insert_,
36 migrate,
37 runMigration,
38 silentMigrationLogger )
39 import Database.Groundhog.Core ( DefaultKey )
40 import Database.Groundhog.Generic ( runDbConn )
41 import Database.Groundhog.Sqlite ( withSqliteConn )
42 import Database.Groundhog.TH (
43 defaultCodegenConfig,
44 groundhog,
45 mkPersist )
46 import Test.Tasty ( TestTree, testGroup )
47 import Test.Tasty.HUnit ( (@?=), testCase )
48 import Text.XML.HXT.Core (
49 PU,
50 xp7Tuple,
51 xp11Tuple,
52 xpAttr,
53 xpElem,
54 xpInt,
55 xpList,
56 xpOption,
57 xpPair,
58 xpPrim,
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_time_stamp )
68 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
69 import Xml (
70 FromXml(..),
71 FromXmlFk(..),
72 ToDb(..),
73 pickle_unpickle,
74 unpickleable,
75 unsafe_unpickle )
76
77
78 -- | The DTD to which this module corresponds. Used to invoke dbimport.
79 --
80 dtd :: String
81 dtd = "scoresxml.dtd"
82
83
84 ---
85 --- DB/XML Data types
86 ---
87
88
89 -- * Score / Message
90
91 -- | Database representation of a 'Message'. It lacks the
92 -- 'xml_locations' and 'xml_game' which are related via foreign keys
93 -- instead.
94 --
95 data Score =
96 Score {
97 db_xml_file_id :: Int,
98 db_heading :: String,
99 db_game_id :: Int,
100 db_schedule_id :: Int,
101 db_tsnupdate :: Maybe Bool,
102 db_category :: String,
103 db_sport :: String,
104 db_season_type :: String,
105 db_time_stamp :: UTCTime }
106
107
108 -- | XML representation of the top level \<message\> element (i.e. a
109 -- 'Score').
110 --
111 data Message =
112 Message {
113 xml_xml_file_id :: Int,
114 xml_heading :: String,
115 xml_game_id :: Int,
116 xml_schedule_id :: Int,
117 xml_tsnupdate :: Maybe Bool,
118 xml_category :: String,
119 xml_sport :: String,
120 xml_locations :: [ScoreLocation],
121 xml_season_type :: String,
122 xml_game :: ScoreGameXml,
123 xml_time_stamp :: UTCTime }
124 deriving (Eq, Show)
125
126 instance ToDb Message where
127 -- | The database representation of a 'Message' is a 'Score'.
128 type Db Message = Score
129
130 instance FromXml Message where
131 from_xml Message{..} =
132 Score {
133 db_xml_file_id = xml_xml_file_id,
134 db_heading = xml_heading,
135 db_game_id = xml_game_id,
136 db_schedule_id = xml_schedule_id,
137 db_tsnupdate = xml_tsnupdate,
138 db_category = xml_category,
139 db_sport = xml_sport,
140 db_season_type = xml_season_type,
141 db_time_stamp = xml_time_stamp }
142
143
144 -- | This lets us insert the XML representation 'Message' directly.
145 --
146 instance XmlImport Message
147
148
149 -- * ScoreGame / ScoreGameXml
150
151 -- | This is an embedded field within 'SportsGame'. Each \<status\>
152 -- element has two attributes, a numeral and a type. It also
153 -- contains some text. Rather than put these in their own table, we
154 -- include them in the parent 'SportsGame'.
155 --
156 data ScoreGameStatus =
157 ScoreGameStatus {
158 db_status_numeral :: Int,
159 db_status_type :: String, -- ^ These are probably only one-character long,
160 -- but they all take the same amount of space
161 -- in Postgres.
162 db_status_text :: String }
163 deriving (Data, Eq, Show, Typeable)
164
165
166 -- | Database representation of a game.
167 --
168 data ScoreGame =
169 ScoreGame {
170 db_scores_id :: DefaultKey Score,
171 db_vscore :: Int,
172 db_hscore :: Int,
173 db_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
174 db_status :: ScoreGameStatus,
175 db_notes :: Maybe String }
176
177
178 -- | XML representation of a \<game\> element (i.e. a 'ScoreGame').
179 --
180 data ScoreGameXml =
181 ScoreGameXml {
182 xml_vteam :: ScoreGameVTeam,
183 xml_hteam :: ScoreGameHTeam,
184 xml_vscore :: Int,
185 xml_hscore :: Int,
186 xml_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
187 xml_status :: ScoreGameStatus,
188 xml_notes :: Maybe String }
189 deriving (Eq, Show)
190
191 -- | Pseudo-accessor to get the 'ScoreGameTeam' out of 'xml_vteam'.
192 vteam :: ScoreGameXml -> ScoreGameTeam
193 vteam g = let (ScoreGameVTeam t) = xml_vteam g in t
194
195 -- | Pseudo-accessor to get the 'ScoreGameTeam' out of 'xml_hteam'.
196 hteam :: ScoreGameXml -> ScoreGameTeam
197 hteam g = let (ScoreGameHTeam t) = xml_hteam g in t
198
199 instance ToDb ScoreGameXml where
200 -- | The database representation of a 'ScoreGameXml' is a
201 -- 'ScoreGame'.
202 --
203 type Db ScoreGameXml = ScoreGame
204
205 instance FromXmlFk ScoreGameXml where
206 -- | Each 'ScoreGameXml' is contained in (i.e. has a foreign key to)
207 -- a 'Score'.
208 --
209 type Parent ScoreGameXml = Score
210
211 from_xml_fk fk ScoreGameXml{..} =
212 ScoreGame {
213 db_scores_id = fk,
214 db_vscore = xml_vscore,
215 db_hscore = xml_hscore,
216 db_time_r = xml_time_r,
217 db_status = xml_status,
218 db_notes = xml_notes }
219
220 -- | This lets us import the database representation 'ScoreGameXml'
221 -- directly.
222 --
223 instance XmlImportFk ScoreGameXml
224
225
226 -- * ScoreGameTeam
227
228 -- | A team that appears in a 'ScoreGame'. This is meant to represent
229 -- both home and away teams.
230 --
231 data ScoreGameTeam =
232 ScoreGameTeam {
233 team_id :: String,
234 team_name :: String }
235 deriving (Eq, Show)
236
237 -- | A wrapper around 'ScoreGameTeam' that lets us distinguish between
238 -- home and away teams. See also 'ScoreGameHTeam'.
239 --
240 newtype ScoreGameVTeam =
241 ScoreGameVTeam ScoreGameTeam
242 deriving (Eq, Show)
243
244
245 -- | A wrapper around 'ScoreGameTeam' that lets us distinguish between
246 -- home and away teams. See also 'ScoreGameVTeam'.
247 --
248 newtype ScoreGameHTeam =
249 ScoreGameHTeam ScoreGameTeam
250 deriving (Eq, Show)
251
252
253 -- * ScoreGame_ScoreGameTeam
254
255 -- | Join a 'ScoreGame' with its home/away teams. Database-only. We
256 -- use a join table because the teams are kept unique.
257 --
258 data ScoreGame_ScoreGameTeam =
259 ScoreGame_ScoreGameTeam
260 (DefaultKey ScoreGame) -- ^ game id
261 (DefaultKey ScoreGameTeam) -- ^ vteam id
262 (DefaultKey ScoreGameTeam) -- ^ hteam id
263
264
265 -- * ScoreLocation
266
267 -- | Database and XML representation of a \<location\>. This is almost
268 -- identical to 'TSN.XML.NewsLocation', but the city/state have not
269 -- appeared optional here so far.
270 --
271 data ScoreLocation =
272 ScoreLocation {
273 city :: String,
274 state :: String,
275 country :: String }
276 deriving (Eq, Show)
277
278
279 -- * Score_ScoreLocation
280
281 -- | Join each 'Score' with its 'ScoreLocation's. Database-only. We
282 -- use a join table because the locations are kept unique.
283 --
284 data Score_ScoreLocation =
285 Score_ScoreLocation
286 (DefaultKey Score)
287 (DefaultKey ScoreLocation)
288
289
290
291 instance DbImport Message where
292 dbmigrate _ =
293 run_dbmigrate $ do
294 migrate (undefined :: Score)
295 migrate (undefined :: ScoreGame)
296 migrate (undefined :: ScoreGameTeam)
297 migrate (undefined :: ScoreGame_ScoreGameTeam)
298 migrate (undefined :: ScoreLocation)
299 migrate (undefined :: Score_ScoreLocation)
300
301 dbimport m = do
302 -- Insert the message and get its ID.
303 msg_id <- insert_xml m
304
305 -- Insert all of the locations contained within this message and
306 -- collect their IDs in a list.
307 location_ids <- mapM insert (xml_locations m)
308
309 -- Now use that list to construct 'Score_ScoreLocation' objects,
310 -- and insert them.
311 mapM_ (insert_ . Score_ScoreLocation msg_id) location_ids
312
313 -- Insert the game and its hteam/vteam, noting the IDs.
314 game_id <- insert_xml_fk msg_id (xml_game m)
315 vteam_id <- insert (vteam $ xml_game m)
316 hteam_id <- insert (hteam $ xml_game m)
317
318 -- Finally add a 'ScoreGame_ScoreGameTeam' mapping the
319 -- aforementioned game to its hteam/vteam.
320 insert_ $ ScoreGame_ScoreGameTeam game_id vteam_id hteam_id
321
322 return ImportSucceeded
323
324
325 -- These types don't have special XML representations or field name
326 -- collisions so we use the defaultCodegenConfig and give their
327 -- fields nice simple names.
328 mkPersist defaultCodegenConfig [groundhog|
329 - entity: ScoreGameTeam
330 dbName: scores_games_teams
331 constructors:
332 - name: ScoreGameTeam
333 uniques:
334 - name: unique_scores_games_team
335 type: constraint
336 fields: [team_id]
337
338 - entity: ScoreLocation
339 dbName: scores_locations
340 constructors:
341 - name: ScoreLocation
342 uniques:
343 - name: unique_scores_location
344 type: constraint
345 fields: [city, state, country]
346
347 |]
348
349
350
351 -- These types have fields with e.g. db_ and xml_ prefixes, so we
352 -- use our own codegen to peel those off before naming the columns.
353 mkPersist tsn_codegen_config [groundhog|
354 - entity: Score
355 dbName: scores
356 constructors:
357 - name: Score
358 uniques:
359 - name: unique_scores
360 type: constraint
361 # Prevent multiple imports of the same message.
362 fields: [db_xml_file_id]
363
364 - embedded: ScoreGameStatus
365 fields:
366 - name: db_status_numeral
367 dbName: status_numeral
368 - name: db_status_type
369 dbName: status_type
370 - name: db_status_text
371 dbName: status_text
372
373 - entity: ScoreGame
374 dbName: scores_games
375 constructors:
376 - name: ScoreGame
377 fields:
378 - name: db_scores_id
379 reference:
380 onDelete: cascade
381 - name: db_status
382 embeddedType:
383 - { name: status_numeral, dbName: status_numeral }
384 - { name: status_type, dbName: status_type }
385 - { name: status_text, dbName: status_text }
386
387 - entity: ScoreGame_ScoreGameTeam
388 dbName: scores_games__scores_games_teams
389 constructors:
390 - name: ScoreGame_ScoreGameTeam
391 fields:
392 - name: scoreGame_ScoreGameTeam0 # Default created by mkNormalFieldName
393 dbName: scores_games_id
394 reference:
395 onDelete: cascade
396 - name: scoreGame_ScoreGameTeam1 # Default created by mkNormalFieldName
397 dbName: scores_games_teams_vteam_id
398 reference:
399 onDelete: cascade
400 - name: scoreGame_ScoreGameTeam2 # Default created by mkNormalFieldName
401 dbName: scores_games_teams_hteam_id
402 reference:
403 onDelete: cascade
404
405 - entity: Score_ScoreLocation
406 dbName: scores__scores_locations
407 constructors:
408 - name: Score_ScoreLocation
409 fields:
410 - name: score_ScoreLocation0 # Default created by mkNormalFieldName
411 dbName: scores_id
412 reference:
413 onDelete: cascade
414 - name: score_ScoreLocation1 # Default created by mkNormalFieldName
415 dbName: scores_locations_id
416 reference:
417 onDelete: cascade
418 |]
419
420
421 --
422 -- Pickling
423 --
424
425 -- | Convert a 'Message' to/from \<message\>.
426 --
427 pickle_message :: PU Message
428 pickle_message =
429 xpElem "message" $
430 xpWrap (from_tuple, to_tuple) $
431 xp11Tuple (xpElem "XML_File_ID" xpInt)
432 (xpElem "heading" xpText)
433 (xpElem "game_id" xpInt)
434 (xpElem "schedule_id" xpInt)
435 (xpOption $ xpElem "tsnupdate" xpPrim)
436 (xpElem "category" xpText)
437 (xpElem "sport" xpText)
438 (xpList pickle_location)
439 (xpElem "seasontype" xpText)
440 pickle_game
441 (xpElem "time_stamp" xp_time_stamp)
442 where
443 from_tuple = uncurryN Message
444 to_tuple m = (xml_xml_file_id m,
445 xml_heading m,
446 xml_game_id m,
447 xml_schedule_id m,
448 xml_tsnupdate m,
449 xml_category m,
450 xml_sport m,
451 xml_locations m,
452 xml_season_type m,
453 xml_game m,
454 xml_time_stamp m)
455
456
457
458 -- | Convert a 'ScoreLocation' to/from \<location\>.
459 --
460 pickle_location :: PU ScoreLocation
461 pickle_location =
462 xpElem "location" $
463 xpWrap (from_tuple, to_tuple) $
464 xpTriple (xpElem "city" xpText)
465 (xpElem "state" xpText)
466 (xpElem "country" xpText)
467 where
468 from_tuple =
469 uncurryN ScoreLocation
470 to_tuple l = (city l, state l, country l)
471
472
473 -- | Convert a 'ScoreGameStatus' to/from \<status\>.
474 --
475 pickle_status :: PU ScoreGameStatus
476 pickle_status =
477 xpElem "status" $
478 xpWrap (from_tuple, to_tuple) $
479 xpTriple (xpAttr "numeral" xpInt)
480 (xpAttr "type" xpText)
481 xpText
482 where
483 from_tuple = uncurryN ScoreGameStatus
484 to_tuple ScoreGameStatus{..} = (db_status_numeral,
485 db_status_type,
486 db_status_text)
487
488
489 -- | Convert a 'ScoreGameXml' to/from \<game\>.
490 --
491 pickle_game :: PU ScoreGameXml
492 pickle_game =
493 xpElem "game" $
494 xpWrap (from_tuple, to_tuple) $
495 xp7Tuple pickle_vteam
496 pickle_hteam
497 (xpElem "vscore" xpInt)
498 (xpElem "hscore" xpInt)
499 (xpOption $ xpElem "time_r" xpText)
500 pickle_status
501 (xpOption $ xpElem "notes" xpText)
502 where
503 from_tuple = uncurryN ScoreGameXml
504 to_tuple ScoreGameXml{..} = (xml_vteam,
505 xml_hteam,
506 xml_vscore,
507 xml_hscore,
508 xml_time_r,
509 xml_status,
510 xml_notes)
511
512
513 -- | Convert a 'ScoreGameVTeam' to/from \<vteam\>.
514 --
515 pickle_vteam :: PU ScoreGameVTeam
516 pickle_vteam =
517 xpElem "vteam" $
518 xpWrap (from_tuple, to_tuple) $
519 xpPair (xpAttr "id" xpText)
520 xpText
521 where
522 from_tuple = ScoreGameVTeam . uncurry ScoreGameTeam
523 to_tuple (ScoreGameVTeam ScoreGameTeam{..}) = (team_id, team_name)
524
525
526 -- | Convert a 'ScoreGameVTeam' to/from \<hteam\>. Identical to
527 -- 'pickle_vteam' modulo the \"h\" and \"v\".
528 --
529 pickle_hteam :: PU ScoreGameHTeam
530 pickle_hteam =
531 xpElem "hteam" $
532 xpWrap (from_tuple, to_tuple) $
533 xpPair (xpAttr "id" xpText)
534 xpText
535 where
536 from_tuple = ScoreGameHTeam . uncurry ScoreGameTeam
537 to_tuple (ScoreGameHTeam ScoreGameTeam{..}) = (team_id, team_name)
538
539
540
541 ---
542 --- Tasty tests
543 ---
544
545 -- | A list of all tests for this module.
546 --
547 scores_tests :: TestTree
548 scores_tests =
549 testGroup
550 "Scores tests"
551 [ test_on_delete_cascade,
552 test_pickle_of_unpickle_is_identity,
553 test_unpickle_succeeds ]
554
555
556 -- | If we unpickle something and then pickle it, we should wind up
557 -- with the same thing we started with. WARNING: success of this
558 -- test does not mean that unpickling succeeded.
559 --
560 test_pickle_of_unpickle_is_identity :: TestTree
561 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
562 [ check "pickle composed with unpickle is the identity"
563 "test/xml/scoresxml.xml",
564
565 check "pickle composed with unpickle is the identity (no locations)"
566 "test/xml/scoresxml-no-locations.xml" ]
567 where
568 check desc path = testCase desc $ do
569 (expected, actual) <- pickle_unpickle pickle_message path
570 actual @?= expected
571
572
573 -- | Make sure we can actually unpickle these things.
574 --
575 test_unpickle_succeeds :: TestTree
576 test_unpickle_succeeds = testGroup "unpickle tests"
577 [ check "unpickling succeeds"
578 "test/xml/scoresxml.xml",
579
580 check "unpickling succeeds (no locations)"
581 "test/xml/scoresxml-no-locations.xml" ]
582 where
583 check desc path = testCase desc $ do
584 actual <- unpickleable path pickle_message
585 let expected = True
586 actual @?= expected
587
588
589 -- | Make sure everything gets deleted when we delete the top-level
590 -- record.
591 --
592 test_on_delete_cascade :: TestTree
593 test_on_delete_cascade = testGroup "cascading delete tests"
594 [ check "unpickling succeeds"
595 "test/xml/scoresxml.xml"
596 4, -- 2 teams, 2 locations
597
598 check "unpickling succeeds (no locations)"
599 "test/xml/scoresxml-no-locations.xml"
600 2 -- 2 teams, 0 locations
601 ]
602 where
603 check desc path expected = testCase desc $ do
604 score <- unsafe_unpickle path pickle_message
605 let a = undefined :: Score
606 let b = undefined :: ScoreGame
607 let c = undefined :: ScoreGameTeam
608 let d = undefined :: ScoreGame_ScoreGameTeam
609 let e = undefined :: ScoreLocation
610 let f = undefined :: Score_ScoreLocation
611 actual <- withSqliteConn ":memory:" $ runDbConn $ do
612 runMigration silentMigrationLogger $ do
613 migrate a
614 migrate b
615 migrate c
616 migrate d
617 migrate e
618 migrate f
619 _ <- dbimport score
620 -- No idea how 'delete' works, so do this instead.
621 deleteAll a
622 count_a <- countAll a
623 count_b <- countAll b
624 count_c <- countAll c
625 count_d <- countAll d
626 count_e <- countAll e
627 count_f <- countAll f
628 return $ sum [count_a, count_b, count_c,
629 count_d, count_e, count_f ]
630 actual @?= expected