]> gitweb.michael.orlitzky.com - dead/htsn-import.git/blob - TSN/XML/JFile.hs
Allow "TBA" laps in TSN.XML.AutoRacingSchedule.
[dead/htsn-import.git] / TSN / XML / JFile.hs
1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE GADTs #-}
3 {-# LANGUAGE QuasiQuotes #-}
4 {-# LANGUAGE RecordWildCards #-}
5 {-# LANGUAGE TemplateHaskell #-}
6 {-# LANGUAGE TypeFamilies #-}
7
8 -- | Parse TSN XML for the DTD \"jfilexml.dtd\". There's a top-level
9 -- \<message\>, containing a \<gamelist\>, containing
10 -- \<game\>s. Those games contain a bunch of other stuff. The
11 -- \<gamelist\> is pretty irrelevant; we ignore it and pretend that
12 -- a message contains a bunch of games.
13 --
14 module TSN.XML.JFile (
15 dtd,
16 pickle_message,
17 -- * Tests
18 jfile_tests,
19 -- * WARNING: these are private but exported to silence warnings
20 JFileConstructor(..),
21 JFileGameConstructor(..) )
22 where
23
24 -- System imports
25 import Control.Monad ( forM_ )
26 import Data.List ( intercalate )
27 import Data.String.Utils ( split )
28 import Data.Time ( UTCTime(..) )
29 import Data.Tuple.Curry ( uncurryN )
30 import Database.Groundhog (
31 countAll,
32 deleteAll,
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 xpTriple,
47 xp6Tuple,
48 xp14Tuple,
49 xp19Tuple,
50 xpAttr,
51 xpElem,
52 xpInt,
53 xpList,
54 xpOption,
55 xpPair,
56 xpPrim,
57 xpText,
58 xpText0,
59 xpWrap )
60
61
62 -- Local imports
63 import TSN.Codegen ( tsn_codegen_config )
64 import TSN.Database ( insert_or_select )
65 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
66 import TSN.Picklers (
67 xp_date,
68 xp_date_padded,
69 xp_datetime,
70 xp_time,
71 xp_time_dots,
72 xp_time_stamp )
73 import TSN.Team (
74 FromXmlFkTeams(..),
75 HTeam(..),
76 Team(..),
77 VTeam(..) )
78 import TSN.XmlImport (
79 XmlImport(..),
80 XmlImportFkTeams(..) )
81 import Xml (
82 Child(..),
83 FromXml(..),
84 ToDb(..),
85 pickle_unpickle,
86 unpickleable,
87 unsafe_unpickle )
88
89
90
91 -- | The DTD to which this module corresponds. Used to invoke dbimport.
92 --
93 dtd :: String
94 dtd = "jfilexml.dtd"
95
96 --
97 -- DB/XML data types
98 --
99
100 -- * JFile/Message
101
102 -- | Database representation of a 'Message'.
103 --
104 data JFile =
105 JFile {
106 db_xml_file_id :: Int,
107 db_heading :: String,
108 db_category :: String,
109 db_sport :: String,
110 db_time_stamp :: UTCTime }
111
112
113
114 -- | XML Representation of an 'JFile'.
115 --
116 data Message =
117 Message {
118 xml_xml_file_id :: Int,
119 xml_heading :: String,
120 xml_category :: String,
121 xml_sport :: String,
122 xml_gamelist :: JFileGameListXml,
123 xml_time_stamp :: UTCTime }
124 deriving (Eq, Show)
125
126
127 instance ToDb Message where
128 -- | The database analogue of a 'Message' is a 'JFile'.
129 --
130 type Db Message = JFile
131
132
133 -- | The 'FromXml' instance for 'Message' is required for the
134 -- 'XmlImport' instance.
135 --
136 instance FromXml Message where
137 -- | To convert a 'Message' to an 'JFile', we just drop
138 -- the 'xml_gamelist'.
139 --
140 from_xml Message{..} =
141 JFile {
142 db_xml_file_id = xml_xml_file_id,
143 db_heading = xml_heading,
144 db_category = xml_category,
145 db_sport = xml_sport,
146 db_time_stamp = xml_time_stamp }
147
148
149 -- | This allows us to insert the XML representation 'Message'
150 -- directly.
151 --
152 instance XmlImport Message
153
154
155
156 -- * JFileGame/JFileGameXml
157
158 -- | This is an embedded type within each JFileGame. It has its own
159 -- element, \<Odds_Info\>, but there's only one of them per game. So
160 -- essentially all of these fields belong to a 'JFileGame'. Aaaannnd
161 -- most of them are redundant. We'll (un)pickle them for good
162 -- measure, but in the conversion to the database type, we can drop
163 -- all of the redundant information.
164 --
165 -- All of these are optional because TSN does actually leave the
166 -- whole thing empty from time to time.
167 --
168 -- We stick \"info\" on the home/away team ids to avoid a name clash
169 -- with the game itself.
170 --
171 data JFileGameOddsInfo =
172 JFileGameOddsInfo {
173 db_list_date :: Maybe UTCTime,
174 db_info_home_team_id :: Maybe String, -- redundant (Team)
175 db_info_away_team_id :: Maybe String, -- redundant (Team)
176 db_home_abbr :: Maybe String, -- redundant (Team)
177 db_away_abbr :: Maybe String, -- redundant (Team)
178 db_home_team_name :: Maybe String, -- redundant (Team)
179 db_away_team_name :: Maybe String, -- redundant (Team)
180 db_home_starter :: Maybe String,
181 db_away_starter :: Maybe String,
182 db_game_date :: Maybe UTCTime, -- redundant (JFileGame)
183 db_home_game_key :: Maybe Int,
184 db_away_game_key :: Maybe Int,
185 db_current_timestamp :: Maybe UTCTime,
186 db_live :: Maybe Bool,
187 db_notes :: String }
188 deriving (Eq, Show)
189
190
191 -- | Another embedded type within 'JFileGame'. These look like,
192 -- \<status numeral=\"4\"\>FINAL\</status\> within the XML, but
193 -- they're in one-to-one correspondence with the games.
194 --
195 data JFileGameStatus =
196 JFileGameStatus {
197 db_status_numeral :: Int,
198 db_status :: Maybe String }
199 deriving (Eq, Show)
200
201
202 -- | Database representation of a \<game\> contained within a
203 -- \<message\>, and, implicitly, a \<gamelist\>.
204 --
205 -- We've left out the game date, opting instead to combine the
206 -- date/time into the 'db_game_time' field.
207 --
208 data JFileGame =
209 JFileGame {
210 db_jfile_id :: DefaultKey JFile,
211 db_away_team_id :: DefaultKey Team,
212 db_home_team_id :: DefaultKey Team,
213 db_game_id :: Int,
214 db_schedule_id :: Int,
215 db_odds_info :: JFileGameOddsInfo,
216 db_season_type :: Maybe String,
217 db_game_time :: UTCTime,
218 db_vleague :: Maybe String,
219 db_hleague :: Maybe String,
220 db_vscore :: Int,
221 db_hscore :: Int,
222 db_time_remaining :: Maybe String,
223 db_game_status :: JFileGameStatus }
224
225
226 -- | XML representation of a \<game\> contained within a \<message\>,
227 -- and a \<gamelist\>. The Away/Home teams seem to coincide with
228 -- those of 'OddsGame', so we're reusing the DB type via the common
229 -- 'TSN.Team' structure. But the XML types are different, because
230 -- they have different picklers!
231 --
232 data JFileGameXml =
233 JFileGameXml {
234 xml_game_id :: Int,
235 xml_schedule_id :: Int,
236 xml_odds_info :: JFileGameOddsInfo,
237 xml_season_type :: Maybe String,
238 xml_game_date :: UTCTime,
239 xml_game_time :: UTCTime,
240 xml_vteam :: VTeam,
241 xml_vleague :: Maybe String,
242 xml_hteam :: HTeam,
243 xml_hleague :: Maybe String,
244 xml_vscore :: Int,
245 xml_hscore :: Int,
246 xml_time_remaining :: Maybe String,
247 xml_game_status :: JFileGameStatus }
248 deriving (Eq, Show)
249
250
251 -- * JFileGameListXml
252
253 -- | The XML representation of \<message\> -> \<gamelist\>. This
254 -- element serves only to contain \<game\>s, so we don't store the
255 -- intermediate table in the database.
256 --
257 newtype JFileGameListXml =
258 JFileGameListXml {
259 xml_games ::
260 [JFileGameXml] }
261 deriving (Eq, Show)
262
263
264 instance ToDb JFileGameXml where
265 -- | The database analogue of an 'JFileGameXml' is
266 -- an 'JFileGame'.
267 --
268 type Db JFileGameXml = JFileGame
269
270
271 instance Child JFileGameXml where
272 -- | Each 'JFileGameXml' is contained in (i.e. has a foreign key to)
273 -- a 'JFile'.
274 --
275 type Parent JFileGameXml = JFile
276
277
278 instance FromXmlFkTeams JFileGameXml where
279 -- | To convert an 'JFileGameXml' to an 'JFileGame', we add the
280 -- foreign keys for JFile and the home/away teams. We also mash
281 -- the date/time together into one field.
282 --
283 from_xml_fk_teams fk fk_away fk_home JFileGameXml{..} =
284 JFileGame {
285 db_jfile_id = fk,
286 db_away_team_id = fk_away,
287 db_home_team_id = fk_home,
288 db_game_id = xml_game_id,
289 db_schedule_id = xml_schedule_id,
290 db_odds_info = xml_odds_info,
291 db_season_type = xml_season_type,
292 db_game_time = make_game_time xml_game_date xml_game_time,
293 db_vleague = xml_vleague,
294 db_hleague = xml_hleague,
295 db_vscore = xml_vscore,
296 db_hscore = xml_hscore,
297 db_time_remaining = xml_time_remaining,
298 db_game_status = xml_game_status }
299 where
300 -- | Make the database \"game time\" from the XML
301 -- date/time. Simply take the day part from one and the time
302 -- from the other.
303 --
304 make_game_time d t = UTCTime (utctDay d) (utctDayTime t)
305
306
307 -- | This allows us to insert the XML representation
308 -- 'JFileGameXml' directly.
309 --
310 instance XmlImportFkTeams JFileGameXml
311
312
313 ---
314 --- Database stuff.
315 ---
316
317 instance DbImport Message where
318 dbmigrate _ =
319 run_dbmigrate $ do
320 migrate (undefined :: Team)
321 migrate (undefined :: JFile)
322 migrate (undefined :: JFileGame)
323
324 dbimport m = do
325 -- Insert the top-level message
326 msg_id <- insert_xml m
327
328 -- Now loop through the message's games
329 forM_ (xml_games $ xml_gamelist m) $ \game -> do
330 -- First we insert the home and away teams.
331 away_team_id <- insert_or_select (vteam $ xml_vteam game)
332 home_team_id <- insert_or_select (hteam $ xml_hteam game)
333
334 -- Now insert the game keyed to the "jfile" and its teams.
335 insert_xml_fk_teams_ msg_id away_team_id home_team_id game
336
337
338 return ImportSucceeded
339
340
341 mkPersist tsn_codegen_config [groundhog|
342 - entity: JFile
343 dbName: jfile
344 constructors:
345 - name: JFile
346 uniques:
347 - name: unique_jfile
348 type: constraint
349 # Prevent multiple imports of the same message.
350 fields: [db_xml_file_id]
351
352 - embedded: JFileGameStatus
353 fields:
354 - name: db_status_numeral
355 dbName: status_numeral
356 - name: db_status
357 dbName: status
358
359 # Many of the JFileGameOddsInfo fields are redundant and have
360 # been left out.
361 - embedded: JFileGameOddsInfo
362 fields:
363 - name: db_list_date
364 dbName: list_date
365 - name: db_home_starter
366 dbName: home_starter
367 - name: db_home_game_key
368 dbName: home_game_key
369 - name: db_away_game_key
370 dbName: away_game_key
371 - name: db_current_timestamp
372 dbName: current_timestamp
373 - name: db_live
374 dbName: live
375 - name: db_notes
376 dbName: notes
377
378 - entity: JFileGame
379 dbName: jfile_games
380 constructors:
381 - name: JFileGame
382 fields:
383 - name: db_jfile_id
384 reference:
385 onDelete: cascade
386 - name: db_away_team_id
387 reference:
388 onDelete: cascade
389 - name: db_home_team_id
390 reference:
391 onDelete: cascade
392 - name: db_odds_info
393 embeddedType:
394 - {name: list_date, dbName: list_date}
395 - {name: home_starter, dbName: home_starter}
396 - {name: away_starter, dbName: away_starter}
397 - {name: home_game_key, dbName: home_game_key}
398 - {name: away_game_key, dbName: away_game_key}
399 - {name: current_timestamp, dbName: current_timestamp}
400 - {name: live, dbName: live}
401 - {name: notes, dbName: notes}
402 - name: db_game_status
403 embeddedType:
404 - {name: status_numeral, dbName: status_numeral}
405 - {name: status, dbName: status}
406
407 |]
408
409
410
411 ---
412 --- Pickling
413 ---
414
415 -- | Pickler for the top-level 'Message'.
416 --
417 pickle_message :: PU Message
418 pickle_message =
419 xpElem "message" $
420 xpWrap (from_tuple, to_tuple) $
421 xp6Tuple (xpElem "XML_File_ID" xpInt)
422 (xpElem "heading" xpText)
423 (xpElem "category" xpText)
424 (xpElem "sport" xpText)
425 pickle_gamelist
426 (xpElem "time_stamp" xp_time_stamp)
427 where
428 from_tuple = uncurryN Message
429 to_tuple m = (xml_xml_file_id m,
430 xml_heading m,
431 xml_category m,
432 xml_sport m,
433 xml_gamelist m,
434 xml_time_stamp m)
435
436 pickle_gamelist :: PU JFileGameListXml
437 pickle_gamelist =
438 xpElem "gamelist" $
439 xpWrap (to_result, from_result) $ xpList pickle_game
440 where
441 to_result = JFileGameListXml
442 from_result = xml_games
443
444
445
446
447 pickle_game :: PU JFileGameXml
448 pickle_game =
449 xpElem "game" $
450 xpWrap (from_tuple, to_tuple) $
451 xp14Tuple (xpElem "game_id" xpInt)
452 (xpElem "schedule_id" xpInt)
453 pickle_odds_info
454 (xpElem "seasontype" (xpOption xpText))
455 (xpElem "Game_Date" xp_date_padded)
456 (xpElem "Game_Time" xp_time)
457 pickle_away_team
458 (xpOption $ xpElem "vleague" xpText)
459 pickle_home_team
460 (xpOption $ xpElem "hleague" xpText)
461 (xpElem "vscore" xpInt)
462 (xpElem "hscore" xpInt)
463 (xpOption $ xpElem "time_r" xpText)
464 pickle_status
465 where
466 from_tuple = uncurryN JFileGameXml
467 to_tuple m = (xml_game_id m,
468 xml_schedule_id m,
469 xml_odds_info m,
470 xml_season_type m,
471 xml_game_date m,
472 xml_game_time m,
473 xml_vteam m,
474 xml_vleague m,
475 xml_hteam m,
476 xml_hleague m,
477 xml_vscore m,
478 xml_hscore m,
479 xml_time_remaining m,
480 xml_game_status m)
481
482 pickle_odds_info :: PU JFileGameOddsInfo
483 pickle_odds_info =
484 xpElem "Odds_Info" $
485 xpWrap (from_tuple, to_tuple) $
486 xp19Tuple (xpElem "ListDate" (xpOption xp_date))
487 (xpElem "HomeTeamID" (xpOption xpText))
488 (xpElem "AwayTeamID" (xpOption xpText))
489 (xpElem "HomeAbbr" (xpOption xpText))
490 (xpElem "AwayAbbr" (xpOption xpText))
491 (xpElem "HomeTeamName" (xpOption xpText))
492 (xpElem "AwayTeamName" (xpOption xpText))
493 (xpElem "HStarter" (xpOption xpText))
494 (xpElem "AStarter" (xpOption xpText))
495 (xpElem "GameDate" (xpOption xp_datetime))
496 (xpElem "HGameKey" (xpOption xpInt))
497 (xpElem "AGameKey" (xpOption xpInt))
498 (xpElem "CurrentTimeStamp" (xpOption xp_time_dots))
499 (xpElem "Live" (xpOption xpPrim))
500 (xpElem "Notes1" xpText0)
501 (xpElem "Notes2" xpText0)
502 (xpElem "Notes3" xpText0)
503 (xpElem "Notes4" xpText0)
504 (xpElem "Notes5" xpText0)
505 where
506 from_tuple (x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,n1,n2,n3,n4,n5) =
507 JFileGameOddsInfo x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 notes
508 where
509 notes = intercalate "\n" [n1,n2,n3,n4,n5]
510
511 to_tuple o = (db_list_date o,
512 db_info_home_team_id o,
513 db_info_away_team_id o,
514 db_home_abbr o,
515 db_away_abbr o,
516 db_home_team_name o,
517 db_away_team_name o,
518 db_home_starter o,
519 db_away_starter o,
520 db_game_date o,
521 db_home_game_key o,
522 db_away_game_key o,
523 db_current_timestamp o,
524 db_live o,
525 n1,n2,n3,n4,n5)
526 where
527 note_lines = split "\n" (db_notes o)
528 n1 = case note_lines of
529 (notes1:_) -> notes1
530 _ -> ""
531 n2 = case note_lines of
532 (_:notes2:_) -> notes2
533 _ -> ""
534 n3 = case note_lines of
535 (_:_:notes3:_) -> notes3
536 _ -> ""
537 n4 = case note_lines of
538 (_:_:_:notes4:_) -> notes4
539 _ -> ""
540 n5 = case note_lines of
541 (_:_:_:_:notes5:_) -> notes5
542 _ -> ""
543
544 -- | (Un)pickle a home team to/from the dual XML/DB representation
545 -- 'Team'.
546 --
547 pickle_home_team :: PU HTeam
548 pickle_home_team =
549 xpElem "hteam" $
550 xpWrap (from_tuple, to_tuple) $
551 xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text.
552 (xpAttr "abbr" (xpOption xpText)) -- Some are blank
553 (xpOption xpText) -- Yup, some are nameless
554 where
555 from_tuple = HTeam . (uncurryN Team)
556 to_tuple (HTeam t) = (team_id t,
557 abbreviation t,
558 name t)
559
560
561 -- | (Un)pickle an away team to/from the dual XML/DB representation
562 -- 'Team'.
563 --
564 pickle_away_team :: PU VTeam
565 pickle_away_team =
566 xpElem "vteam" $
567 xpWrap (from_tuple, to_tuple) $
568 xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text.
569 (xpAttr "abbr" (xpOption xpText)) -- Some are blank
570 (xpOption xpText) -- Yup, some are nameless
571 where
572 from_tuple = VTeam . (uncurryN Team)
573 to_tuple (VTeam t) = (team_id t,
574 abbreviation t,
575 name t)
576
577
578 pickle_status :: PU JFileGameStatus
579 pickle_status =
580 xpElem "status" $
581 xpWrap (from_tuple, to_tuple) $
582 xpPair (xpAttr "numeral" xpInt)
583 (xpOption xpText)
584 where
585 from_tuple = uncurry JFileGameStatus
586 to_tuple s = (db_status_numeral s,
587 db_status s)
588
589
590
591 --
592 -- Tasty Tests
593 --
594
595 -- | A list of all tests for this module.
596 --
597 jfile_tests :: TestTree
598 jfile_tests =
599 testGroup
600 "JFile tests"
601 [ test_on_delete_cascade,
602 test_pickle_of_unpickle_is_identity,
603 test_unpickle_succeeds ]
604
605
606 -- | If we unpickle something and then pickle it, we should wind up
607 -- with the same thing we started with. WARNING: success of this
608 -- test does not mean that unpickling succeeded.
609 --
610 test_pickle_of_unpickle_is_identity :: TestTree
611 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
612 [ check "pickle composed with unpickle is the identity"
613 "test/xml/jfilexml.xml",
614 check "pickle composed with unpickle is the identity (missing fields)"
615 "test/xml/jfilexml-missing-fields.xml" ]
616 where
617 check desc path = testCase desc $ do
618 (expected, actual) <- pickle_unpickle pickle_message path
619 actual @?= expected
620
621
622
623 -- | Make sure we can actually unpickle these things.
624 --
625 test_unpickle_succeeds :: TestTree
626 test_unpickle_succeeds = testGroup "unpickle tests"
627 [ check "unpickling succeeds" "test/xml/jfilexml.xml",
628 check "unpickling succeeds (missing fields)"
629 "test/xml/jfilexml-missing-fields.xml" ]
630 where
631 check desc path = testCase desc $ do
632 actual <- unpickleable path pickle_message
633
634 let expected = True
635 actual @?= expected
636
637
638
639 -- | Make sure everything gets deleted when we delete the top-level
640 -- record.
641 --
642 test_on_delete_cascade :: TestTree
643 test_on_delete_cascade = testGroup "cascading delete tests"
644 [ check "deleting auto_racing_results deletes its children"
645 "test/xml/jfilexml.xml"
646 20,
647 check "deleting auto_racing_results deletes its children (missing fields)"
648 "test/xml/jfilexml-missing-fields.xml"
649 44 ]
650 where
651 check desc path expected = testCase desc $ do
652 results <- unsafe_unpickle path pickle_message
653 let a = undefined :: Team
654 let b = undefined :: JFile
655 let c = undefined :: JFileGame
656
657 actual <- withSqliteConn ":memory:" $ runDbConn $ do
658 runMigration silentMigrationLogger $ do
659 migrate a
660 migrate b
661 migrate c
662 _ <- dbimport results
663 deleteAll b
664 count_a <- countAll a
665 count_b <- countAll b
666 count_c <- countAll c
667 return $ sum [count_a, count_b, count_c]
668 actual @?= expected