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 )
73 import TSN.Team ( Team(..), HTeam(..), VTeam(..) )
74 import TSN.XmlImport (
76 XmlImportFkTeams(..) )
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
153 -- * JFileGame/JFileGameXml
155 -- | This is an embedded type within each JFileGame. It has its own
156 -- element, \<Odds_Info\>, but there's only one of them per game. So
157 -- essentially all of these fields belong to a 'JFileGame'. Aaaannnd
158 -- most of them are redundant. We'll (un)pickle them for good
159 -- measure, but in the conversion to the database type, we can drop
160 -- all of the redundant information.
162 -- All of these are optional because TSN does actually leave the
163 -- whole thing empty from time to time.
165 -- We stick \"info\" on the home/away team ids to avoid a name clash
166 -- with the game itself.
168 data JFileGameOddsInfo =
170 db_list_date :: Maybe UTCTime,
171 db_info_home_team_id :: Maybe String, -- redundant (Team)
172 db_info_away_team_id :: Maybe String, -- redundant (Team)
173 db_home_abbr :: Maybe String, -- redundant (Team)
174 db_away_abbr :: Maybe String, -- redundant (Team)
175 db_home_team_name :: Maybe String, -- redundant (Team)
176 db_away_team_name :: Maybe String, -- redundant (Team)
177 db_home_starter :: Maybe String,
178 db_away_starter :: Maybe String,
179 db_game_date :: Maybe UTCTime, -- redundant (JFileGame)
180 db_home_game_key :: Maybe Int,
181 db_away_game_key :: Maybe Int,
182 db_current_timestamp :: Maybe UTCTime,
183 db_live :: Maybe Bool,
188 -- | Another embedded type within 'JFileGame'. These look like,
189 -- \<status numeral=\"4\"\>FINAL\</status\> within the XML, but
190 -- they're in one-to-one correspondence with the games.
192 data JFileGameStatus =
194 db_status_numeral :: Int,
195 db_status :: Maybe String }
199 -- | Database representation of a \<game\> contained within a
200 -- \<message\>, and, implicitly, a \<gamelist\>.
202 -- We've left out the game date, opting instead to combine the
203 -- date/time into the 'db_game_time' field.
207 db_jfile_id :: DefaultKey JFile,
208 db_away_team_id :: DefaultKey Team,
209 db_home_team_id :: DefaultKey Team,
211 db_schedule_id :: Int,
212 db_odds_info :: JFileGameOddsInfo,
213 db_season_type :: Maybe String,
214 db_game_time :: UTCTime,
215 db_vleague :: Maybe String,
216 db_hleague :: Maybe String,
219 db_time_remaining :: Maybe String,
220 db_game_status :: JFileGameStatus }
223 -- | XML representation of a \<game\> contained within a \<message\>,
224 -- and a \<gamelist\>. The Away/Home teams seem to coincide with
225 -- those of 'OddsGame', so we're reusing the DB type via the common
226 -- 'TSN.Team' structure. But the XML types are different, because
227 -- they have different picklers!
232 xml_schedule_id :: Int,
233 xml_odds_info :: JFileGameOddsInfo,
234 xml_season_type :: Maybe String,
235 xml_game_date :: UTCTime,
236 xml_game_time :: UTCTime,
238 xml_vleague :: Maybe String,
240 xml_hleague :: Maybe String,
243 xml_time_remaining :: Maybe String,
244 xml_game_status :: JFileGameStatus }
248 -- * JFileGameListXml
250 -- | The XML representation of \<message\> -> \<gamelist\>. This
251 -- element serves only to contain \<game\>s, so we don't store the
252 -- intermediate table in the database.
254 newtype JFileGameListXml =
261 instance ToDb JFileGameXml where
262 -- | The database analogue of an 'JFileGameXml' is
265 type Db JFileGameXml = JFileGame
268 instance Child JFileGameXml where
269 -- | Each 'JFileGameXml' is contained in (i.e. has a foreign key to)
272 type Parent JFileGameXml = JFile
275 instance FromXmlFkTeams JFileGameXml where
276 -- | To convert an 'JFileGameXml' to an 'JFileGame', we add the
277 -- foreign keys for JFile and the home/away teams. We also mash
278 -- the date/time together into one field.
280 from_xml_fk_teams fk fk_away fk_home JFileGameXml{..} =
283 db_away_team_id = fk_away,
284 db_home_team_id = fk_home,
285 db_game_id = xml_game_id,
286 db_schedule_id = xml_schedule_id,
287 db_odds_info = xml_odds_info,
288 db_season_type = xml_season_type,
289 db_game_time = make_game_time xml_game_date xml_game_time,
290 db_vleague = xml_vleague,
291 db_hleague = xml_hleague,
292 db_vscore = xml_vscore,
293 db_hscore = xml_hscore,
294 db_time_remaining = xml_time_remaining,
295 db_game_status = xml_game_status }
297 -- | Make the database \"game time\" from the XML
298 -- date/time. Simply take the day part from one and the time
301 make_game_time d t = UTCTime (utctDay d) (utctDayTime t)
304 -- | This allows us to insert the XML representation
305 -- 'JFileGameXml' directly.
307 instance XmlImportFkTeams JFileGameXml
314 instance DbImport Message where
317 migrate (undefined :: Team)
318 migrate (undefined :: JFile)
319 migrate (undefined :: JFileGame)
322 -- Insert the top-level message
323 msg_id <- insert_xml m
325 -- Now loop through the message's games
326 forM_ (xml_games $ xml_gamelist m) $ \game -> do
327 -- First we insert the home and away teams.
328 away_team_id <- insert_or_select (vteam $ xml_vteam game)
329 home_team_id <- insert_or_select (hteam $ xml_hteam game)
331 -- Now insert the game keyed to the "jfile" and its teams.
332 insert_xml_fk_teams_ msg_id away_team_id home_team_id game
335 return ImportSucceeded
338 mkPersist tsn_codegen_config [groundhog|
346 # Prevent multiple imports of the same message.
347 fields: [db_xml_file_id]
349 - embedded: JFileGameStatus
351 - name: db_status_numeral
352 dbName: status_numeral
356 # Many of the JFileGameOddsInfo fields are redundant and have
358 - embedded: JFileGameOddsInfo
362 - name: db_home_starter
364 - name: db_home_game_key
365 dbName: home_game_key
366 - name: db_away_game_key
367 dbName: away_game_key
368 - name: db_current_timestamp
369 dbName: current_timestamp
383 - name: db_away_team_id
386 - name: db_home_team_id
391 - {name: list_date, dbName: list_date}
392 - {name: home_starter, dbName: home_starter}
393 - {name: away_starter, dbName: away_starter}
394 - {name: home_game_key, dbName: home_game_key}
395 - {name: away_game_key, dbName: away_game_key}
396 - {name: current_timestamp, dbName: current_timestamp}
397 - {name: live, dbName: live}
398 - {name: notes, dbName: notes}
399 - name: db_game_status
401 - {name: status_numeral, dbName: status_numeral}
402 - {name: status, dbName: status}
412 -- | Pickler for the top-level 'Message'.
414 pickle_message :: PU Message
417 xpWrap (from_tuple, to_tuple) $
418 xp6Tuple (xpElem "XML_File_ID" xpInt)
419 (xpElem "heading" xpText)
420 (xpElem "category" xpText)
421 (xpElem "sport" xpText)
423 (xpElem "time_stamp" xp_time_stamp)
425 from_tuple = uncurryN Message
426 to_tuple m = (xml_xml_file_id m,
433 pickle_gamelist :: PU JFileGameListXml
436 xpWrap (to_result, from_result) $ xpList pickle_game
438 to_result = JFileGameListXml
439 from_result = xml_games
444 pickle_game :: PU JFileGameXml
447 xpWrap (from_tuple, to_tuple) $
448 xp14Tuple (xpElem "game_id" xpInt)
449 (xpElem "schedule_id" xpInt)
451 (xpElem "seasontype" (xpOption xpText))
452 (xpElem "Game_Date" xp_date_padded)
453 (xpElem "Game_Time" xp_time)
455 (xpOption $ xpElem "vleague" xpText)
457 (xpOption $ xpElem "hleague" xpText)
458 (xpElem "vscore" xpInt)
459 (xpElem "hscore" xpInt)
460 (xpOption $ xpElem "time_r" xpText)
463 from_tuple = uncurryN JFileGameXml
464 to_tuple m = (xml_game_id m,
476 xml_time_remaining m,
479 pickle_odds_info :: PU JFileGameOddsInfo
482 xpWrap (from_tuple, to_tuple) $
483 xp19Tuple (xpElem "ListDate" (xpOption xp_date))
484 (xpElem "HomeTeamID" (xpOption xpText))
485 (xpElem "AwayTeamID" (xpOption xpText))
486 (xpElem "HomeAbbr" (xpOption xpText))
487 (xpElem "AwayAbbr" (xpOption xpText))
488 (xpElem "HomeTeamName" (xpOption xpText))
489 (xpElem "AwayTeamName" (xpOption xpText))
490 (xpElem "HStarter" (xpOption xpText))
491 (xpElem "AStarter" (xpOption xpText))
492 (xpElem "GameDate" (xpOption xp_datetime))
493 (xpElem "HGameKey" (xpOption xpInt))
494 (xpElem "AGameKey" (xpOption xpInt))
495 (xpElem "CurrentTimeStamp" (xpOption xp_time_dots))
496 (xpElem "Live" (xpOption xpPrim))
497 (xpElem "Notes1" xpText0)
498 (xpElem "Notes2" xpText0)
499 (xpElem "Notes3" xpText0)
500 (xpElem "Notes4" xpText0)
501 (xpElem "Notes5" xpText0)
503 from_tuple (x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,n1,n2,n3,n4,n5) =
504 JFileGameOddsInfo x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 notes
506 notes = intercalate "\n" [n1,n2,n3,n4,n5]
508 to_tuple o = (db_list_date o,
509 db_info_home_team_id o,
510 db_info_away_team_id o,
520 db_current_timestamp o,
524 note_lines = split "\n" (db_notes o)
525 n1 = case note_lines of
528 n2 = case note_lines of
529 (_:notes2:_) -> notes2
531 n3 = case note_lines of
532 (_:_:notes3:_) -> notes3
534 n4 = case note_lines of
535 (_:_:_:notes4:_) -> notes4
537 n5 = case note_lines of
538 (_:_:_:_:notes5:_) -> notes5
541 -- | (Un)pickle a home team to/from the dual XML/DB representation
544 pickle_home_team :: PU HTeam
547 xpWrap (from_tuple, to_tuple) $
548 xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text.
549 (xpAttr "abbr" (xpOption xpText)) -- Some are blank
550 (xpOption xpText) -- Yup, some are nameless
552 from_tuple = HTeam . (uncurryN Team)
553 to_tuple (HTeam t) = (team_id t,
558 -- | (Un)pickle an away team to/from the dual XML/DB representation
561 pickle_away_team :: PU VTeam
564 xpWrap (from_tuple, to_tuple) $
565 xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text.
566 (xpAttr "abbr" (xpOption xpText)) -- Some are blank
567 (xpOption xpText) -- Yup, some are nameless
569 from_tuple = VTeam . (uncurryN Team)
570 to_tuple (VTeam t) = (team_id t,
575 pickle_status :: PU JFileGameStatus
578 xpWrap (from_tuple, to_tuple) $
579 xpPair (xpAttr "numeral" xpInt)
582 from_tuple = uncurry JFileGameStatus
583 to_tuple s = (db_status_numeral s,
592 -- | A list of all tests for this module.
594 jfile_tests :: TestTree
598 [ test_on_delete_cascade,
599 test_pickle_of_unpickle_is_identity,
600 test_unpickle_succeeds ]
603 -- | If we unpickle something and then pickle it, we should wind up
604 -- with the same thing we started with. WARNING: success of this
605 -- test does not mean that unpickling succeeded.
607 test_pickle_of_unpickle_is_identity :: TestTree
608 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
609 [ check "pickle composed with unpickle is the identity"
610 "test/xml/jfilexml.xml",
611 check "pickle composed with unpickle is the identity (missing fields)"
612 "test/xml/jfilexml-missing-fields.xml" ]
614 check desc path = testCase desc $ do
615 (expected, actual) <- pickle_unpickle pickle_message path
620 -- | Make sure we can actually unpickle these things.
622 test_unpickle_succeeds :: TestTree
623 test_unpickle_succeeds = testGroup "unpickle tests"
624 [ check "unpickling succeeds" "test/xml/jfilexml.xml",
625 check "unpickling succeeds (missing fields)"
626 "test/xml/jfilexml-missing-fields.xml" ]
628 check desc path = testCase desc $ do
629 actual <- unpickleable path pickle_message
636 -- | Make sure everything gets deleted when we delete the top-level
639 test_on_delete_cascade :: TestTree
640 test_on_delete_cascade = testGroup "cascading delete tests"
641 [ check "deleting auto_racing_results deletes its children"
642 "test/xml/jfilexml.xml"
644 check "deleting auto_racing_results deletes its children (missing fields)"
645 "test/xml/jfilexml-missing-fields.xml"
648 check desc path expected = testCase desc $ do
649 results <- unsafe_unpickle path pickle_message
650 let a = undefined :: Team
651 let b = undefined :: JFile
652 let c = undefined :: JFileGame
654 actual <- withSqliteConn ":memory:" $ runDbConn $ do
655 runMigration silentMigrationLogger $ do
659 _ <- dbimport results
661 count_a <- countAll a
662 count_b <- countAll b
663 count_c <- countAll c
664 return $ sum [count_a, count_b, count_c]