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(..),
22 JFileGame_TeamConstructor(..) )
26 import Control.Monad ( forM_ )
27 import Data.List ( intercalate )
28 import Data.String.Utils ( split )
29 import Data.Time ( UTCTime(..) )
30 import Data.Tuple.Curry ( uncurryN )
31 import Database.Groundhog (
37 silentMigrationLogger )
38 import Database.Groundhog.Core ( DefaultKey )
39 import Database.Groundhog.Generic ( runDbConn )
40 import Database.Groundhog.Sqlite ( withSqliteConn )
41 import Database.Groundhog.TH (
44 import Test.Tasty ( TestTree, testGroup )
45 import Test.Tasty.HUnit ( (@?=), testCase )
46 import Text.XML.HXT.Core (
65 import TSN.Codegen ( tsn_codegen_config )
66 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
74 import TSN.Team ( Team(..) )
75 import TSN.XmlImport (
88 -- | The DTD to which this module corresponds. Used to invoke dbimport.
99 -- | Database representation of a 'Message'.
103 db_xml_file_id :: Int,
104 db_heading :: String,
105 db_category :: String,
107 db_time_stamp :: UTCTime }
111 -- | XML Representation of an 'JFile'.
115 xml_xml_file_id :: Int,
116 xml_heading :: String,
117 xml_category :: String,
119 xml_gamelist :: JFileGameListXml,
120 xml_time_stamp :: UTCTime }
124 instance ToDb Message where
125 -- | The database analogue of a 'Message' is a 'JFile'.
127 type Db Message = JFile
130 -- | The 'FromXml' instance for 'Message' is required for the
131 -- 'XmlImport' instance.
133 instance FromXml Message where
134 -- | To convert a 'Message' to an 'JFile', we just drop
135 -- the 'xml_gamelist'.
137 from_xml Message{..} =
139 db_xml_file_id = xml_xml_file_id,
140 db_heading = xml_heading,
141 db_category = xml_category,
142 db_sport = xml_sport,
143 db_time_stamp = xml_time_stamp }
146 -- | This allows us to insert the XML representation 'Message'
149 instance XmlImport Message
152 -- * JFileGameAwayTeamXml / JFileGameHomeTeamXml
154 -- | The XML representation of a JFile away team. Its corresponding
155 -- database representation (along with that of the home team) is a
156 -- TSN.Team, but their XML representations are different.
157 data JFileGameAwayTeamXml =
158 JFileGameAwayTeamXml {
159 away_team_id :: String,
160 away_team_abbreviation :: Maybe String,
161 away_team_name :: Maybe String }
164 instance ToDb JFileGameAwayTeamXml where
165 -- | The database analogue of an 'JFileGameAwayTeamXml' is
168 type Db JFileGameAwayTeamXml = Team
170 instance FromXml JFileGameAwayTeamXml where
171 -- | To convert a 'JFileGameAwayTeamXml' to a 'Team', we do just
174 from_xml JFileGameAwayTeamXml{..} =
176 team_id = away_team_id,
177 team_abbreviation = away_team_abbreviation,
178 team_name = away_team_name }
180 -- | Allow us to import JFileGameAwayTeamXml directly.
181 instance XmlImport JFileGameAwayTeamXml
184 -- | The XML representation of a JFile home team. Its corresponding
185 -- database representation (along with that of the away team) is a
186 -- TSN.Team, but their XML representations are different.
187 data JFileGameHomeTeamXml =
188 JFileGameHomeTeamXml {
189 home_team_id :: String,
190 home_team_abbreviation :: Maybe String,
191 home_team_name :: Maybe String }
194 instance ToDb JFileGameHomeTeamXml where
195 -- | The database analogue of an 'JFileGameHomeTeamXml' is
198 type Db JFileGameHomeTeamXml = Team
200 instance FromXml JFileGameHomeTeamXml where
201 -- | To convert a 'JFileGameHomeTeamXml' to a 'Team', we do just
204 from_xml JFileGameHomeTeamXml{..} =
206 team_id = home_team_id,
207 team_abbreviation = home_team_abbreviation,
208 team_name = home_team_name }
210 -- | Allow us to import JFileGameHomeTeamXml directly.
211 instance XmlImport JFileGameHomeTeamXml
214 -- * JFileGame/JFileGameXml
216 -- | This is an embedded type within each JFileGame. It has its own
217 -- element, \<Odds_Info\>, but there's only one of them per game. So
218 -- essentially all of these fields belong to a 'JFileGame'. Aaaannnd
219 -- most of them are redundant. We'll (un)pickle them for good
220 -- measure, but in the conversion to the database type, we can drop
221 -- all of the redundant information.
223 -- All of these are optional because TSN does actually leave the
224 -- whole thing empty from time to time.
226 data JFileGameOddsInfo =
228 db_list_date :: Maybe UTCTime,
229 db_home_team_id :: Maybe String, -- redundant (Team)
230 db_away_team_id :: Maybe String, -- redundant (Team)
231 db_home_abbr :: Maybe String, -- redundant (Team)
232 db_away_abbr :: Maybe String, -- redundant (Team)
233 db_home_team_name :: Maybe String, -- redundant (Team)
234 db_away_team_name :: Maybe String, -- redundant (Team)
235 db_home_starter :: Maybe String,
236 db_away_starter :: Maybe String,
237 db_game_date :: Maybe UTCTime, -- redundant (JFileGame)
238 db_home_game_key :: Maybe Int,
239 db_away_game_key :: Maybe Int,
240 db_current_timestamp :: Maybe UTCTime,
241 db_live :: Maybe Bool,
246 -- | Another embedded type within 'JFileGame'. These look like,
247 -- \<status numeral=\"4\"\>FINAL\</status\> within the XML, but
248 -- they're in one-to-one correspondence with the games.
250 data JFileGameStatus =
252 db_status_numeral :: Int,
253 db_status :: Maybe String }
257 -- | Database representation of a \<game\> contained within a
258 -- \<message\>, and, implicitly, a \<gamelist\>.
260 -- We've left out the game date, opting instead to combine the
261 -- date/time into the 'db_game_time' field.
265 db_jfile_id :: DefaultKey JFile,
267 db_schedule_id :: Int,
268 db_odds_info :: JFileGameOddsInfo,
269 db_season_type :: Maybe String,
270 db_game_time :: UTCTime,
271 db_vleague :: Maybe String,
272 db_hleague :: Maybe String,
275 db_time_remaining :: Maybe String,
276 db_game_status :: JFileGameStatus }
279 -- | XML representation of a \<game\> contained within a \<message\>,
280 -- and a \<gamelist\>. The Away/Home teams seem to coincide with
281 -- those of 'OddsGame', so we're reusing the DB type via the common
282 -- 'TSN.Team' structure. But the XML types are different, because
283 -- they have different picklers!
288 xml_schedule_id :: Int,
289 xml_odds_info :: JFileGameOddsInfo,
290 xml_season_type :: Maybe String,
291 xml_game_date :: UTCTime,
292 xml_game_time :: UTCTime,
293 xml_vteam :: JFileGameAwayTeamXml,
294 xml_vleague :: Maybe String,
295 xml_hteam :: JFileGameHomeTeamXml,
296 xml_hleague :: Maybe String,
299 xml_time_remaining :: Maybe String,
300 xml_game_status :: JFileGameStatus }
304 -- * JFileGameListXml
306 -- | The XML representation of \<message\> -> \<gamelist\>. This
307 -- element serves only to contain \<game\>s, so we don't store the
308 -- intermediate table in the database.
310 newtype JFileGameListXml =
317 instance ToDb JFileGameXml where
318 -- | The database analogue of an 'JFileGameXml' is
321 type Db JFileGameXml = JFileGame
323 instance FromXmlFk JFileGameXml where
324 -- | Each 'JFileGameXml' is contained in (i.e. has a foreign key to)
327 type Parent JFileGameXml = JFile
329 -- | To convert an 'JFileGameXml' to an 'JFileGame', we add the
330 -- foreign key and drop the 'xml_vteam'/'xml_hteam'. We also mash
331 -- the date/time together into one field.
333 from_xml_fk fk JFileGameXml{..} =
336 db_game_id = xml_game_id,
337 db_schedule_id = xml_schedule_id,
338 db_odds_info = xml_odds_info,
339 db_season_type = xml_season_type,
340 db_game_time = make_game_time xml_game_date xml_game_time,
341 db_vleague = xml_vleague,
342 db_hleague = xml_hleague,
343 db_vscore = xml_vscore,
344 db_hscore = xml_hscore,
345 db_time_remaining = xml_time_remaining,
346 db_game_status = xml_game_status }
348 -- | Make the database \"game time\" from the XML
349 -- date/time. Simply take the day part from one and the time
352 make_game_time d t = UTCTime (utctDay d) (utctDayTime t)
355 -- | This allows us to insert the XML representation
356 -- 'JFileGameXml' directly.
358 instance XmlImportFk JFileGameXml
363 -- | Database mapping between games and their home/away teams.
365 data JFileGame_Team =
367 jgt_jfile_games_id :: DefaultKey JFileGame,
368 jgt_away_team_id :: DefaultKey Team,
369 jgt_home_team_id :: DefaultKey Team }
376 instance DbImport Message where
379 migrate (undefined :: Team)
380 migrate (undefined :: JFile)
381 migrate (undefined :: JFileGame)
382 migrate (undefined :: JFileGame_Team)
385 -- Insert the top-level message
386 msg_id <- insert_xml m
388 -- Now loop through the message's games
389 forM_ (xml_games $ xml_gamelist m) $ \game -> do
391 -- Next, we insert the home and away teams. We do this before
392 -- inserting the game itself because the game has two foreign keys
393 -- pointing to "teams".
394 away_team_id <- insert_xml_or_select (xml_vteam game)
395 home_team_id <- insert_xml_or_select (xml_hteam game)
397 game_id <- insert_xml_fk msg_id game
399 -- Insert a record into jfile_games__teams mapping the
400 -- home/away teams to this game. Use the full record syntax
401 -- because the types would let us mix up the home/away teams.
402 insert_ JFileGame_Team {
403 jgt_jfile_games_id = game_id,
404 jgt_away_team_id = away_team_id,
405 jgt_home_team_id = home_team_id }
408 return ImportSucceeded
411 mkPersist tsn_codegen_config [groundhog|
419 # Prevent multiple imports of the same message.
420 fields: [db_xml_file_id]
422 - embedded: JFileGameStatus
424 - name: db_status_numeral
425 dbName: status_numeral
429 # Many of the JFileGameOddsInfo fields are redundant and have
431 - embedded: JFileGameOddsInfo
435 - name: db_home_starter
437 - name: db_home_game_key
438 dbName: home_game_key
439 - name: db_away_game_key
440 dbName: away_game_key
441 - name: db_current_timestamp
442 dbName: current_timestamp
458 - {name: list_date, dbName: list_date}
459 - {name: home_starter, dbName: home_starter}
460 - {name: away_starter, dbName: away_starter}
461 - {name: home_game_key, dbName: home_game_key}
462 - {name: away_game_key, dbName: away_game_key}
463 - {name: current_timestamp, dbName: current_timestamp}
464 - {name: live, dbName: live}
465 - {name: notes, dbName: notes}
466 - name: db_game_status
468 - {name: status_numeral, dbName: status_numeral}
469 - {name: status, dbName: status}
471 - entity: JFileGame_Team
472 dbName: jfile_games__teams
474 - name: JFileGame_Team
476 - name: jgt_jfile_games_id
479 - name: jgt_away_team_id
482 - name: jgt_home_team_id
493 -- | Pickler for the top-level 'Message'.
495 pickle_message :: PU Message
498 xpWrap (from_tuple, to_tuple) $
499 xp6Tuple (xpElem "XML_File_ID" xpInt)
500 (xpElem "heading" xpText)
501 (xpElem "category" xpText)
502 (xpElem "sport" xpText)
504 (xpElem "time_stamp" xp_time_stamp)
506 from_tuple = uncurryN Message
507 to_tuple m = (xml_xml_file_id m,
514 pickle_gamelist :: PU JFileGameListXml
517 xpWrap (to_result, from_result) $ xpList pickle_game
519 to_result = JFileGameListXml
520 from_result = xml_games
525 pickle_game :: PU JFileGameXml
528 xpWrap (from_tuple, to_tuple) $
529 xp14Tuple (xpElem "game_id" xpInt)
530 (xpElem "schedule_id" xpInt)
532 (xpElem "seasontype" (xpOption xpText))
533 (xpElem "Game_Date" xp_date_padded)
534 (xpElem "Game_Time" xp_time)
536 (xpOption $ xpElem "vleague" xpText)
538 (xpOption $ xpElem "hleague" xpText)
539 (xpElem "vscore" xpInt)
540 (xpElem "hscore" xpInt)
541 (xpOption $ xpElem "time_r" xpText)
544 from_tuple = uncurryN JFileGameXml
545 to_tuple m = (xml_game_id m,
557 xml_time_remaining m,
560 pickle_odds_info :: PU JFileGameOddsInfo
563 xpWrap (from_tuple, to_tuple) $
564 xp19Tuple (xpElem "ListDate" (xpOption xp_date))
565 (xpElem "HomeTeamID" (xpOption xpText))
566 (xpElem "AwayTeamID" (xpOption xpText))
567 (xpElem "HomeAbbr" (xpOption xpText))
568 (xpElem "AwayAbbr" (xpOption xpText))
569 (xpElem "HomeTeamName" (xpOption xpText))
570 (xpElem "AwayTeamName" (xpOption xpText))
571 (xpElem "HStarter" (xpOption xpText))
572 (xpElem "AStarter" (xpOption xpText))
573 (xpElem "GameDate" (xpOption xp_datetime))
574 (xpElem "HGameKey" (xpOption xpInt))
575 (xpElem "AGameKey" (xpOption xpInt))
576 (xpElem "CurrentTimeStamp" (xpOption xp_time_dots))
577 (xpElem "Live" (xpOption xpPrim))
578 (xpElem "Notes1" xpText0)
579 (xpElem "Notes2" xpText0)
580 (xpElem "Notes3" xpText0)
581 (xpElem "Notes4" xpText0)
582 (xpElem "Notes5" xpText0)
584 from_tuple (x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,n1,n2,n3,n4,n5) =
585 JFileGameOddsInfo x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 notes
587 notes = intercalate "\n" [n1,n2,n3,n4,n5]
589 to_tuple o = (db_list_date o,
601 db_current_timestamp o,
605 note_lines = split "\n" (db_notes o)
606 n1 = case note_lines of
609 n2 = case note_lines of
610 (_:notes2:_) -> notes2
612 n3 = case note_lines of
613 (_:_:notes3:_) -> notes3
615 n4 = case note_lines of
616 (_:_:_:notes4:_) -> notes4
618 n5 = case note_lines of
619 (_:_:_:_:notes5:_) -> notes5
622 pickle_home_team :: PU JFileGameHomeTeamXml
625 xpWrap (from_tuple, to_tuple) $
626 xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text.
627 (xpAttr "abbr" (xpOption xpText)) -- Some are blank
628 (xpOption xpText) -- Yup, some are nameless
630 from_tuple = uncurryN JFileGameHomeTeamXml
631 to_tuple t = (home_team_id t,
632 home_team_abbreviation t,
636 pickle_away_team :: PU JFileGameAwayTeamXml
639 xpWrap (from_tuple, to_tuple) $
640 xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text.
641 (xpAttr "abbr" (xpOption xpText)) -- Some are blank
642 (xpOption xpText) -- Yup, some are nameless
644 from_tuple = uncurryN JFileGameAwayTeamXml
645 to_tuple t = (away_team_id t,
646 away_team_abbreviation t,
650 pickle_status :: PU JFileGameStatus
653 xpWrap (from_tuple, to_tuple) $
654 xpPair (xpAttr "numeral" xpInt)
657 from_tuple = uncurry JFileGameStatus
658 to_tuple s = (db_status_numeral s,
667 -- | A list of all tests for this module.
669 jfile_tests :: TestTree
673 [ test_on_delete_cascade,
674 test_pickle_of_unpickle_is_identity,
675 test_unpickle_succeeds ]
678 -- | If we unpickle something and then pickle it, we should wind up
679 -- with the same thing we started with. WARNING: success of this
680 -- test does not mean that unpickling succeeded.
682 test_pickle_of_unpickle_is_identity :: TestTree
683 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
684 [ check "pickle composed with unpickle is the identity"
685 "test/xml/jfilexml.xml",
686 check "pickle composed with unpickle is the identity (missing fields)"
687 "test/xml/jfilexml-missing-fields.xml" ]
689 check desc path = testCase desc $ do
690 (expected, actual) <- pickle_unpickle pickle_message path
695 -- | Make sure we can actually unpickle these things.
697 test_unpickle_succeeds :: TestTree
698 test_unpickle_succeeds = testGroup "unpickle tests"
699 [ check "unpickling succeeds" "test/xml/jfilexml.xml",
700 check "unpickling succeeds (missing fields)"
701 "test/xml/jfilexml-missing-fields.xml" ]
703 check desc path = testCase desc $ do
704 actual <- unpickleable path pickle_message
711 -- | Make sure everything gets deleted when we delete the top-level
714 test_on_delete_cascade :: TestTree
715 test_on_delete_cascade = testGroup "cascading delete tests"
716 [ check "deleting auto_racing_results deletes its children"
717 "test/xml/jfilexml.xml"
719 check "deleting auto_racing_results deletes its children (missing fields)"
720 "test/xml/jfilexml-missing-fields.xml"
723 check desc path expected = testCase desc $ do
724 results <- unsafe_unpickle path pickle_message
725 let a = undefined :: Team
726 let b = undefined :: JFile
727 let c = undefined :: JFileGame
728 let d = undefined :: JFileGame_Team
730 actual <- withSqliteConn ":memory:" $ runDbConn $ do
731 runMigration silentMigrationLogger $ do
736 _ <- dbimport results
738 count_a <- countAll a
739 count_b <- countAll b
740 count_c <- countAll c
741 count_d <- countAll d
742 return $ sum [count_a, count_b, count_c, count_d]