htsn-import-0.2.1: src/TSN/XML/SportInfo.hs
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
-- | SportInfo represents a collection of DTDs that we don't really
-- handle but want to make available. The raw XML gets stored in the
-- database along with the XML_File_ID, but we don't parse any of it.
--
-- This is almost completely redundant with "TSN.XML.GameInfo", but
-- the redundancy is necessary: we need separate message types so
-- that we can have separate 'DbImport' instances. It would take
-- more code/work to abstract (if it's even possible) than to
-- duplicate.
--
module TSN.XML.SportInfo (
dtds,
parse_xml,
sport_info_tests,
-- * WARNING: these are private but exported to silence warnings
SportInfoConstructor(..) )
where
-- System imports.
import Data.Either ( rights )
import Data.String.Utils ( replace )
import Data.Time.Clock ( UTCTime )
import Database.Groundhog (
countAll,
insert_,
migrate )
import Database.Groundhog.Generic ( runDbConn, runMigrationSilent )
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 ( XmlTree )
import Text.XML.HXT.DOM.ShowXml ( xshow )
-- Local imports.
import TSN.DbImport (
DbImport(..),
ImportResult(..),
run_dbmigrate )
import TSN.Parse (
ParseError,
parse_message,
parse_xmlfid,
parse_xml_time_stamp )
import Xml ( unsafe_read_document )
-- | The DTDs for everything that we consider \"Sport Info.\"
--
dtds :: [String]
dtds =
[ "CBASK_3PPctXML.dtd",
"Cbask_All_Tourn_Teams_XML.dtd",
"CBASK_AssistsXML.dtd",
"Cbask_Awards_XML.dtd",
"CBASK_BlocksXML.dtd",
"Cbask_Conf_Standings_XML.dtd",
"Cbask_DivII_III_Indv_Stats_XML.dtd",
"Cbask_DivII_Team_Stats_XML.dtd",
"Cbask_DivIII_Team_Stats_XML.dtd",
"CBASK_FGPctXML.dtd",
"CBASK_FoulsXML.dtd",
"CBASK_FTPctXML.dtd",
"Cbask_Indv_No_Avg_XML.dtd",
"Cbask_Indv_Scoring_XML.dtd",
"Cbask_Indv_Shooting_XML.dtd",
"CBASK_MinutesXML.dtd",
"Cbask_Polls_XML.dtd",
"CBASK_ReboundsXML.dtd",
"CBASK_ScoringLeadersXML.dtd",
"Cbask_Team_Scoring_Rebound_Margin_XML.dtd",
"Cbask_Team_Scoring_XML.dtd",
"Cbask_Team_Shooting_Pct_XML.dtd",
"Cbask_Team_ThreePT_Made_XML.dtd",
"Cbask_Team_ThreePT_PCT_XML.dtd",
"Cbask_Team_Win_Pct_XML.dtd",
"Cbask_Top_Twenty_Five_XML.dtd",
"CBASK_TopTwentyFiveResult_XML.dtd",
"Cbask_Tourn_Awards_XML.dtd",
"Cbask_Tourn_Champs_XML.dtd",
"Cbask_Tourn_Indiv_XML.dtd",
"Cbask_Tourn_Leaders_XML.dtd",
"Cbask_Tourn_MVP_XML.dtd",
"Cbask_Tourn_Records_XML.dtd",
"LeagueScheduleXML.dtd",
"minorscoresxml.dtd",
"Minor_Baseball_League_Leaders_XML.dtd",
"Minor_Baseball_Standings_XML.dtd",
"Minor_Baseball_Transactions_XML.dtd",
"mlbbattingavgxml.dtd",
"mlbdoublesleadersxml.dtd",
"MLBGamesPlayedXML.dtd",
"MLBGIDPXML.dtd",
"MLBHitByPitchXML.dtd",
"mlbhitsleadersxml.dtd",
"mlbhomerunsxml.dtd",
"MLBHRFreqXML.dtd",
"MLBIntWalksXML.dtd",
"MLBKORateXML.dtd",
"mlbonbasepctxml.dtd",
"MLBOPSXML.dtd",
"MLBPlateAppsXML.dtd",
"mlbrbisxml.dtd",
"mlbrunsleadersxml.dtd",
"MLBSacFliesXML.dtd",
"MLBSacrificesXML.dtd",
"MLBSBSuccessXML.dtd",
"mlbsluggingpctxml.dtd",
"mlbstandxml.dtd",
"mlbstandxml_preseason.dtd",
"mlbstolenbasexml.dtd",
"mlbtotalbasesleadersxml.dtd",
"mlbtriplesleadersxml.dtd",
"MLBWalkRateXML.dtd",
"mlbwalksleadersxml.dtd",
"MLBXtraBaseHitsXML.dtd",
"MLB_ERA_Leaders.dtd",
"MLB_Fielding_XML.dtd",
"MLB_Pitching_Appearances_Leaders.dtd",
"MLB_Pitching_Balks_Leaders.dtd",
"MLB_Pitching_CG_Leaders.dtd",
"MLB_Pitching_ER_Allowed_Leaders.dtd",
"MLB_Pitching_Hits_Allowed_Leaders.dtd",
"MLB_Pitching_Hit_Batters_Leaders.dtd",
"MLB_Pitching_HR_Allowed_Leaders.dtd",
"MLB_Pitching_IP_Leaders.dtd",
"MLB_Pitching_Runs_Allowed_Leaders.dtd",
"MLB_Pitching_Saves_Leaders.dtd",
"MLB_Pitching_Shut_Outs_Leaders.dtd",
"MLB_Pitching_Starts_Leaders.dtd",
"MLB_Pitching_Strike_Outs_Leaders.dtd",
"MLB_Pitching_Walks_Leaders.dtd",
"MLB_Pitching_WHIP_Leaders.dtd",
"MLB_Pitching_Wild_Pitches_Leaders.dtd",
"MLB_Pitching_Win_Percentage_Leaders.dtd",
"MLB_Pitching_WL_Leaders.dtd",
"NBA_Team_Stats_XML.dtd",
"NBA3PPctXML.dtd",
"NBAAssistsXML.dtd",
"NBABlocksXML.dtd",
"nbaconfrecxml.dtd",
"nbadaysxml.dtd",
"nbadivisionsxml.dtd",
"NBAFGPctXML.dtd",
"NBAFoulsXML.dtd",
"NBAFTPctXML.dtd",
"NBAMinutesXML.dtd",
"NBAReboundsXML.dtd",
"NBAScorersXML.dtd",
"nbastandxml.dtd",
"NBAStealsXML.dtd",
"nbateamleadersxml.dtd",
"nbatripledoublexml.dtd",
"NBATurnoversXML.dtd",
"NCAA_Conference_Schedule_XML.dtd",
"nflfirstdownxml.dtd",
"NFLFumbleLeaderXML.dtd",
"NFLGrassTurfDomeOutsideXML.dtd",
"NFLGiveTakeXML.dtd",
"NFLInside20XML.dtd",
"NFLInterceptionLeadersXML.dtd",
"NFLKickoffsXML.dtd",
"NFLMondayNightXML.dtd",
"NFLPassingLeadersXML.dtd",
"NFLPassLeadXML.dtd",
"NFLQBStartsXML.dtd",
"NFLReceivingLeadersXML.dtd",
"NFLRushingLeadersXML.dtd",
"NFLSackLeadersXML.dtd",
"nflstandxml.dtd",
"NFLTackleFFLeadersXML.dtd",
"NFLTeamRankingsXML.dtd",
"NFLTopKickoffReturnXML.dtd",
"NFLTopPerformanceXML.dtd",
"NFLTopPuntReturnXML.dtd",
"NFLTotalYardageXML.dtd",
"NFLYardsXML.dtd",
"NFL_KickingLeaders_XML.dtd",
"NFL_NBA_Draft_XML.dtd",
"NFL_PuntingLeaders_XML.dtd",
"NFL_Roster_XML.dtd",
"NFL_Team_Stats_XML.dtd",
"Transactions_XML.dtd",
"Weekly_Sched_XML.dtd",
"WNBA_Team_Leaders_XML.dtd",
"WNBA3PPctXML.dtd",
"WNBAAssistsXML.dtd",
"WNBABlocksXML.dtd",
"WNBAFGPctXML.dtd",
"WNBAFoulsXML.dtd",
"WNBAFTPctXML.dtd",
"WNBAMinutesXML.dtd",
"WNBAReboundsXML.dtd",
"WNBAScorersXML.dtd",
"wnbastandxml.dtd",
"WNBAStealsXML.dtd",
"WNBATurnoversXML.dtd" ]
-- | This serves as both the database and XML representation of a
-- SportInfo \<message\>.
--
data SportInfo =
SportInfo {
dtd :: String,
xml_file_id :: Int,
time_stamp :: UTCTime,
xml :: String }
deriving (Eq, Show)
-- | Attempt to parse a 'SportInfo' from an 'XmlTree'. If we cannot,
-- we fail with an error message.
--
parse_xml :: String -> XmlTree -> Either ParseError SportInfo
parse_xml dtdname xmltree = do
xmlfid <- parse_xmlfid xmltree
timestamp <- parse_xml_time_stamp xmltree
message <- parse_message xmltree
return $ SportInfo dtdname xmlfid timestamp (xshow [message])
--
-- Database code
--
instance DbImport SportInfo where
dbmigrate _ =
run_dbmigrate $ migrate (undefined :: SportInfo)
-- | We import a 'SportInfo' by inserting the whole thing at
-- once. Nothing fancy going on here.
dbimport msg = do
insert_ msg
return ImportSucceeded
-- | The database schema for SportInfo is trivial; all we need is for
-- the XML_File_ID to be unique.
--
mkPersist defaultCodegenConfig [groundhog|
- entity: SportInfo
dbName: sport_info
constructors:
- name: SportInfo
uniques:
- name: unique_sport_info
type: constraint
# Prevent multiple imports of the same message.
fields: [xml_file_id]
|]
--
-- Tasty Tests
--
-- | A list of all tests for this module.
--
sport_info_tests :: TestTree
sport_info_tests =
testGroup
"SportInfo tests"
[ test_accessors,
test_parse_xml_succeeds,
test_dbimport_succeeds ]
-- | Make sure the accessors work and that we can parse one file. Ok,
-- so the real point of this is to make the unused fields (dtd, xml,
-- ...) warning go away without having to mangle the groundhog code.
--
test_accessors :: TestTree
test_accessors = testCase "we can access a parsed sport_info" $ do
xmltree <- unsafe_read_document "test/xml/sportinfo/wnbastandxml.xml"
let Right t = parse_xml "wnbastandxml.dtd" xmltree
let a1 = dtd t
let ex1 = "wnbastandxml.dtd"
let a2 = xml_file_id t
let ex2 = 2011
let a3 = show $ time_stamp t
let ex3 = "2009-09-27 19:50:00 UTC"
let a4 = take 9 (xml t)
let ex4 = "<message>"
let actual = (a1,a2,a3,a4)
let expected = (ex1,ex2,ex3,ex4)
actual @?= expected
-- | Sample XML documents for SportInfo types.
--
sport_info_test_files :: [FilePath]
sport_info_test_files =
map (change_suffix . add_path) dtds
where
add_path = ("test/xml/sportinfo/" ++ )
change_suffix = replace ".dtd" ".xml"
-- | Make sure we can parse every element of 'sport_info_test_files'.
--
test_parse_xml_succeeds :: TestTree
test_parse_xml_succeeds =
testGroup "parse_xml" $ map check sport_info_test_files
where
check t = testCase t $ do
x <- unsafe_read_document t
let result = parse_xml "dummy" x
let actual = case result of -- isRight appears in base-4.7
Left _ -> False
Right _ -> True
let expected = True
actual @?= expected
-- | Ensure that each element of 'sport_info_test_files' can be imported
-- by counting the total number of database records (after
-- importing) and comparing it against the length of
-- 'sport_info_test_files'.
--
test_dbimport_succeeds :: TestTree
test_dbimport_succeeds = testCase "dbimport succeeds" $ do
xmltrees <- mapM unsafe_read_document sport_info_test_files
let msgs = rights $ map (parse_xml "dummy") xmltrees
actual <- withSqliteConn ":memory:" $ runDbConn $ do
runMigrationSilent $
migrate (undefined :: SportInfo)
mapM_ dbimport msgs
countAll (undefined :: SportInfo)
actual @?= expected
where
expected = length sport_info_test_files