{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -- | Parse TSN XML for the DTD \"scoresxml.dtd\". Each document -- contains a single \ and some \s. -- module TSN.XML.Scores ( dtd, pickle_message, -- * Tests scores_tests, -- * WARNING: these are private but exported to silence warnings Score_LocationConstructor(..), ScoreConstructor(..), ScoreGameConstructor(..) ) where -- System imports. import Control.Monad ( join ) import Data.Data ( Data ) import Data.Time ( UTCTime ) import Data.Tuple.Curry ( uncurryN ) import Data.Typeable ( Typeable ) import qualified Data.Vector.HFixed as H ( HVector, convert ) import Database.Groundhog ( countAll, deleteAll, insert_, migrate ) import Database.Groundhog.Core ( DefaultKey ) import Database.Groundhog.Generic ( runDbConn, runMigrationSilent ) import Database.Groundhog.Sqlite ( withSqliteConn ) import Database.Groundhog.TH ( groundhog, mkPersist ) import qualified GHC.Generics as GHC ( Generic ) import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) import Text.XML.HXT.Core ( PU, xp7Tuple, xp11Tuple, xpAttr, xpElem, xpInt, xpList, xpOption, xpPrim, xpText, xpTriple, xpWrap ) -- Local imports. import Misc ( double_just ) import TSN.Codegen ( tsn_codegen_config ) import TSN.Database ( insert_or_select ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) import TSN.Location ( Location(..), pickle_location ) import TSN.Picklers ( xp_attr_option, xp_time_stamp ) import TSN.Team ( FromXmlFkTeams(..), HTeam(..), Team(..), VTeam(..) ) import TSN.XmlImport ( XmlImport(..), XmlImportFkTeams(..) ) import Xml ( Child(..), FromXml(..), ToDb(..), pickle_unpickle, unpickleable, unsafe_unpickle ) -- | The DTD to which this module corresponds. Used to invoke dbimport. -- dtd :: String dtd = "scoresxml.dtd" -- -- * DB/XML Data types -- -- * Score / Message -- | Database representation of a 'Message'. It lacks the -- 'xml_locations' and 'xml_game' which are related via foreign keys -- instead. -- data Score = Score { db_xml_file_id :: Int, db_heading :: String, db_game_id :: Maybe Int, -- ^ We've seen an empty one db_schedule_id :: Maybe Int, -- ^ We've seen an empty one db_tsnupdate :: Maybe Bool, db_category :: String, db_sport :: String, db_season_type :: Maybe String, -- ^ We've seen an empty one db_time_stamp :: UTCTime } -- | XML representation of the top level \ element (i.e. a -- 'Score'). -- data Message = Message { xml_xml_file_id :: Int, xml_heading :: String, xml_game_id :: Maybe Int, -- ^ We've seen an empty one xml_schedule_id :: Maybe Int, -- ^ We've seen an empty one xml_tsnupdate :: Maybe Bool, xml_category :: String, xml_sport :: String, xml_locations :: [Location], xml_season_type :: Maybe String, -- ^ We've seen an empty one xml_game :: ScoreGameXml, xml_time_stamp :: UTCTime } deriving (Eq, GHC.Generic, Show) -- | For 'H.convert'. -- instance H.HVector Message instance ToDb Message where -- | The database representation of a 'Message' is a 'Score'. type Db Message = Score instance FromXml Message where -- | When converting from the XML representation to the database -- one, we drop the list of locations which will be foreign-keyed to -- us instead. from_xml Message{..} = Score { db_xml_file_id = xml_xml_file_id, db_heading = xml_heading, db_game_id = xml_game_id, db_schedule_id = xml_schedule_id, db_tsnupdate = xml_tsnupdate, db_category = xml_category, db_sport = xml_sport, db_season_type = xml_season_type, db_time_stamp = xml_time_stamp } -- | This lets us insert the XML representation 'Message' directly. -- instance XmlImport Message -- * ScoreGame / ScoreGameXml -- | This is an embedded field within 'SportsGame'. Each \ -- element has two attributes, a numeral and a type. It also -- contains some text. Rather than put these in their own table, we -- include them in the parent 'SportsGame'. -- data ScoreGameStatus = ScoreGameStatus { db_status_numeral :: Maybe Int, db_status_type :: Maybe String, -- ^ These are probably only one-character, -- long, but they all take the same -- amount of space in Postgres. db_status_text :: String } deriving (Data, Eq, Show, Typeable) -- | Database representation of a game. -- data ScoreGame = ScoreGame { db_scores_id :: DefaultKey Score, db_away_team_id :: DefaultKey Team, db_home_team_id :: DefaultKey Team, db_away_team_score :: Int, db_home_team_score :: Int, db_away_team_pitcher :: Maybe String, -- ^ Found in the child \ db_home_team_pitcher :: Maybe String, -- ^ Found in the child \ db_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain. db_status :: ScoreGameStatus, db_notes :: Maybe String } -- | XML representation of a \ element (i.e. a 'ScoreGame'). -- data ScoreGameXml = ScoreGameXml { xml_vteam :: VTeamXml, xml_hteam :: HTeamXml, xml_away_team_score :: Int, xml_home_team_score :: Int, xml_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain. xml_status :: ScoreGameStatus, xml_notes :: Maybe String } deriving (Eq, GHC.Generic, Show) -- | For 'H.convert'. -- instance H.HVector ScoreGameXml instance ToDb ScoreGameXml where -- | The database representation of a 'ScoreGameXml' is a -- 'ScoreGame'. -- type Db ScoreGameXml = ScoreGame instance Child ScoreGameXml where -- | Each 'ScoreGameXml' is contained in (i.e. has a foreign key to) -- a 'Score'. -- type Parent ScoreGameXml = Score instance FromXmlFkTeams ScoreGameXml where -- | To create a 'ScoreGame' from a 'ScoreGameXml', we need three -- foreign keys: the parent message, and the away/home teams. -- -- During conversion, we also get the pitchers out of the teams; -- unfortunately this prevents us from making the conversion -- generically. -- from_xml_fk_teams fk fk_away fk_home ScoreGameXml{..} = ScoreGame { db_scores_id = fk, db_away_team_id = fk_away, db_home_team_id = fk_home, db_away_team_score = xml_away_team_score, db_home_team_score = xml_home_team_score, db_away_team_pitcher = xml_vpitcher xml_vteam, db_home_team_pitcher = xml_hpitcher xml_hteam, db_time_r = xml_time_r, db_status = xml_status, db_notes = xml_notes } -- | This lets us import the database representation 'ScoreGameXml' -- directly. -- instance XmlImportFkTeams ScoreGameXml -- * Score_Location -- | Join each 'Score' with its 'Location's. Database-only. We use a -- join table because the locations are kept unique but there are -- multiple locations per 'Score'. -- data Score_Location = Score_Location (DefaultKey Score) (DefaultKey Location) -- * HTeamXml / VTeamXml -- | XML Representation of a home team. This document type is unusual -- in that the \ elements can have a pitcher attribute -- attached to them. We still want to maintain the underlying 'Team' -- representation, so we say that a home team is a 'Team' and -- (maybe) a pitcher. -- data HTeamXml = HTeamXml { xml_ht :: HTeam, xml_hpitcher :: Maybe String } deriving (Eq, Show) instance ToDb HTeamXml where -- | The database analogue of a 'HTeamXml' is its 'Team'. type Db HTeamXml = Team instance FromXml HTeamXml where -- | The conversion from XML to database is simply the 'Team' accessor. -- from_xml = hteam . xml_ht -- | Allow import of the XML representation directly, without -- requiring a manual conversion to the database type first. -- instance XmlImport HTeamXml -- | XML Representation of an away team. This document type is unusual -- in that the \ elements can have a pitcher attribute -- attached to them. We still want to maintain the underlying 'Team' -- representation, so we say that an away team is a 'Team' and -- (maybe) a pitcher. -- data VTeamXml = VTeamXml { xml_vt :: VTeam, xml_vpitcher :: Maybe String } deriving (Eq, Show) instance ToDb VTeamXml where -- | The database analogue of a 'VTeamXml' is its 'Team'. type Db VTeamXml = Team instance FromXml VTeamXml where -- | The conversion from XML to database is simply the 'Team' accessor. -- from_xml = vteam . xml_vt -- | Allow import of the XML representation directly, without -- requiring a manual conversion to the database type first. -- instance XmlImport VTeamXml instance DbImport Message where dbmigrate _ = run_dbmigrate $ do migrate (undefined :: Location) migrate (undefined :: Team) migrate (undefined :: Score) migrate (undefined :: ScoreGame) migrate (undefined :: Score_Location) dbimport m = do -- Insert the message and get its ID. msg_id <- insert_xml m -- Insert all of the locations contained within this message and -- collect their IDs in a list. We use insert_or_select because -- most of the locations will already exist, and we just want to -- get the ID of the existing location when there's a collision. location_ids <- mapM insert_or_select (xml_locations m) -- Now use that list to construct 'Score_ScoreLocation' objects, -- and insert them. mapM_ (insert_ . Score_Location msg_id) location_ids -- Insert the hteam/vteams, noting the IDs. vteam_id <- insert_xml_or_select (xml_vteam $ xml_game m) hteam_id <- insert_xml_or_select (xml_hteam $ xml_game m) -- Now use those along with the msg_id to construct the game. insert_xml_fk_teams_ msg_id vteam_id hteam_id (xml_game m) return ImportSucceeded -- These types have fields with e.g. db_ and xml_ prefixes, so we -- use our own codegen to peel those off before naming the columns. mkPersist tsn_codegen_config [groundhog| - entity: Score dbName: scores constructors: - name: Score uniques: - name: unique_scores type: constraint # Prevent multiple imports of the same message. fields: [db_xml_file_id] - embedded: ScoreGameStatus fields: - name: db_status_numeral dbName: status_numeral - name: db_status_type dbName: status_type - name: db_status_text dbName: status_text - entity: ScoreGame dbName: scores_games constructors: - name: ScoreGame fields: - name: db_scores_id reference: onDelete: cascade - name: db_status embeddedType: - { name: status_numeral, dbName: status_numeral } - { name: status_type, dbName: status_type } - { name: status_text, dbName: status_text } - entity: Score_Location dbName: scores__locations constructors: - name: Score_Location fields: - name: score_Location0 # Default created by mkNormalFieldName dbName: scores_id reference: onDelete: cascade - name: score_Location1 # Default created by mkNormalFieldName dbName: locations_id reference: onDelete: cascade |] -- -- Pickling -- -- | Convert a 'Message' to/from \. -- pickle_message :: PU Message pickle_message = xpElem "message" $ xpWrap (from_tuple, H.convert) $ xp11Tuple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) (xpElem "game_id" (xpOption xpInt)) (xpElem "schedule_id" (xpOption xpInt)) (xpOption $ xpElem "tsnupdate" xpPrim) (xpElem "category" xpText) (xpElem "sport" xpText) (xpList pickle_location) (xpElem "seasontype" (xpOption xpText)) pickle_game (xpElem "time_stamp" xp_time_stamp) where from_tuple = uncurryN Message -- | Convert a 'ScoreGameStatus' to/from \. The \"type\" -- attribute can be either missing or empty, so we're really parsing -- a double-Maybe here. We use the monad join to collapse it into -- one. See also: the hteam/vteam picklers. -- pickle_status :: PU ScoreGameStatus pickle_status = xpElem "status" $ xpWrap (from_tuple, to_tuple') $ xpTriple (xpAttr "numeral" xp_attr_option) (xpOption $ xpAttr "type" $ xpOption xpText) xpText where from_tuple (x,y,z) = ScoreGameStatus x (join y) z to_tuple' ScoreGameStatus{..} = (db_status_numeral, double_just db_status_type, db_status_text) -- | Convert a 'ScoreGameXml' to/from \. -- pickle_game :: PU ScoreGameXml pickle_game = xpElem "game" $ xpWrap (from_tuple, H.convert) $ xp7Tuple pickle_vteam pickle_hteam (xpElem "vscore" xpInt) (xpElem "hscore" xpInt) (xpOption $ xpElem "time_r" xpText) pickle_status (xpOption $ xpElem "notes" xpText) where from_tuple = uncurryN ScoreGameXml -- | Convert a 'VTeamXml' to/from \. The team names -- always seem to be present here, but in the shared representation, -- they're optional (because they show up blank elsewhere). So, we -- pretend they're optional. -- -- The \"pitcher\" attribute is a little bit funny. Usually, when -- there's no pitcher, the attribute itself is missing. But once in -- a blue moon, it will be present with no text. We want to treat -- both cases the same, so what we really parse is a Maybe (Maybe -- String), and then use the monad 'join' to collapse it into a single -- Maybe. -- pickle_vteam :: PU VTeamXml pickle_vteam = xpElem "vteam" $ xpWrap (from_tuple, to_tuple') $ xpTriple (xpAttr "id" xpText) (xpOption $ xpAttr "pitcher" (xpOption xpText)) (xpOption xpText) -- Team name where from_tuple (x,y,z) = VTeamXml (VTeam (Team x Nothing z)) (join y) to_tuple' (VTeamXml (VTeam t) Nothing) = (team_id t, Nothing, name t) to_tuple' (VTeamXml (VTeam t) jvp) = (team_id t, Just jvp, name t) -- | Convert a 'HTeamXml' to/from \. Identical to 'pickle_vteam' -- modulo the \"h\" and \"v\". The team names always seem to be -- present here, but in the shared representation, they're optional -- (because they show up blank elsewhere). So, we pretend they're -- optional. -- -- The \"pitcher\" attribute is a little bit funny. Usually, when -- there's no pitcher, the attribute itself is missing. But once in -- a blue moon, it will be present with no text. We want to treat -- both cases the same, so what we really parse is a Maybe (Maybe -- String), and then use the monad 'join' to collapse it into a single -- Maybe. -- pickle_hteam :: PU HTeamXml pickle_hteam = xpElem "hteam" $ xpWrap (from_tuple, to_tuple') $ xpTriple (xpAttr "id" xpText) (xpOption $ xpAttr "pitcher" (xpOption xpText)) (xpOption xpText) -- Team name where from_tuple (x,y,z)= HTeamXml (HTeam (Team x Nothing z)) (join y) to_tuple' (HTeamXml (HTeam t) jhp) = (team_id t, double_just jhp, name t) -- -- * Tasty tests -- -- | A list of all tests for this module. -- scores_tests :: TestTree scores_tests = testGroup "Scores tests" [ test_on_delete_cascade, test_pickle_of_unpickle_is_identity, test_unpickle_succeeds ] -- | If we unpickle something and then pickle it, we should wind up -- with the same thing we started with. WARNING: success of this -- test does not mean that unpickling succeeded. -- test_pickle_of_unpickle_is_identity :: TestTree test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" [ check "pickle composed with unpickle is the identity" "test/xml/scoresxml.xml", check "pickle composed with unpickle is the identity (no locations)" "test/xml/scoresxml-no-locations.xml", check "pickle composed with unpickle is the identity (pitcher, no type)" "test/xml/scoresxml-pitcher-no-type.xml", check "pickle composed with unpickle is the identity (empty numeral)" "test/xml/scoresxml-empty-numeral.xml", check "pickle composed with unpickle is the identity (empty type)" "test/xml/scoresxml-empty-type.xml" ] where check desc path = testCase desc $ do (expected, actual) <- pickle_unpickle pickle_message path actual @?= expected -- | Make sure we can actually unpickle these things. -- test_unpickle_succeeds :: TestTree test_unpickle_succeeds = testGroup "unpickle tests" [ check "unpickling succeeds" "test/xml/scoresxml.xml", check "unpickling succeeds (no locations)" "test/xml/scoresxml-no-locations.xml", check "unpickling succeeds (pitcher, no type)" "test/xml/scoresxml-pitcher-no-type.xml", check "unpickling succeeds (empty numeral)" "test/xml/scoresxml-empty-numeral.xml", check "unpickling succeeds (empty type)" "test/xml/scoresxml-empty-type.xml" ] where check desc path = testCase desc $ do actual <- unpickleable path pickle_message let expected = True actual @?= expected -- | Make sure everything gets deleted when we delete the top-level -- record. -- test_on_delete_cascade :: TestTree test_on_delete_cascade = testGroup "cascading delete tests" [ check "unpickling succeeds" "test/xml/scoresxml.xml" 4, -- 2 teams, 2 locations check "unpickling succeeds (no locations)" "test/xml/scoresxml-no-locations.xml" 2, -- 2 teams, 0 locations check "unpickling succeeds (pitcher, no type)" "test/xml/scoresxml-pitcher-no-type.xml" 3, -- 2 teams, 1 location check "unpickling succeeds (empty numeral)" "test/xml/scoresxml-empty-numeral.xml" 3, -- 2 teams, 1 location check "unpickling succeeds (empty type)" "test/xml/scoresxml-empty-type.xml" 4 -- 2 teams, 2 locations ] where check desc path expected = testCase desc $ do score <- unsafe_unpickle path pickle_message let a = undefined :: Location let b = undefined :: Team let c = undefined :: Score let d = undefined :: ScoreGame let e = undefined :: Score_Location actual <- withSqliteConn ":memory:" $ runDbConn $ do runMigrationSilent $ do migrate a migrate b migrate c migrate d migrate e _ <- dbimport score -- No idea how 'delete' works, so do this instead. deleteAll c count_a <- countAll a count_b <- countAll b count_c <- countAll c count_d <- countAll d count_e <- countAll e return $ sum [count_a, count_b, count_c, count_d, count_e ] actual @?= expected