{-# 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 ( 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 Control.Monad ( forM_ ) import Data.Data ( Data ) import Data.Time ( UTCTime ) import Data.Tuple.Curry ( uncurryN ) import Data.Typeable ( Typeable ) import Database.Groundhog ( countAll, executeRaw, 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, xp12Tuple, 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_gamedate, xp_time_stamp ) import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) ) import Xml ( FromXml(..), FromXmlFk(..), ToDb(..), pickle_unpickle, unpickleable, unsafe_unpickle ) -- -- DB/XML Data types -- -- * Score / Message 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 } 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) -- * ScoreGame / ScoreGameXml 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) 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 } 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) -- * ScoreGameTeam data ScoreGameTeam = ScoreGameTeam { team_id :: String, team_name :: String } deriving (Eq, Show) newtype ScoreGameVTeam = ScoreGameVTeam ScoreGameTeam deriving (Eq, Show) newtype ScoreGameHTeam = ScoreGameHTeam ScoreGameTeam deriving (Eq, Show) -- * ScoreGame_ScoreGameTeam -- | Join a ScoreGame with its home/away teams. -- data ScoreGame_ScoreGameTeam = ScoreGame_ScoreGameTeam (DefaultKey ScoreGame) -- ^ game id (DefaultKey ScoreGameTeam) -- ^ vteam id (DefaultKey ScoreGameTeam) -- ^ hteam id -- * ScoreLocation data ScoreLocation = ScoreLocation { city :: Maybe String, state :: Maybe String, country :: String } deriving (Eq, Show) -- * Score_ScoreLocation data Score_ScoreLocation = Score_ScoreLocation (DefaultKey Score) (DefaultKey ScoreLocation) -- 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 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__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 XML. -- 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 XML. -- pickle_location :: PU ScoreLocation pickle_location = xpElem "location" $ xpWrap (from_tuple, to_tuple) $ xpTriple (xpOption (xpElem "city" xpText)) (xpOption (xpElem "state" xpText)) (xpElem "country" xpText) where from_tuple = uncurryN ScoreLocation to_tuple l = (city l, state l, country l) 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 x y z) = (x,y,z) 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) 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 x y)) = (x,y) 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 x y)) = (x,y) --- --- Tasty tests --- -- | A list of all tests for this module. -- scores_tests :: TestTree scores_tests = testGroup "Scores tests" [ 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