1 {-# LANGUAGE DeriveGeneric #-}
2 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE QuasiQuotes #-}
5 {-# LANGUAGE RecordWildCards #-}
6 {-# LANGUAGE TemplateHaskell #-}
7 {-# LANGUAGE TypeFamilies #-}
9 -- | Parse TSN XML for the DTD \"jfilexml.dtd\". There's a top-level
10 -- \<message\>, containing a \<gamelist\>, containing
11 -- \<game\>s. Those games contain a bunch of other stuff. The
12 -- \<gamelist\> is pretty irrelevant; we ignore it and pretend that
13 -- a message contains a bunch of games.
15 module TSN.XML.JFile (
20 -- * WARNING: these are private but exported to silence warnings
22 JFileGameConstructor(..) )
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 qualified Data.Vector.HFixed as H ( HVector, convert )
32 import Database.Groundhog (
36 import Database.Groundhog.Core ( DefaultKey )
37 import Database.Groundhog.Generic ( runDbConn, runMigrationSilent )
38 import Database.Groundhog.Sqlite ( withSqliteConn )
39 import Database.Groundhog.TH (
42 import qualified GHC.Generics as GHC ( Generic )
43 import Test.Tasty ( TestTree, testGroup )
44 import Test.Tasty.HUnit ( (@?=), testCase )
45 import Text.XML.HXT.Core (
64 import TSN.Codegen ( tsn_codegen_config )
65 import TSN.Database ( insert_or_select )
66 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
79 import TSN.XmlImport (
81 XmlImportFkTeams(..) )
92 -- | The DTD to which this module corresponds. Used to invoke dbimport.
103 -- | Database representation of a 'Message'.
107 db_xml_file_id :: Int,
108 db_heading :: String,
109 db_category :: String,
111 db_time_stamp :: UTCTime }
115 -- | XML Representation of an 'JFile'.
119 xml_xml_file_id :: Int,
120 xml_heading :: String,
121 xml_category :: String,
123 xml_gamelist :: JFileGameListXml,
124 xml_time_stamp :: UTCTime }
125 deriving (Eq, GHC.Generic, Show)
128 -- | For 'H.convert'.
130 instance H.HVector Message
133 instance ToDb Message where
134 -- | The database analogue of a 'Message' is a 'JFile'.
136 type Db Message = JFile
139 -- | The 'FromXml' instance for 'Message' is required for the
140 -- 'XmlImport' instance.
142 instance FromXml Message where
143 -- | To convert a 'Message' to an 'JFile', we just drop
144 -- the 'xml_gamelist'.
146 from_xml Message{..} =
148 db_xml_file_id = xml_xml_file_id,
149 db_heading = xml_heading,
150 db_category = xml_category,
151 db_sport = xml_sport,
152 db_time_stamp = xml_time_stamp }
155 -- | This allows us to insert the XML representation 'Message'
158 instance XmlImport Message
162 -- * JFileGame/JFileGameXml
164 -- | This is an embedded type within each JFileGame. It has its own
165 -- element, \<Odds_Info\>, but there's only one of them per game. So
166 -- essentially all of these fields belong to a 'JFileGame'. Aaaannnd
167 -- most of them are redundant. We'll (un)pickle them for good
168 -- measure, but in the conversion to the database type, we can drop
169 -- all of the redundant information.
171 -- All of these are optional because TSN does actually leave the
172 -- whole thing empty from time to time.
174 -- We stick \"info\" on the home/away team ids to avoid a name clash
175 -- with the game itself.
177 data JFileGameOddsInfo =
179 db_list_date :: Maybe UTCTime,
180 db_info_home_team_id :: Maybe String, -- redundant (Team)
181 db_info_away_team_id :: Maybe String, -- redundant (Team)
182 db_home_abbr :: Maybe String, -- redundant (Team)
183 db_away_abbr :: Maybe String, -- redundant (Team)
184 db_home_team_name :: Maybe String, -- redundant (Team)
185 db_away_team_name :: Maybe String, -- redundant (Team)
186 db_home_starter :: Maybe String,
187 db_away_starter :: Maybe String,
188 db_game_date :: Maybe UTCTime, -- redundant (JFileGame)
189 db_home_game_key :: Maybe Int,
190 db_away_game_key :: Maybe Int,
191 db_current_timestamp :: Maybe UTCTime,
192 db_live :: Maybe Bool,
197 -- | Another embedded type within 'JFileGame'. These look like,
198 -- \<status numeral=\"4\"\>FINAL\</status\> within the XML, but
199 -- they're in one-to-one correspondence with the games.
201 data JFileGameStatus =
203 db_status_numeral :: Int,
204 db_status :: Maybe String }
209 -- | Database representation of a \<game\> contained within a
210 -- \<message\>, and, implicitly, a \<gamelist\>.
212 -- We've left out the game date, opting instead to combine the
213 -- date/time into the 'db_game_time' field.
217 db_jfile_id :: DefaultKey JFile,
218 db_away_team_id :: DefaultKey Team,
219 db_home_team_id :: DefaultKey Team,
221 db_schedule_id :: Int,
222 db_odds_info :: JFileGameOddsInfo,
223 db_season_type :: Maybe String,
224 db_game_time :: Maybe UTCTime,
225 db_vleague :: Maybe String,
226 db_hleague :: Maybe String,
229 db_time_remaining :: Maybe String,
230 db_game_status :: JFileGameStatus }
233 -- | XML representation of a \<game\> contained within a \<message\>,
234 -- and a \<gamelist\>. The Away/Home teams seem to coincide with
235 -- those of 'OddsGame', so we're reusing the DB type via the common
236 -- 'TSN.Team' structure. But the XML types are different, because
237 -- they have different picklers!
242 xml_schedule_id :: Int,
243 xml_odds_info :: JFileGameOddsInfo,
244 xml_season_type :: Maybe String,
245 xml_game_date :: UTCTime,
246 xml_game_time :: Maybe UTCTime,
248 xml_vleague :: Maybe String,
250 xml_hleague :: Maybe String,
253 xml_time_remaining :: Maybe String,
254 xml_game_status :: JFileGameStatus }
255 deriving (Eq, GHC.Generic, Show)
258 -- | For 'H.convert'.
260 instance H.HVector JFileGameXml
263 -- * JFileGameListXml
265 -- | The XML representation of \<message\> -> \<gamelist\>. This
266 -- element serves only to contain \<game\>s, so we don't store the
267 -- intermediate table in the database.
269 newtype JFileGameListXml =
276 instance ToDb JFileGameXml where
277 -- | The database analogue of an 'JFileGameXml' is
280 type Db JFileGameXml = JFileGame
283 instance Child JFileGameXml where
284 -- | Each 'JFileGameXml' is contained in (i.e. has a foreign key to)
287 type Parent JFileGameXml = JFile
290 instance FromXmlFkTeams JFileGameXml where
291 -- | To convert an 'JFileGameXml' to an 'JFileGame', we add the
292 -- foreign keys for JFile and the home/away teams. We also mash
293 -- the date/time together into one field.
295 from_xml_fk_teams fk fk_away fk_home JFileGameXml{..} =
298 db_away_team_id = fk_away,
299 db_home_team_id = fk_home,
300 db_game_id = xml_game_id,
301 db_schedule_id = xml_schedule_id,
302 db_odds_info = xml_odds_info,
303 db_season_type = xml_season_type,
304 db_game_time = make_game_time xml_game_date xml_game_time,
305 db_vleague = xml_vleague,
306 db_hleague = xml_hleague,
307 db_vscore = xml_vscore,
308 db_hscore = xml_hscore,
309 db_time_remaining = xml_time_remaining,
310 db_game_status = xml_game_status }
312 -- | Construct the database game time from the XML \<Game_Date\>
313 -- and \<Game_Time\> elements. The \<Game_Time\> elements
314 -- sometimes have a value of \"TBA\"; in that case, we don't
315 -- want to pretend that we know the time by setting it to
316 -- e.g. midnight, so instead we make the entire date/time
318 make_game_time :: UTCTime -> Maybe UTCTime -> Maybe UTCTime
319 make_game_time _ Nothing = Nothing
320 make_game_time d (Just t) = Just $ UTCTime (utctDay d) (utctDayTime t)
323 -- | This allows us to insert the XML representation
324 -- 'JFileGameXml' directly.
326 instance XmlImportFkTeams JFileGameXml
333 instance DbImport Message where
336 migrate (undefined :: Team)
337 migrate (undefined :: JFile)
338 migrate (undefined :: JFileGame)
341 -- Insert the top-level message
342 msg_id <- insert_xml m
344 -- Now loop through the message's games
345 forM_ (xml_games $ xml_gamelist m) $ \game -> do
346 -- First we insert the home and away teams.
347 away_team_id <- insert_or_select (vteam $ xml_vteam game)
348 home_team_id <- insert_or_select (hteam $ xml_hteam game)
350 -- Now insert the game keyed to the "jfile" and its teams.
351 insert_xml_fk_teams_ msg_id away_team_id home_team_id game
354 return ImportSucceeded
357 mkPersist tsn_codegen_config [groundhog|
365 # Prevent multiple imports of the same message.
366 fields: [db_xml_file_id]
368 - embedded: JFileGameStatus
370 - name: db_status_numeral
371 dbName: status_numeral
375 # Many of the JFileGameOddsInfo fields are redundant and have
377 - embedded: JFileGameOddsInfo
381 - name: db_home_starter
383 - name: db_home_game_key
384 dbName: home_game_key
385 - name: db_away_game_key
386 dbName: away_game_key
387 - name: db_current_timestamp
388 dbName: current_timestamp
402 - name: db_away_team_id
405 - name: db_home_team_id
410 - {name: list_date, dbName: list_date}
411 - {name: home_starter, dbName: home_starter}
412 - {name: away_starter, dbName: away_starter}
413 - {name: home_game_key, dbName: home_game_key}
414 - {name: away_game_key, dbName: away_game_key}
415 - {name: current_timestamp, dbName: current_timestamp}
416 - {name: live, dbName: live}
417 - {name: notes, dbName: notes}
418 - name: db_game_status
420 - {name: status_numeral, dbName: status_numeral}
421 - {name: status, dbName: status}
431 -- | Pickler for the top-level 'Message'.
433 pickle_message :: PU Message
436 xpWrap (from_tuple, H.convert) $
437 xp6Tuple (xpElem "XML_File_ID" xpInt)
438 (xpElem "heading" xpText)
439 (xpElem "category" xpText)
440 (xpElem "sport" xpText)
442 (xpElem "time_stamp" xp_time_stamp)
444 from_tuple = uncurryN Message
447 pickle_gamelist :: PU JFileGameListXml
450 xpWrap (to_result, from_result) $ xpList pickle_game
452 to_result = JFileGameListXml
453 from_result = xml_games
458 pickle_game :: PU JFileGameXml
461 xpWrap (from_tuple, H.convert) $
462 xp14Tuple (xpElem "game_id" xpInt)
463 (xpElem "schedule_id" xpInt)
465 (xpElem "seasontype" (xpOption xpText))
466 (xpElem "Game_Date" xp_date_padded)
467 (xpElem "Game_Time" xp_tba_time)
469 (xpOption $ xpElem "vleague" xpText)
471 (xpOption $ xpElem "hleague" xpText)
472 (xpElem "vscore" xpInt)
473 (xpElem "hscore" xpInt)
474 (xpOption $ xpElem "time_r" xpText)
477 from_tuple = uncurryN JFileGameXml
480 pickle_odds_info :: PU JFileGameOddsInfo
483 xpWrap (from_tuple, to_tuple') $
484 xp19Tuple (xpElem "ListDate" (xpOption xp_date))
485 (xpElem "HomeTeamID" (xpOption xpText))
486 (xpElem "AwayTeamID" (xpOption xpText))
487 (xpElem "HomeAbbr" (xpOption xpText))
488 (xpElem "AwayAbbr" (xpOption xpText))
489 (xpElem "HomeTeamName" (xpOption xpText))
490 (xpElem "AwayTeamName" (xpOption xpText))
491 (xpElem "HStarter" (xpOption xpText))
492 (xpElem "AStarter" (xpOption xpText))
493 (xpElem "GameDate" (xpOption xp_datetime))
494 (xpElem "HGameKey" (xpOption xpInt))
495 (xpElem "AGameKey" (xpOption xpInt))
496 (xpElem "CurrentTimeStamp" (xpOption xp_time_dots))
497 (xpElem "Live" (xpOption xpPrim))
498 (xpElem "Notes1" xpText0)
499 (xpElem "Notes2" xpText0)
500 (xpElem "Notes3" xpText0)
501 (xpElem "Notes4" xpText0)
502 (xpElem "Notes5" xpText0)
504 from_tuple (x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,n1,n2,n3,n4,n5) =
505 JFileGameOddsInfo x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 notes
507 notes = intercalate "\n" [n1,n2,n3,n4,n5]
509 to_tuple' o = (db_list_date o,
510 db_info_home_team_id o,
511 db_info_away_team_id o,
521 db_current_timestamp o,
525 note_lines = split "\n" (db_notes o)
526 n1 = case note_lines of
529 n2 = case note_lines of
530 (_:notes2:_) -> notes2
532 n3 = case note_lines of
533 (_:_:notes3:_) -> notes3
535 n4 = case note_lines of
536 (_:_:_:notes4:_) -> notes4
538 n5 = case note_lines of
539 (_:_:_:_:notes5:_) -> notes5
542 -- | (Un)pickle a home team to/from the dual XML/DB representation
545 pickle_home_team :: PU HTeam
548 xpWrap (from_tuple, to_tuple') $
549 xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text.
550 (xpAttr "abbr" (xpOption xpText)) -- Some are blank
551 (xpOption xpText) -- Yup, some are nameless
553 from_tuple = HTeam . (uncurryN Team)
554 to_tuple' (HTeam t) = H.convert t
557 -- | (Un)pickle an away team to/from the dual XML/DB representation
560 pickle_away_team :: PU VTeam
563 xpWrap (from_tuple, to_tuple') $
564 xpTriple (xpAttr "teamid" xpText) -- Yeah, they're text.
565 (xpAttr "abbr" (xpOption xpText)) -- Some are blank
566 (xpOption xpText) -- Yup, some are nameless
568 from_tuple = VTeam . (uncurryN Team)
569 to_tuple' (VTeam t) = H.convert t
572 pickle_status :: PU JFileGameStatus
575 xpWrap (from_tuple, to_tuple') $
576 xpPair (xpAttr "numeral" xpInt)
579 from_tuple = uncurry JFileGameStatus
581 -- Avoid unused field warnings.
582 to_tuple' JFileGameStatus{..} = (db_status_numeral, db_status)
589 -- | A list of all tests for this module.
591 jfile_tests :: TestTree
595 [ test_on_delete_cascade,
596 test_pickle_of_unpickle_is_identity,
597 test_unpickle_succeeds ]
600 -- | If we unpickle something and then pickle it, we should wind up
601 -- with the same thing we started with. WARNING: success of this
602 -- test does not mean that unpickling succeeded.
604 test_pickle_of_unpickle_is_identity :: TestTree
605 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
606 [ check "pickle composed with unpickle is the identity"
607 "test/xml/jfilexml.xml",
608 check "pickle composed with unpickle is the identity (missing fields)"
609 "test/xml/jfilexml-missing-fields.xml",
611 check "pickle composed with unpickle is the identity (TBA game time)"
612 "test/xml/jfilexml-tba-game-time.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",
626 check "unpickling succeeds (missing fields)"
627 "test/xml/jfilexml-missing-fields.xml",
629 check "unpickling succeeds (TBA game time)"
630 "test/xml/jfilexml-tba-game-time.xml" ]
632 check desc path = testCase desc $ do
633 actual <- unpickleable path pickle_message
640 -- | Make sure everything gets deleted when we delete the top-level
643 test_on_delete_cascade :: TestTree
644 test_on_delete_cascade = testGroup "cascading delete tests"
645 [ check "deleting auto_racing_results deletes its children"
646 "test/xml/jfilexml.xml"
649 check "deleting auto_racing_results deletes its children (missing fields)"
650 "test/xml/jfilexml-missing-fields.xml"
653 check "deleting auto_racing_results deletes its children (TBA game time)"
654 "test/xml/jfilexml-tba-game-time.xml"
657 check desc path expected = testCase desc $ do
658 results <- unsafe_unpickle path pickle_message
659 let a = undefined :: Team
660 let b = undefined :: JFile
661 let c = undefined :: JFileGame
663 actual <- withSqliteConn ":memory:" $ runDbConn $ do
664 runMigrationSilent $ do
668 _ <- dbimport results
670 count_a <- countAll a
671 count_b <- countAll b
672 count_c <- countAll c
673 return $ sum [count_a, count_b, count_c]