From 6c0f782525b51d1f99f337ddfebc31d54c499b3d Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Fri, 24 Jan 2014 15:27:47 -0500 Subject: [PATCH] Add the TSN.XML.Scores module (no db support yet) and update docs and tests for it. --- doc/man1/htsn-import.1 | 2 + htsn-import.cabal | 2 + src/Main.hs | 1 + src/TSN/XML/Scores.hs | 438 ++++++++++++++++++++++++++++++ test/TestSuite.hs | 2 + test/shell/import-duplicates.test | 2 +- 6 files changed, 446 insertions(+), 1 deletion(-) create mode 100644 src/TSN/XML/Scores.hs diff --git a/doc/man1/htsn-import.1 b/doc/man1/htsn-import.1 index ef43f1e..a870cbe 100644 --- a/doc/man1/htsn-import.1 +++ b/doc/man1/htsn-import.1 @@ -60,6 +60,8 @@ newsxml.dtd .IP \[bu] Odds_XML.dtd .IP \[bu] +scoresxml.dtd +.IP \[bu] weatherxml.dtd .SH DATABASE SCHEMA diff --git a/htsn-import.cabal b/htsn-import.cabal index 8eae1a9..5fba9c5 100644 --- a/htsn-import.cabal +++ b/htsn-import.cabal @@ -22,6 +22,7 @@ extra-source-files: schemagen/Injuries_Detail_XML/*.xml schemagen/newsxml/*.xml schemagen/Odds_XML/*.xml + schemagen/scoresxml/*.xml schemagen/weatherxml/*.xml test/shell/*.test test/xml/*.xml @@ -116,6 +117,7 @@ executable htsn-import TSN.XML.InjuriesDetail TSN.XML.News TSN.XML.Odds + TSN.XML.Scores TSN.XML.Weather Xml diff --git a/src/Main.hs b/src/Main.hs index 8459397..853c64d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -52,6 +52,7 @@ import qualified TSN.XML.Injuries as Injuries ( pickle_message ) import qualified TSN.XML.InjuriesDetail as InjuriesDetail ( pickle_message ) import qualified TSN.XML.News as News ( pickle_message ) import qualified TSN.XML.Odds as Odds ( pickle_message ) +import qualified TSN.XML.Scores as Scores ( pickle_message ) import qualified TSN.XML.Weather as Weather ( pickle_message ) import Xml ( DtdName(..), parse_opts ) diff --git a/src/TSN/XML/Scores.hs b/src/TSN/XML/Scores.hs new file mode 100644 index 0000000..8660b1f --- /dev/null +++ b/src/TSN/XML/Scores.hs @@ -0,0 +1,438 @@ +{-# 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 diff --git a/test/TestSuite.hs b/test/TestSuite.hs index 051d1f0..2db5e45 100644 --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -6,6 +6,7 @@ import TSN.XML.Injuries ( injuries_tests ) import TSN.XML.InjuriesDetail ( injuries_detail_tests ) import TSN.XML.News ( news_tests ) import TSN.XML.Odds ( odds_tests ) +import TSN.XML.Scores ( scores_tests ) import TSN.XML.Weather ( weather_tests ) tests :: TestTree @@ -17,6 +18,7 @@ tests = testGroup injuries_detail_tests, news_tests, odds_tests, + scores_tests, weather_tests ] main :: IO () diff --git a/test/shell/import-duplicates.test b/test/shell/import-duplicates.test index 7bf5456..b4c3fa5 100644 --- a/test/shell/import-duplicates.test +++ b/test/shell/import-duplicates.test @@ -15,7 +15,7 @@ rm -f shelltest.sqlite3 # Heartbeat.xml that doesn't really count. find ./test/xml -name '*.xml' | wc -l >>> -14 +16 >>>= 0 # Run the imports again; we should get complaints about the duplicate -- 2.43.2