1 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE QuasiQuotes #-}
4 {-# LANGUAGE RecordWildCards #-}
5 {-# LANGUAGE TemplateHaskell #-}
6 {-# LANGUAGE TypeFamilies #-}
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.
14 module TSN.XML.JFile (
19 -- * WARNING: these are private but exported to silence warnings
21 JFileGameConstructor(..) )
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 (
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 (
42 import Test.Tasty ( TestTree, testGroup )
43 import Test.Tasty.HUnit ( (@?=), testCase )
44 import Text.XML.HXT.Core (
63 import TSN.Codegen ( tsn_codegen_config )
64 import TSN.Database ( insert_or_select )
65 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
78 import TSN.XmlImport (
80 XmlImportFkTeams(..) )
91 -- | The DTD to which this module corresponds. Used to invoke dbimport.
102 -- | Database representation of a 'Message'.
106 db_xml_file_id :: Int,
107 db_heading :: String,
108 db_category :: String,
110 db_time_stamp :: UTCTime }
114 -- | XML Representation of an 'JFile'.
118 xml_xml_file_id :: Int,
119 xml_heading :: String,
120 xml_category :: String,
122 xml_gamelist :: JFileGameListXml,
123 xml_time_stamp :: UTCTime }
127 instance ToDb Message where
128 -- | The database analogue of a 'Message' is a 'JFile'.
130 type Db Message = JFile
133 -- | The 'FromXml' instance for 'Message' is required for the
134 -- 'XmlImport' instance.
136 instance FromXml Message where
137 -- | To convert a 'Message' to an 'JFile', we just drop
138 -- the 'xml_gamelist'.
140 from_xml Message{..} =
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 }
149 -- | This allows us to insert the XML representation 'Message'
152 instance XmlImport Message
156 -- * JFileGame/JFileGameXml
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.
165 -- All of these are optional because TSN does actually leave the
166 -- whole thing empty from time to time.
168 -- We stick \"info\" on the home/away team ids to avoid a name clash
169 -- with the game itself.
171 data 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,
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.
195 data JFileGameStatus =
197 db_status_numeral :: Int,
198 db_status :: Maybe String }
202 -- | Database representation of a \<game\> contained within a
203 -- \<message\>, and, implicitly, a \<gamelist\>.
205 -- We've left out the game date, opting instead to combine the
206 -- date/time into the 'db_game_time' field.
210 db_jfile_id :: DefaultKey JFile,
211 db_away_team_id :: DefaultKey Team,
212 db_home_team_id :: DefaultKey Team,
214 db_schedule_id :: Int,
215 db_odds_info :: JFileGameOddsInfo,
216 db_season_type :: Maybe String,
217 db_game_time :: Maybe UTCTime,
218 db_vleague :: Maybe String,
219 db_hleague :: Maybe String,
222 db_time_remaining :: Maybe String,
223 db_game_status :: JFileGameStatus }
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!
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 :: Maybe UTCTime,
241 xml_vleague :: Maybe String,
243 xml_hleague :: Maybe String,
246 xml_time_remaining :: Maybe String,
247 xml_game_status :: JFileGameStatus }
251 -- * JFileGameListXml
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.
257 newtype JFileGameListXml =
264 instance ToDb JFileGameXml where
265 -- | The database analogue of an 'JFileGameXml' is
268 type Db JFileGameXml = JFileGame
271 instance Child JFileGameXml where
272 -- | Each 'JFileGameXml' is contained in (i.e. has a foreign key to)
275 type Parent JFileGameXml = JFile
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.
283 from_xml_fk_teams fk fk_away fk_home JFileGameXml{..} =
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 }
300 -- | Construct the database game time from the XML \<Game_Date\>
301 -- and \<Game_Time\> elements. The \<Game_Time\> elements
302 -- sometimes have a value of \"TBA\"; in that case, we don't
303 -- want to pretend that we know the time by setting it to
304 -- e.g. midnight, so instead we make the entire date/time
306 make_game_time :: UTCTime -> Maybe UTCTime -> Maybe UTCTime
307 make_game_time _ Nothing = Nothing
308 make_game_time d (Just t) = Just $ UTCTime (utctDay d) (utctDayTime t)
311 -- | This allows us to insert the XML representation
312 -- 'JFileGameXml' directly.
314 instance XmlImportFkTeams JFileGameXml
321 instance DbImport Message where
324 migrate (undefined :: Team)
325 migrate (undefined :: JFile)
326 migrate (undefined :: JFileGame)
329 -- Insert the top-level message
330 msg_id <- insert_xml m
332 -- Now loop through the message's games
333 forM_ (xml_games $ xml_gamelist m) $ \game -> do
334 -- First we insert the home and away teams.
335 away_team_id <- insert_or_select (vteam $ xml_vteam game)
336 home_team_id <- insert_or_select (hteam $ xml_hteam game)
338 -- Now insert the game keyed to the "jfile" and its teams.
339 insert_xml_fk_teams_ msg_id away_team_id home_team_id game
342 return ImportSucceeded
345 mkPersist tsn_codegen_config [groundhog|
353 # Prevent multiple imports of the same message.
354 fields: [db_xml_file_id]
356 - embedded: JFileGameStatus
358 - name: db_status_numeral
359 dbName: status_numeral
363 # Many of the JFileGameOddsInfo fields are redundant and have
365 - embedded: JFileGameOddsInfo
369 - name: db_home_starter
371 - name: db_home_game_key
372 dbName: home_game_key
373 - name: db_away_game_key
374 dbName: away_game_key
375 - name: db_current_timestamp
376 dbName: current_timestamp
390 - name: db_away_team_id
393 - name: db_home_team_id
398 - {name: list_date, dbName: list_date}
399 - {name: home_starter, dbName: home_starter}
400 - {name: away_starter, dbName: away_starter}
401 - {name: home_game_key, dbName: home_game_key}
402 - {name: away_game_key, dbName: away_game_key}
403 - {name: current_timestamp, dbName: current_timestamp}
404 - {name: live, dbName: live}
405 - {name: notes, dbName: notes}
406 - name: db_game_status
408 - {name: status_numeral, dbName: status_numeral}
409 - {name: status, dbName: status}
419 -- | Pickler for the top-level 'Message'.
421 pickle_message :: PU Message
424 xpWrap (from_tuple, to_tuple) $
425 xp6Tuple (xpElem "XML_File_ID" xpInt)
426 (xpElem "heading" xpText)
427 (xpElem "category" xpText)
428 (xpElem "sport" xpText)
430 (xpElem "time_stamp" xp_time_stamp)
432 from_tuple = uncurryN Message
433 to_tuple m = (xml_xml_file_id m,
440 pickle_gamelist :: PU JFileGameListXml
443 xpWrap (to_result, from_result) $ xpList pickle_game
445 to_result = JFileGameListXml
446 from_result = xml_games
451 pickle_game :: PU JFileGameXml
454 xpWrap (from_tuple, to_tuple) $
455 xp14Tuple (xpElem "game_id" xpInt)
456 (xpElem "schedule_id" xpInt)
458 (xpElem "seasontype" (xpOption xpText))
459 (xpElem "Game_Date" xp_date_padded)
460 (xpElem "Game_Time" xp_tba_time)
462 (xpOption $ xpElem "vleague" xpText)
464 (xpOption $ xpElem "hleague" xpText)
465 (xpElem "vscore" xpInt)
466 (xpElem "hscore" xpInt)
467 (xpOption $ xpElem "time_r" xpText)
470 from_tuple = uncurryN JFileGameXml
471 to_tuple m = (xml_game_id m,
483 xml_time_remaining m,
486 pickle_odds_info :: PU JFileGameOddsInfo
489 xpWrap (from_tuple, to_tuple) $
490 xp19Tuple (xpElem "ListDate" (xpOption xp_date))
491 (xpElem "HomeTeamID" (xpOption xpText))
492 (xpElem "AwayTeamID" (xpOption xpText))
493 (xpElem "HomeAbbr" (xpOption xpText))
494 (xpElem "AwayAbbr" (xpOption xpText))
495 (xpElem "HomeTeamName" (xpOption xpText))
496 (xpElem "AwayTeamName" (xpOption xpText))
497 (xpElem "HStarter" (xpOption xpText))
498 (xpElem "AStarter" (xpOption xpText))
499 (xpElem "GameDate" (xpOption xp_datetime))
500 (xpElem "HGameKey" (xpOption xpInt))
501 (xpElem "AGameKey" (xpOption xpInt))
502 (xpElem "CurrentTimeStamp" (xpOption xp_time_dots))
503 (xpElem "Live" (xpOption xpPrim))
504 (xpElem "Notes1" xpText0)
505 (xpElem "Notes2" xpText0)
506 (xpElem "Notes3" xpText0)
507 (xpElem "Notes4" xpText0)
508 (xpElem "Notes5" xpText0)
510 from_tuple (x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,n1,n2,n3,n4,n5) =
511 JFileGameOddsInfo x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 notes
513 notes = intercalate "\n" [n1,n2,n3,n4,n5]
515 to_tuple o = (db_list_date o,
516 db_info_home_team_id o,
517 db_info_away_team_id o,
527 db_current_timestamp o,
531 note_lines = split "\n" (db_notes o)
532 n1 = case note_lines of
535 n2 = case note_lines of
536 (_:notes2:_) -> notes2
538 n3 = case note_lines of
539 (_:_:notes3:_) -> notes3
541 n4 = case note_lines of
542 (_:_:_:notes4:_) -> notes4
544 n5 = case note_lines of
545 (_:_:_:_:notes5:_) -> notes5
548 -- | (Un)pickle a home team to/from the dual XML/DB representation
551 pickle_home_team :: PU HTeam
554 xpWrap (from_tuple, to_tuple) $
555 xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text.
556 (xpAttr "abbr" (xpOption xpText)) -- Some are blank
557 (xpOption xpText) -- Yup, some are nameless
559 from_tuple = HTeam . (uncurryN Team)
560 to_tuple (HTeam t) = (team_id t,
565 -- | (Un)pickle an away team to/from the dual XML/DB representation
568 pickle_away_team :: PU VTeam
571 xpWrap (from_tuple, to_tuple) $
572 xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text.
573 (xpAttr "abbr" (xpOption xpText)) -- Some are blank
574 (xpOption xpText) -- Yup, some are nameless
576 from_tuple = VTeam . (uncurryN Team)
577 to_tuple (VTeam t) = (team_id t,
582 pickle_status :: PU JFileGameStatus
585 xpWrap (from_tuple, to_tuple) $
586 xpPair (xpAttr "numeral" xpInt)
589 from_tuple = uncurry JFileGameStatus
590 to_tuple s = (db_status_numeral s,
599 -- | A list of all tests for this module.
601 jfile_tests :: TestTree
605 [ test_on_delete_cascade,
606 test_pickle_of_unpickle_is_identity,
607 test_unpickle_succeeds ]
610 -- | If we unpickle something and then pickle it, we should wind up
611 -- with the same thing we started with. WARNING: success of this
612 -- test does not mean that unpickling succeeded.
614 test_pickle_of_unpickle_is_identity :: TestTree
615 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
616 [ check "pickle composed with unpickle is the identity"
617 "test/xml/jfilexml.xml",
618 check "pickle composed with unpickle is the identity (missing fields)"
619 "test/xml/jfilexml-missing-fields.xml",
621 check "pickle composed with unpickle is the identity (TBA game time)"
622 "test/xml/jfilexml-tba-game-time.xml"]
624 check desc path = testCase desc $ do
625 (expected, actual) <- pickle_unpickle pickle_message path
630 -- | Make sure we can actually unpickle these things.
632 test_unpickle_succeeds :: TestTree
633 test_unpickle_succeeds = testGroup "unpickle tests"
634 [ check "unpickling succeeds" "test/xml/jfilexml.xml",
636 check "unpickling succeeds (missing fields)"
637 "test/xml/jfilexml-missing-fields.xml",
639 check "unpickling succeeds (TBA game time)"
640 "test/xml/jfilexml-tba-game-time.xml" ]
642 check desc path = testCase desc $ do
643 actual <- unpickleable path pickle_message
650 -- | Make sure everything gets deleted when we delete the top-level
653 test_on_delete_cascade :: TestTree
654 test_on_delete_cascade = testGroup "cascading delete tests"
655 [ check "deleting auto_racing_results deletes its children"
656 "test/xml/jfilexml.xml"
659 check "deleting auto_racing_results deletes its children (missing fields)"
660 "test/xml/jfilexml-missing-fields.xml"
663 check "deleting auto_racing_results deletes its children (TBA game time)"
664 "test/xml/jfilexml-tba-game-time.xml"
667 check desc path expected = testCase desc $ do
668 results <- unsafe_unpickle path pickle_message
669 let a = undefined :: Team
670 let b = undefined :: JFile
671 let c = undefined :: JFileGame
673 actual <- withSqliteConn ":memory:" $ runDbConn $ do
674 runMigration silentMigrationLogger $ do
678 _ <- dbimport results
680 count_a <- countAll a
681 count_b <- countAll b
682 count_c <- countAll c
683 return $ sum [count_a, count_b, count_c]