--- /dev/null
+{-# 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
+-- \<message\>, containing a \<gamelist\>, containing
+-- \<game\>s. Those games contain a bunch of other stuff. The
+-- \<gamelist\> 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, \<Odds_Info\>, 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 \<game\> contained within a
+-- \<message\>, and, implicitly, a \<gamelist\>.
+--
+-- 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 \<game\> contained within a \<message\>,
+-- and a \<gamelist\>. 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 \<message\> -> \<gamelist\>. This
+-- element serves only to contain \<game\>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
projects / dead / htsn-import.git / commitdiff