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 abbreviation = away_team_abbreviation,
178 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 abbreviation = home_team_abbreviation,
208 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
390 -- First insert the game, keyed to the "jfile",
391 game_id <- insert_xml_fk msg_id game
393 -- Next, we insert the home and away teams.
394 away_team_id <- insert_xml_or_select (xml_vteam game)
395 home_team_id <- insert_xml_or_select (xml_hteam game)
397 -- Insert a record into jfile_games__teams mapping the
398 -- home/away teams to this game. Use the full record syntax
399 -- because the types would let us mix up the home/away teams.
400 insert_ JFileGame_Team {
401 jgt_jfile_games_id = game_id,
402 jgt_away_team_id = away_team_id,
403 jgt_home_team_id = home_team_id }
406 return ImportSucceeded
409 mkPersist tsn_codegen_config [groundhog|
417 # Prevent multiple imports of the same message.
418 fields: [db_xml_file_id]
420 - embedded: JFileGameStatus
422 - name: db_status_numeral
423 dbName: status_numeral
427 # Many of the JFileGameOddsInfo fields are redundant and have
429 - embedded: JFileGameOddsInfo
433 - name: db_home_starter
435 - name: db_home_game_key
436 dbName: home_game_key
437 - name: db_away_game_key
438 dbName: away_game_key
439 - name: db_current_timestamp
440 dbName: current_timestamp
456 - {name: list_date, dbName: list_date}
457 - {name: home_starter, dbName: home_starter}
458 - {name: away_starter, dbName: away_starter}
459 - {name: home_game_key, dbName: home_game_key}
460 - {name: away_game_key, dbName: away_game_key}
461 - {name: current_timestamp, dbName: current_timestamp}
462 - {name: live, dbName: live}
463 - {name: notes, dbName: notes}
464 - name: db_game_status
466 - {name: status_numeral, dbName: status_numeral}
467 - {name: status, dbName: status}
469 - entity: JFileGame_Team
470 dbName: jfile_games__teams
472 - name: JFileGame_Team
474 - name: jgt_jfile_games_id
477 - name: jgt_away_team_id
480 - name: jgt_home_team_id
491 -- | Pickler for the top-level 'Message'.
493 pickle_message :: PU Message
496 xpWrap (from_tuple, to_tuple) $
497 xp6Tuple (xpElem "XML_File_ID" xpInt)
498 (xpElem "heading" xpText)
499 (xpElem "category" xpText)
500 (xpElem "sport" xpText)
502 (xpElem "time_stamp" xp_time_stamp)
504 from_tuple = uncurryN Message
505 to_tuple m = (xml_xml_file_id m,
512 pickle_gamelist :: PU JFileGameListXml
515 xpWrap (to_result, from_result) $ xpList pickle_game
517 to_result = JFileGameListXml
518 from_result = xml_games
523 pickle_game :: PU JFileGameXml
526 xpWrap (from_tuple, to_tuple) $
527 xp14Tuple (xpElem "game_id" xpInt)
528 (xpElem "schedule_id" xpInt)
530 (xpElem "seasontype" (xpOption xpText))
531 (xpElem "Game_Date" xp_date_padded)
532 (xpElem "Game_Time" xp_time)
534 (xpOption $ xpElem "vleague" xpText)
536 (xpOption $ xpElem "hleague" xpText)
537 (xpElem "vscore" xpInt)
538 (xpElem "hscore" xpInt)
539 (xpOption $ xpElem "time_r" xpText)
542 from_tuple = uncurryN JFileGameXml
543 to_tuple m = (xml_game_id m,
555 xml_time_remaining m,
558 pickle_odds_info :: PU JFileGameOddsInfo
561 xpWrap (from_tuple, to_tuple) $
562 xp19Tuple (xpElem "ListDate" (xpOption xp_date))
563 (xpElem "HomeTeamID" (xpOption xpText))
564 (xpElem "AwayTeamID" (xpOption xpText))
565 (xpElem "HomeAbbr" (xpOption xpText))
566 (xpElem "AwayAbbr" (xpOption xpText))
567 (xpElem "HomeTeamName" (xpOption xpText))
568 (xpElem "AwayTeamName" (xpOption xpText))
569 (xpElem "HStarter" (xpOption xpText))
570 (xpElem "AStarter" (xpOption xpText))
571 (xpElem "GameDate" (xpOption xp_datetime))
572 (xpElem "HGameKey" (xpOption xpInt))
573 (xpElem "AGameKey" (xpOption xpInt))
574 (xpElem "CurrentTimeStamp" (xpOption xp_time_dots))
575 (xpElem "Live" (xpOption xpPrim))
576 (xpElem "Notes1" xpText0)
577 (xpElem "Notes2" xpText0)
578 (xpElem "Notes3" xpText0)
579 (xpElem "Notes4" xpText0)
580 (xpElem "Notes5" xpText0)
582 from_tuple (x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,n1,n2,n3,n4,n5) =
583 JFileGameOddsInfo x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 notes
585 notes = intercalate "\n" [n1,n2,n3,n4,n5]
587 to_tuple o = (db_list_date o,
599 db_current_timestamp o,
603 note_lines = split "\n" (db_notes o)
604 n1 = case note_lines of
607 n2 = case note_lines of
608 (_:notes2:_) -> notes2
610 n3 = case note_lines of
611 (_:_:notes3:_) -> notes3
613 n4 = case note_lines of
614 (_:_:_:notes4:_) -> notes4
616 n5 = case note_lines of
617 (_:_:_:_:notes5:_) -> notes5
620 pickle_home_team :: PU JFileGameHomeTeamXml
623 xpWrap (from_tuple, to_tuple) $
624 xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text.
625 (xpAttr "abbr" (xpOption xpText)) -- Some are blank
626 (xpOption xpText) -- Yup, some are nameless
628 from_tuple = uncurryN JFileGameHomeTeamXml
629 to_tuple t = (home_team_id t,
630 home_team_abbreviation t,
634 pickle_away_team :: PU JFileGameAwayTeamXml
637 xpWrap (from_tuple, to_tuple) $
638 xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text.
639 (xpAttr "abbr" (xpOption xpText)) -- Some are blank
640 (xpOption xpText) -- Yup, some are nameless
642 from_tuple = uncurryN JFileGameAwayTeamXml
643 to_tuple t = (away_team_id t,
644 away_team_abbreviation t,
648 pickle_status :: PU JFileGameStatus
651 xpWrap (from_tuple, to_tuple) $
652 xpPair (xpAttr "numeral" xpInt)
655 from_tuple = uncurry JFileGameStatus
656 to_tuple s = (db_status_numeral s,
665 -- | A list of all tests for this module.
667 jfile_tests :: TestTree
671 [ test_on_delete_cascade,
672 test_pickle_of_unpickle_is_identity,
673 test_unpickle_succeeds ]
676 -- | If we unpickle something and then pickle it, we should wind up
677 -- with the same thing we started with. WARNING: success of this
678 -- test does not mean that unpickling succeeded.
680 test_pickle_of_unpickle_is_identity :: TestTree
681 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
682 [ check "pickle composed with unpickle is the identity"
683 "test/xml/jfilexml.xml",
684 check "pickle composed with unpickle is the identity (missing fields)"
685 "test/xml/jfilexml-missing-fields.xml" ]
687 check desc path = testCase desc $ do
688 (expected, actual) <- pickle_unpickle pickle_message path
693 -- | Make sure we can actually unpickle these things.
695 test_unpickle_succeeds :: TestTree
696 test_unpickle_succeeds = testGroup "unpickle tests"
697 [ check "unpickling succeeds" "test/xml/jfilexml.xml",
698 check "unpickling succeeds (missing fields)"
699 "test/xml/jfilexml-missing-fields.xml" ]
701 check desc path = testCase desc $ do
702 actual <- unpickleable path pickle_message
709 -- | Make sure everything gets deleted when we delete the top-level
712 test_on_delete_cascade :: TestTree
713 test_on_delete_cascade = testGroup "cascading delete tests"
714 [ check "deleting auto_racing_results deletes its children"
715 "test/xml/jfilexml.xml"
717 check "deleting auto_racing_results deletes its children (missing fields)"
718 "test/xml/jfilexml-missing-fields.xml"
721 check desc path expected = testCase desc $ do
722 results <- unsafe_unpickle path pickle_message
723 let a = undefined :: Team
724 let b = undefined :: JFile
725 let c = undefined :: JFileGame
726 let d = undefined :: JFileGame_Team
728 actual <- withSqliteConn ":memory:" $ runDbConn $ do
729 runMigration silentMigrationLogger $ do
734 _ <- dbimport results
736 count_a <- countAll a
737 count_b <- countAll b
738 count_c <- countAll c
739 count_d <- countAll d
740 return $ sum [count_a, count_b, count_c, count_d]