From: Michael Orlitzky Date: Tue, 24 Jun 2014 17:11:26 +0000 (-0400) Subject: Begin work on the TSN.XML.JFile module. X-Git-Tag: 0.0.6~69 X-Git-Url: http://gitweb.michael.orlitzky.com/?p=dead%2Fhtsn-import.git;a=commitdiff_plain;h=4e8ac732bb83c50951d0c007f49333392397f277 Begin work on the TSN.XML.JFile module. --- diff --git a/.ghci b/.ghci index b80f21c..07b1f83 100644 --- a/.ghci +++ b/.ghci @@ -21,6 +21,7 @@ src/TSN/XML/Heartbeat.hs src/TSN/XML/Injuries.hs src/TSN/XML/InjuriesDetail.hs + src/TSN/XML/JFile.hs src/TSN/XML/News.hs src/TSN/XML/Odds.hs src/TSN/XML/Scores.hs @@ -47,6 +48,7 @@ import TSN.XML.GameInfo import TSN.XML.Heartbeat import TSN.XML.Injuries import TSN.XML.InjuriesDetail +import TSN.XML.JFile import TSN.XML.News import TSN.XML.Odds import TSN.XML.Scores diff --git a/htsn-import.cabal b/htsn-import.cabal index f264e30..4122605 100644 --- a/htsn-import.cabal +++ b/htsn-import.cabal @@ -121,6 +121,7 @@ executable htsn-import TSN.XML.Heartbeat TSN.XML.Injuries TSN.XML.InjuriesDetail + TSN.XML.JFile TSN.XML.News TSN.XML.Odds TSN.XML.Scores diff --git a/src/TSN/XML/JFile.hs b/src/TSN/XML/JFile.hs new file mode 100644 index 0000000..a327460 --- /dev/null +++ b/src/TSN/XML/JFile.hs @@ -0,0 +1,425 @@ +{-# 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