{-# 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_ScoreLocationConstructor(..), ScoreConstructor(..), ScoreGameConstructor(..), ScoreGameTeamConstructor(..), ScoreLocationConstructor(..), ScoreGame_ScoreGameTeamConstructor(..) ) where -- System imports. import Data.Data ( Data ) import Data.Time ( UTCTime ) import Data.Tuple.Curry ( uncurryN ) import Data.Typeable ( Typeable ) import Database.Groundhog ( countAll, deleteAll, insert, insert_, migrate, runMigration, silentMigrationLogger ) import Database.Groundhog.Core ( DefaultKey ) import Database.Groundhog.Generic ( runDbConn ) import Database.Groundhog.Sqlite ( withSqliteConn ) import Database.Groundhog.TH ( defaultCodegenConfig, groundhog, mkPersist ) import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) import Text.XML.HXT.Core ( PU, xp7Tuple, xp11Tuple, xpAttr, xpElem, xpInt, xpList, xpOption, xpPair, xpPrim, xpText, xpTriple, xpWrap ) -- Local imports. import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) import TSN.Picklers ( xp_time_stamp ) import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) ) import Xml ( Child(..), FromXml(..), FromXmlFk(..), 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 :: Int, db_schedule_id :: Int, db_tsnupdate :: Maybe Bool, db_category :: String, db_sport :: String, db_season_type :: String, 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 :: Int, xml_schedule_id :: Int, xml_tsnupdate :: Maybe Bool, xml_category :: String, xml_sport :: String, xml_locations :: [ScoreLocation], xml_season_type :: String, xml_game :: ScoreGameXml, xml_time_stamp :: UTCTime } deriving (Eq, Show) instance ToDb Message where -- | The database representation of a 'Message' is a 'Score'. type Db Message = Score instance FromXml Message where 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 :: Int, db_status_type :: 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_vscore :: Int, db_hscore :: Int, 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 :: ScoreGameVTeam, xml_hteam :: ScoreGameHTeam, xml_vscore :: Int, xml_hscore :: Int, xml_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain. xml_status :: ScoreGameStatus, xml_notes :: Maybe String } deriving (Eq, Show) -- | Pseudo-accessor to get the 'ScoreGameTeam' out of 'xml_vteam'. vteam :: ScoreGameXml -> ScoreGameTeam vteam g = let (ScoreGameVTeam t) = xml_vteam g in t -- | Pseudo-accessor to get the 'ScoreGameTeam' out of 'xml_hteam'. hteam :: ScoreGameXml -> ScoreGameTeam hteam g = let (ScoreGameHTeam t) = xml_hteam g in t 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 FromXmlFk ScoreGameXml where from_xml_fk fk ScoreGameXml{..} = ScoreGame { db_scores_id = fk, db_vscore = xml_vscore, db_hscore = xml_hscore, db_time_r = xml_time_r, db_status = xml_status, db_notes = xml_notes } -- | This lets us import the database representation 'ScoreGameXml' -- directly. -- instance XmlImportFk ScoreGameXml -- * ScoreGameTeam -- | A team that appears in a 'ScoreGame'. This is meant to represent -- both home and away teams. -- data ScoreGameTeam = ScoreGameTeam { team_id :: String, team_name :: String } deriving (Eq, Show) -- | A wrapper around 'ScoreGameTeam' that lets us distinguish between -- home and away teams. See also 'ScoreGameHTeam'. -- newtype ScoreGameVTeam = ScoreGameVTeam ScoreGameTeam deriving (Eq, Show) -- | A wrapper around 'ScoreGameTeam' that lets us distinguish between -- home and away teams. See also 'ScoreGameVTeam'. -- newtype ScoreGameHTeam = ScoreGameHTeam ScoreGameTeam deriving (Eq, Show) -- * ScoreGame_ScoreGameTeam -- | Join a 'ScoreGame' with its home/away teams. Database-only. We -- use a join table because the teams are kept unique. The first -- argument is the game id, the second argument is the visiting team -- (vteam) id, and the last argument is the home team (hteam) id. -- data ScoreGame_ScoreGameTeam = ScoreGame_ScoreGameTeam (DefaultKey ScoreGame) -- game id (DefaultKey ScoreGameTeam) -- vteam id (DefaultKey ScoreGameTeam) -- hteam id -- * ScoreLocation -- | Database and XML representation of a \. This is almost -- identical to 'TSN.XML.NewsLocation', but the city/state have not -- appeared optional here so far. -- data ScoreLocation = ScoreLocation { city :: String, state :: String, country :: String } deriving (Eq, Show) -- * Score_ScoreLocation -- | Join each 'Score' with its 'ScoreLocation's. Database-only. We -- use a join table because the locations are kept unique. -- data Score_ScoreLocation = Score_ScoreLocation (DefaultKey Score) (DefaultKey ScoreLocation) instance DbImport Message where dbmigrate _ = run_dbmigrate $ do migrate (undefined :: Score) migrate (undefined :: ScoreGame) migrate (undefined :: ScoreGameTeam) migrate (undefined :: ScoreGame_ScoreGameTeam) migrate (undefined :: ScoreLocation) migrate (undefined :: Score_ScoreLocation) 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. location_ids <- mapM insert (xml_locations m) -- Now use that list to construct 'Score_ScoreLocation' objects, -- and insert them. mapM_ (insert_ . Score_ScoreLocation msg_id) location_ids -- Insert the game and its hteam/vteam, noting the IDs. game_id <- insert_xml_fk msg_id (xml_game m) vteam_id <- insert (vteam $ xml_game m) hteam_id <- insert (hteam $ xml_game m) -- Finally add a 'ScoreGame_ScoreGameTeam' mapping the -- aforementioned game to its hteam/vteam. insert_ $ ScoreGame_ScoreGameTeam game_id vteam_id hteam_id return ImportSucceeded -- These types don't have special XML representations or field name -- collisions so we use the defaultCodegenConfig and give their -- fields nice simple names. mkPersist defaultCodegenConfig [groundhog| - entity: ScoreGameTeam dbName: scores_games_teams constructors: - name: ScoreGameTeam uniques: - name: unique_scores_games_team type: constraint fields: [team_id] - entity: ScoreLocation dbName: scores_locations constructors: - name: ScoreLocation uniques: - name: unique_scores_location type: constraint fields: [city, state, country] |] -- 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: ScoreGame_ScoreGameTeam dbName: scores_games__scores_games_teams constructors: - name: ScoreGame_ScoreGameTeam fields: - name: scoreGame_ScoreGameTeam0 # Default created by mkNormalFieldName dbName: scores_games_id reference: onDelete: cascade - name: scoreGame_ScoreGameTeam1 # Default created by mkNormalFieldName dbName: scores_games_teams_vteam_id reference: onDelete: cascade - name: scoreGame_ScoreGameTeam2 # Default created by mkNormalFieldName dbName: scores_games_teams_hteam_id reference: onDelete: cascade - entity: Score_ScoreLocation dbName: scores__scores_locations constructors: - name: Score_ScoreLocation fields: - name: score_ScoreLocation0 # Default created by mkNormalFieldName dbName: scores_id reference: onDelete: cascade - name: score_ScoreLocation1 # Default created by mkNormalFieldName dbName: scores_locations_id reference: onDelete: cascade |] -- -- Pickling -- -- | Convert a 'Message' to/from \. -- pickle_message :: PU Message pickle_message = xpElem "message" $ xpWrap (from_tuple, to_tuple) $ xp11Tuple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) (xpElem "game_id" xpInt) (xpElem "schedule_id" xpInt) (xpOption $ xpElem "tsnupdate" xpPrim) (xpElem "category" xpText) (xpElem "sport" xpText) (xpList pickle_location) (xpElem "seasontype" xpText) pickle_game (xpElem "time_stamp" xp_time_stamp) where from_tuple = uncurryN Message to_tuple m = (xml_xml_file_id m, xml_heading m, xml_game_id m, xml_schedule_id m, xml_tsnupdate m, xml_category m, xml_sport m, xml_locations m, xml_season_type m, xml_game m, xml_time_stamp m) -- | Convert a 'ScoreLocation' to/from \. -- pickle_location :: PU ScoreLocation pickle_location = xpElem "location" $ xpWrap (from_tuple, to_tuple) $ xpTriple (xpElem "city" xpText) (xpElem "state" xpText) (xpElem "country" xpText) where from_tuple = uncurryN ScoreLocation to_tuple l = (city l, state l, country l) -- | Convert a 'ScoreGameStatus' to/from \. -- pickle_status :: PU ScoreGameStatus pickle_status = xpElem "status" $ xpWrap (from_tuple, to_tuple) $ xpTriple (xpAttr "numeral" xpInt) (xpAttr "type" xpText) xpText where from_tuple = uncurryN ScoreGameStatus to_tuple ScoreGameStatus{..} = (db_status_numeral, db_status_type, db_status_text) -- | Convert a 'ScoreGameXml' to/from \. -- pickle_game :: PU ScoreGameXml pickle_game = xpElem "game" $ xpWrap (from_tuple, to_tuple) $ 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 to_tuple ScoreGameXml{..} = (xml_vteam, xml_hteam, xml_vscore, xml_hscore, xml_time_r, xml_status, xml_notes) -- | Convert a 'ScoreGameVTeam' to/from \. -- pickle_vteam :: PU ScoreGameVTeam pickle_vteam = xpElem "vteam" $ xpWrap (from_tuple, to_tuple) $ xpPair (xpAttr "id" xpText) xpText where from_tuple = ScoreGameVTeam . uncurry ScoreGameTeam to_tuple (ScoreGameVTeam ScoreGameTeam{..}) = (team_id, team_name) -- | Convert a 'ScoreGameVTeam' to/from \. Identical to -- 'pickle_vteam' modulo the \"h\" and \"v\". -- pickle_hteam :: PU ScoreGameHTeam pickle_hteam = xpElem "hteam" $ xpWrap (from_tuple, to_tuple) $ xpPair (xpAttr "id" xpText) xpText where from_tuple = ScoreGameHTeam . uncurry ScoreGameTeam to_tuple (ScoreGameHTeam ScoreGameTeam{..}) = (team_id, team_name) --- --- 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" ] 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" ] 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 ] where check desc path expected = testCase desc $ do score <- unsafe_unpickle path pickle_message let a = undefined :: Score let b = undefined :: ScoreGame let c = undefined :: ScoreGameTeam let d = undefined :: ScoreGame_ScoreGameTeam let e = undefined :: ScoreLocation let f = undefined :: Score_ScoreLocation actual <- withSqliteConn ":memory:" $ runDbConn $ do runMigration silentMigrationLogger $ do migrate a migrate b migrate c migrate d migrate e migrate f _ <- dbimport score -- No idea how 'delete' works, so do this instead. deleteAll a count_a <- countAll a count_b <- countAll b count_c <- countAll c count_d <- countAll d count_e <- countAll e count_f <- countAll f return $ sum [count_a, count_b, count_c, count_d, count_e, count_f ] actual @?= expected