{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -- | Parse TSN XML for the DTD \"jfilexml.dtd\". There's a top-level -- \, containing a \, containing -- \s. Those games contain a bunch of other stuff. The -- \ is pretty irrelevant; we ignore it and pretend that -- a message contains a bunch of games. -- module TSN.XML.JFile ( dtd ) where -- System imports import Data.Time ( UTCTime(..) ) import Data.Tuple.Curry ( uncurryN ) import Database.Groundhog ( migrate ) import Database.Groundhog.Core ( DefaultKey ) import Database.Groundhog.TH ( groundhog, mkPersist ) import Text.XML.HXT.Core ( PU, xp6Tuple, xp7Tuple, xp8Tuple, xp10Tuple, xp14Tuple, xpElem, xpInt, xpList, xpOption, xpText, xpWrap ) -- Local imports import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) import TSN.Picklers ( xp_date_padded, xp_time, xp_time_stamp ) import TSN.XML.Odds ( OddsGameAwayTeamXml(..), OddsGameHomeTeamXml(..), OddsGameTeam(..) ) import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) ) import Xml ( FromXml(..), FromXmlFk(..), ToDb(..) ) -- | The DTD to which this module corresponds. Used to invoke dbimport. -- dtd :: String dtd = "jfilexml.dtd" -- -- DB/XML data types -- -- * JFile/Message -- | Database representation of a 'Message'. -- data JFile = JFile { db_xml_file_id :: Int, db_heading :: String, db_category :: String, db_sport :: String, db_time_stamp :: UTCTime } -- | XML Representation of an 'JFile'. -- data Message = Message { xml_xml_file_id :: Int, xml_heading :: String, xml_category :: String, xml_sport :: String, xml_gamelist :: JFileGameListXml, xml_time_stamp :: UTCTime } deriving (Eq, Show) instance ToDb Message where -- | The database analogue of a 'Message' is a 'JFile'. -- type Db Message = JFile -- | The 'FromXml' instance for 'Message' is required for the -- 'XmlImport' instance. -- instance FromXml Message where -- | To convert a 'Message' to an 'JFile', we just drop -- the 'xml_gamelist'. -- from_xml Message{..} = JFile { db_xml_file_id = xml_xml_file_id, db_heading = xml_heading, db_category = xml_category, db_sport = xml_sport, db_time_stamp = xml_time_stamp } -- | This allows us to insert the XML representation 'Message' -- directly. -- instance XmlImport Message -- | This is an embedded type within each JFileGame. It has its own -- element, \, but there's only one of them per game. So -- essentially all of these fields belong to a 'JFileGame'. Aaaannnd -- most of them are redundant. We'll (un)pickle them for good -- measure, but in the conversion to the database type, we can drop -- all of the redundant information. -- data OddsInfo = OddsInfo { db_list_date :: UTCTime, db_home_team_id :: Int, -- redundant (OddsGameTeam) db_away_team_id :: Int, -- redundant (OddsGameTeam) db_home_abbr :: String, -- redundant (OddsGameTeam) db_away_abbr :: String, -- redundant (OddsGameTeam) db_home_team_name :: String, -- redundant (OddsGameTeam) db_away_team_name :: String, -- redundant (OddsGameTeam) db_home_starter :: String, db_away_starter :: String, db_game_date :: UTCTime, -- redundant (JFileGame) db_home_game_key :: Int, db_away_game_key :: Int, db_current_timestamp :: UTCTime, db_live :: Bool, db_notes :: String } deriving (Eq, Show) -- * JFileGame/JFileGameXml -- | Database representation of a \ contained within a -- \, and, implicitly, a \. -- -- We've left out the game date, opting instead to combine the -- date/time into the 'db_game_time' field. -- data JFileGame = JFileGame { db_jfile_id :: DefaultKey JFile, db_game_id :: Int, db_schedule_id :: Int, db_odds_info :: OddsInfo, db_season_type :: String, db_game_time :: UTCTime, db_vleague :: Maybe String, db_hleague :: Maybe String, db_vscore :: Int, db_hscore :: Int, db_time_remaining :: Maybe String, db_status :: String } -- | XML representation of a \ contained within a \, -- and a \. The Away/Home teams seem to -- coincide with those of 'OddsGame', so we're reusing those for -- now. In the future it may make sense to separate them out into -- just \"Teams\". Note however that they require different picklers! -- data JFileGameXml = JFileGameXml { xml_game_id :: Int, xml_schedule_id :: Int, xml_odds_info :: OddsInfo, xml_season_type :: String, xml_game_date :: UTCTime, xml_game_time :: UTCTime, xml_vteam :: OddsGameAwayTeamXml, xml_vleague :: Maybe String, xml_hteam :: OddsGameHomeTeamXml, xml_hleague :: Maybe String, xml_vscore :: Int, xml_hscore :: Int, xml_time_remaining :: Maybe String, xml_status :: String } deriving (Eq, Show) -- * JFileGameListXml -- | The XML representation of \ -> \. This -- element serves only to contain \s, so we don't store the -- intermediate table in the database. -- newtype JFileGameListXml = JFileGameListXml { xml_games :: [JFileGameXml] } deriving (Eq, Show) instance ToDb JFileGameXml where -- | The database analogue of an 'JFileGameXml' is -- an 'JFileGame'. -- type Db JFileGameXml = JFileGame instance FromXmlFk JFileGameXml where -- | Each 'JFileGameXml' is contained in (i.e. has a foreign key to) -- a 'JFile'. -- type Parent JFileGameXml = JFile -- | To convert an 'JFileGameXml' to an 'JFileGame', we add the -- foreign key and drop the 'xml_vteam'/'xml_hteam'. We also mash -- the date/time together into one field. -- from_xml_fk fk JFileGameXml{..} = JFileGame { db_jfile_id = fk, db_game_id = xml_game_id, db_schedule_id = xml_schedule_id, db_odds_info = xml_odds_info, db_season_type = xml_season_type, db_game_time = xml_game_time, db_vleague = xml_vleague, db_hleague = xml_hleague, db_vscore = xml_vscore, db_hscore = xml_hscore, db_time_remaining = xml_time_remaining, db_status = xml_status } where -- | Make the database \"game time\" from the XML -- date/time. Simply take the day part from one and the time -- from the other. -- make_game_time d Nothing = d make_game_time d (Just t) = UTCTime (utctDay d) (utctDayTime t) -- | This allows us to insert the XML representation -- 'JFileGameXml' directly. -- instance XmlImportFk JFileGameXml -- * JFileGame_OddsGameTeam -- | Database mapping between games and their home/away teams. -- data JFileGame_OddsGameTeam = JFileGame_OddsGameTeam { jgogt_jfile_games_id :: DefaultKey JFileGame, jgogt_away_team_id :: DefaultKey OddsGameTeam, jgogt_home_team_id :: DefaultKey OddsGameTeam } --- --- Database stuff. --- instance DbImport Message where dbmigrate _ = run_dbmigrate $ do migrate (undefined :: JFile) migrate (undefined :: JFileGame) migrate (undefined :: OddsGameTeam) migrate (undefined :: JFileGame_OddsGameTeam) dbimport m = return ImportSucceeded mkPersist tsn_codegen_config [groundhog| - entity: JFile dbName: jfile constructors: - name: JFile uniques: - name: unique_jfile type: constraint # Prevent multiple imports of the same message. fields: [db_xml_file_id] # Many of the OddsInfo fields are redundant and have been left out. - embedded: OddsInfo fields: - name: db_list_date dbName: list_date - name: db_home_starter dbName: home_starter - name: db_home_game_key dbName: home_game_key - name: db_away_game_key dbName: away_game_key - name: db_current_timestamp dbName: current_timestamp - name: db_live dbName: live - name: db_notes dbName: notes - entity: JFileGame dbName: jfile_games constructors: - name: JFileGame fields: - name: db_jfile_id reference: onDelete: cascade - name: db_odds_info embeddedType: - {name: list_date, dbName: list_date} - {name: home_starter, dbName: home_starter} - {name: away_starter, dbName: away_starter} - {name: home_game_key, dbName: home_game_key} - {name: away_game_key, dbName: home_game_key} - {name: current_timestamp, dbName: current_timestamp} - {name: live, dbName: live} - {name: notes, dbName: notes} - entity: JFileGame_OddsGameTeam dbName: jfile_games__odds_games_teams constructors: - name: JFileGame_OddsGameTeam fields: - name: jgogt_jfile_games_id reference: onDelete: cascade - name: jgogt_away_team_id reference: onDelete: cascade - name: jgogt_home_team_id reference: onDelete: cascade |] --- --- Pickling --- -- | Pickler for the top-level 'Message'. -- pickle_message :: PU Message pickle_message = xpElem "message" $ xpWrap (from_tuple, to_tuple) $ xp6Tuple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) (xpElem "category" xpText) (xpElem "sport" xpText) pickle_gamelist (xpElem "time_stamp" xp_time_stamp) where from_tuple = uncurryN Message to_tuple m = (xml_xml_file_id m, xml_heading m, xml_category m, xml_sport m, xml_gamelist m, xml_time_stamp m) pickle_gamelist :: PU JFileGameListXml pickle_gamelist = xpElem "gamelist" $ xpWrap (to_result, from_result) $ xpList pickle_game where to_result = JFileGameListXml from_result = xml_games pickle_game :: PU JFileGameXml pickle_game = xpElem "game" $ xpWrap (from_tuple, to_tuple) $ xp14Tuple (xpElem "game_id" xpInt) (xpElem "schedule_id" xpInt) pickle_odds_info (xpElem "seasontype" xpText) (xpElem "Game_Date" xp_date_padded) (xpElem "Game_Time" xp_time) pickle_away_team (xpOption $ xpElem "vleague" xpText) pickle_home_team (xpOption $ xpElem "hleague" xpText) (xpElem "vscore" xpInt) (xpElem "hscore" xpInt) (xpOption $ xpElem "time_r" xpText) pickle_status where from_tuple = uncurryN JFileGameXml to_tuple m = (xml_game_id m, xml_schedule_id m, xml_odds_info m, xml_season_type m, xml_game_date m, xml_game_time m, xml_vteam m, xml_vleague m, xml_hteam m, xml_hleague m, xml_vscore m, xml_hscore m, xml_time_remaining m, xml_status m) pickle_odds_info = undefined pickle_home_team = undefined pickle_away_team = undefined pickle_status = undefined