src/TSN/XML/SportInfo.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE QuasiQuotes #-}
   4 {-# LANGUAGE RecordWildCards #-}
   5 {-# LANGUAGE TemplateHaskell #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7
   8 -- | SportInfo represents a collection of DTDs that we don't really
   9 --   handle but want to make available. The raw XML gets stored in the
  10 --   database along with the XML_File_ID, but we don't parse any of it.
  11 --
  12 --   This is almost completely redundant with "TSN.XML.GameInfo", but
  13 --   the redundancy is necessary: we need separate message types so
  14 --   that we can have separate 'DbImport' instances. It would take
  15 --   more code/work to abstract (if it's even possible) than to
  16 --   duplicate.
  17 --
  18 module TSN.XML.SportInfo (
  19   dtds,
  20   parse_xml,
  21   sport_info_tests,
  22   -- * WARNING: these are private but exported to silence warnings
  23   SportInfoConstructor(..) )
  24 where
  25
  26 -- System imports.
  27 import Data.Either ( rights )
  28 import Data.String.Utils ( replace )
  29 import Data.Time.Clock ( UTCTime )
  30 import Database.Groundhog (
  31   countAll,
  32   insert_,
  33   migrate )
  34 import Database.Groundhog.Generic ( runDbConn, runMigrationSilent )
  35 import Database.Groundhog.Sqlite ( withSqliteConn )
  36 import Database.Groundhog.TH (
  37   defaultCodegenConfig,
  38   groundhog,
  39   mkPersist )
  40 import Test.Tasty ( TestTree, testGroup )
  41 import Test.Tasty.HUnit ( (@?=), testCase )
  42 import Text.XML.HXT.Core ( XmlTree )
  43 import Text.XML.HXT.DOM.ShowXml ( xshow )
  44
  45 -- Local imports.
  46 import TSN.DbImport (
  47   DbImport(..),
  48   ImportResult(..),
  49   run_dbmigrate )
  50 import TSN.Parse (
  51   ParseError,
  52   parse_message,
  53   parse_xmlfid,
  54   parse_xml_time_stamp )
  55 import Xml ( unsafe_read_document )
  56
  57
  58 -- | The DTDs for everything that we consider \"Sport Info.\"
  59 --
  60 dtds :: [String]
  61 dtds =
  62   [ "CBASK_3PPctXML.dtd",
  63     "Cbask_All_Tourn_Teams_XML.dtd",
  64     "CBASK_AssistsXML.dtd",
  65     "Cbask_Awards_XML.dtd",
  66     "CBASK_BlocksXML.dtd",
  67     "Cbask_Conf_Standings_XML.dtd",
  68     "Cbask_DivII_III_Indv_Stats_XML.dtd",
  69     "Cbask_DivII_Team_Stats_XML.dtd",
  70     "Cbask_DivIII_Team_Stats_XML.dtd",
  71     "CBASK_FGPctXML.dtd",
  72     "CBASK_FoulsXML.dtd",
  73     "CBASK_FTPctXML.dtd",
  74     "Cbask_Indv_No_Avg_XML.dtd",
  75     "Cbask_Indv_Scoring_XML.dtd",
  76     "Cbask_Indv_Shooting_XML.dtd",
  77     "CBASK_MinutesXML.dtd",
  78     "Cbask_Polls_XML.dtd",
  79     "CBASK_ReboundsXML.dtd",
  80     "CBASK_ScoringLeadersXML.dtd",
  81     "Cbask_Team_Scoring_Rebound_Margin_XML.dtd",
  82     "Cbask_Team_Scoring_XML.dtd",
  83     "Cbask_Team_Shooting_Pct_XML.dtd",
  84     "Cbask_Team_ThreePT_Made_XML.dtd",
  85     "Cbask_Team_ThreePT_PCT_XML.dtd",
  86     "Cbask_Team_Win_Pct_XML.dtd",
  87     "Cbask_Top_Twenty_Five_XML.dtd",
  88     "CBASK_TopTwentyFiveResult_XML.dtd",
  89     "Cbask_Tourn_Awards_XML.dtd",
  90     "Cbask_Tourn_Champs_XML.dtd",
  91     "Cbask_Tourn_Indiv_XML.dtd",
  92     "Cbask_Tourn_Leaders_XML.dtd",
  93     "Cbask_Tourn_MVP_XML.dtd",
  94     "Cbask_Tourn_Records_XML.dtd",
  95     "LeagueScheduleXML.dtd",
  96     "minorscoresxml.dtd",
  97     "Minor_Baseball_League_Leaders_XML.dtd",
  98     "Minor_Baseball_Standings_XML.dtd",
  99     "Minor_Baseball_Transactions_XML.dtd",
 100     "mlbbattingavgxml.dtd",
 101     "mlbdoublesleadersxml.dtd",
 102     "MLBGamesPlayedXML.dtd",
 103     "MLBGIDPXML.dtd",
 104     "MLBHitByPitchXML.dtd",
 105     "mlbhitsleadersxml.dtd",
 106     "mlbhomerunsxml.dtd",
 107     "MLBHRFreqXML.dtd",
 108     "MLBIntWalksXML.dtd",
 109     "MLBKORateXML.dtd",
 110     "mlbonbasepctxml.dtd",
 111     "MLBOPSXML.dtd",
 112     "MLBPlateAppsXML.dtd",
 113     "mlbrbisxml.dtd",
 114     "mlbrunsleadersxml.dtd",
 115     "MLBSacFliesXML.dtd",
 116     "MLBSacrificesXML.dtd",
 117     "MLBSBSuccessXML.dtd",
 118     "mlbsluggingpctxml.dtd",
 119     "mlbstandxml.dtd",
 120     "mlbstandxml_preseason.dtd",
 121     "mlbstolenbasexml.dtd",
 122     "mlbtotalbasesleadersxml.dtd",
 123     "mlbtriplesleadersxml.dtd",
 124     "MLBWalkRateXML.dtd",
 125     "mlbwalksleadersxml.dtd",
 126     "MLBXtraBaseHitsXML.dtd",
 127     "MLB_ERA_Leaders.dtd",
 128     "MLB_Fielding_XML.dtd",
 129     "MLB_Pitching_Appearances_Leaders.dtd",
 130     "MLB_Pitching_Balks_Leaders.dtd",
 131     "MLB_Pitching_CG_Leaders.dtd",
 132     "MLB_Pitching_ER_Allowed_Leaders.dtd",
 133     "MLB_Pitching_Hits_Allowed_Leaders.dtd",
 134     "MLB_Pitching_Hit_Batters_Leaders.dtd",
 135     "MLB_Pitching_HR_Allowed_Leaders.dtd",
 136     "MLB_Pitching_IP_Leaders.dtd",
 137     "MLB_Pitching_Runs_Allowed_Leaders.dtd",
 138     "MLB_Pitching_Saves_Leaders.dtd",
 139     "MLB_Pitching_Shut_Outs_Leaders.dtd",
 140     "MLB_Pitching_Starts_Leaders.dtd",
 141     "MLB_Pitching_Strike_Outs_Leaders.dtd",
 142     "MLB_Pitching_Walks_Leaders.dtd",
 143     "MLB_Pitching_WHIP_Leaders.dtd",
 144     "MLB_Pitching_Wild_Pitches_Leaders.dtd",
 145     "MLB_Pitching_Win_Percentage_Leaders.dtd",
 146     "MLB_Pitching_WL_Leaders.dtd",
 147     "NBA_Team_Stats_XML.dtd",
 148     "NBA3PPctXML.dtd",
 149     "NBAAssistsXML.dtd",
 150     "NBABlocksXML.dtd",
 151     "nbaconfrecxml.dtd",
 152     "nbadaysxml.dtd",
 153     "nbadivisionsxml.dtd",
 154     "NBAFGPctXML.dtd",
 155     "NBAFoulsXML.dtd",
 156     "NBAFTPctXML.dtd",
 157     "NBAMinutesXML.dtd",
 158     "NBAReboundsXML.dtd",
 159     "NBAScorersXML.dtd",
 160     "nbastandxml.dtd",
 161     "NBAStealsXML.dtd",
 162     "nbateamleadersxml.dtd",
 163     "nbatripledoublexml.dtd",
 164     "NBATurnoversXML.dtd",
 165     "NCAA_Conference_Schedule_XML.dtd",
 166     "nflfirstdownxml.dtd",
 167     "NFLFumbleLeaderXML.dtd",
 168     "NFLGrassTurfDomeOutsideXML.dtd",
 169     "NFLGiveTakeXML.dtd",
 170     "NFLInside20XML.dtd",
 171     "NFLInterceptionLeadersXML.dtd",
 172     "NFLKickoffsXML.dtd",
 173     "NFLMondayNightXML.dtd",
 174     "NFLPassingLeadersXML.dtd",
 175     "NFLPassLeadXML.dtd",
 176     "NFLQBStartsXML.dtd",
 177     "NFLReceivingLeadersXML.dtd",
 178     "NFLRushingLeadersXML.dtd",
 179     "NFLSackLeadersXML.dtd",
 180     "nflstandxml.dtd",
 181     "NFLTackleFFLeadersXML.dtd",
 182     "NFLTeamRankingsXML.dtd",
 183     "NFLTopKickoffReturnXML.dtd",
 184     "NFLTopPerformanceXML.dtd",
 185     "NFLTopPuntReturnXML.dtd",
 186     "NFLTotalYardageXML.dtd",
 187     "NFLYardsXML.dtd",
 188     "NFL_KickingLeaders_XML.dtd",
 189     "NFL_NBA_Draft_XML.dtd",
 190     "NFL_PuntingLeaders_XML.dtd",
 191     "NFL_Roster_XML.dtd",
 192     "NFL_Team_Stats_XML.dtd",
 193     "Transactions_XML.dtd",
 194     "Weekly_Sched_XML.dtd",
 195     "WNBA_Team_Leaders_XML.dtd",
 196     "WNBA3PPctXML.dtd",
 197     "WNBAAssistsXML.dtd",
 198     "WNBABlocksXML.dtd",
 199     "WNBAFGPctXML.dtd",
 200     "WNBAFoulsXML.dtd",
 201     "WNBAFTPctXML.dtd",
 202     "WNBAMinutesXML.dtd",
 203     "WNBAReboundsXML.dtd",
 204     "WNBAScorersXML.dtd",
 205     "wnbastandxml.dtd",
 206     "WNBAStealsXML.dtd",
 207     "WNBATurnoversXML.dtd" ]
 208
 209
 210 -- | This serves as both the database and XML representation of a
 211 --   SportInfo \<message\>.
 212 --
 213 data SportInfo =
 214   SportInfo {
 215     dtd :: String,
 216     xml_file_id :: Int,
 217     time_stamp :: UTCTime,
 218     xml :: String }
 219   deriving (Eq, Show)
 220
 221
 222 -- | Attempt to parse a 'SportInfo' from an 'XmlTree'. If we cannot,
 223 --   we fail with an error message.
 224 --
 225 parse_xml :: String -> XmlTree -> Either ParseError SportInfo
 226 parse_xml dtdname xmltree = do
 227   xmlfid <- parse_xmlfid xmltree
 228   timestamp <- parse_xml_time_stamp xmltree
 229   message <- parse_message xmltree
 230   return $ SportInfo dtdname xmlfid timestamp (xshow [message])
 231
 232
 233 --
 234 -- Database code
 235 --
 236
 237 instance DbImport SportInfo where
 238   dbmigrate _ =
 239     run_dbmigrate $ migrate (undefined :: SportInfo)
 240
 241   -- | We import a 'SportInfo' by inserting the whole thing at
 242   --   once. Nothing fancy going on here.
 243   dbimport msg = do
 244     insert_ msg
 245     return ImportSucceeded
 246
 247
 248 -- | The database schema for SportInfo is trivial; all we need is for
 249 --   the XML_File_ID to be unique.
 250 --
 251 mkPersist defaultCodegenConfig [groundhog|
 252 - entity: SportInfo
 253   dbName: sport_info
 254   constructors:
 255     - name: SportInfo
 256       uniques:
 257         - name: unique_sport_info
 258           type: constraint
 259           # Prevent multiple imports of the same message.
 260           fields: [xml_file_id]
 261 |]
 262
 263
 264 --
 265 -- Tasty Tests
 266 --
 267
 268 -- | A list of all tests for this module.
 269 --
 270 sport_info_tests :: TestTree
 271 sport_info_tests =
 272   testGroup
 273     "SportInfo tests"
 274     [ test_accessors,
 275       test_parse_xml_succeeds,
 276       test_dbimport_succeeds ]
 277
 278
 279 -- | Make sure the accessors work and that we can parse one file. Ok,
 280 --   so the real point of this is to make the unused fields (dtd, xml,
 281 --   ...) warning go away without having to mangle the groundhog code.
 282 --
 283 test_accessors :: TestTree
 284 test_accessors = testCase "we can access a parsed sport_info" $ do
 285   xmltree <- unsafe_read_document "test/xml/sportinfo/wnbastandxml.xml"
 286   let Right t = parse_xml "wnbastandxml.dtd" xmltree
 287   let a1  = dtd t
 288   let ex1 = "wnbastandxml.dtd"
 289   let a2  = xml_file_id t
 290   let ex2 = 2011
 291   let a3  = show $ time_stamp t
 292   let ex3 = "2009-09-27 19:50:00 UTC"
 293   let a4  = take 9 (xml t)
 294   let ex4 = "<message>"
 295   let actual = (a1,a2,a3,a4)
 296   let expected = (ex1,ex2,ex3,ex4)
 297   actual @?= expected
 298
 299
 300 -- | Sample XML documents for SportInfo types.
 301 --
 302 sport_info_test_files :: [FilePath]
 303 sport_info_test_files =
 304   map (change_suffix . add_path) dtds
 305   where
 306      add_path = ("test/xml/sportinfo/" ++ )
 307      change_suffix = replace ".dtd" ".xml"
 308
 309
 310 -- | Make sure we can parse every element of 'sport_info_test_files'.
 311 --
 312 test_parse_xml_succeeds :: TestTree
 313 test_parse_xml_succeeds =
 314   testGroup "parse_xml" $ map check sport_info_test_files
 315   where
 316     check t = testCase t $ do
 317       x <- unsafe_read_document t
 318       let result = parse_xml "dummy" x
 319       let actual = case result of -- isRight appears in base-4.7
 320                      Left _  -> False
 321                      Right _ -> True
 322       let expected = True
 323       actual @?= expected
 324
 325
 326 -- | Ensure that each element of 'sport_info_test_files' can be imported
 327 --   by counting the total number of database records (after
 328 --   importing) and comparing it against the length of
 329 --   'sport_info_test_files'.
 330 --
 331 test_dbimport_succeeds :: TestTree
 332 test_dbimport_succeeds = testCase "dbimport succeeds" $ do
 333   xmltrees <- mapM unsafe_read_document sport_info_test_files
 334   let msgs = rights $ map (parse_xml "dummy") xmltrees
 335   actual <- withSqliteConn ":memory:" $ runDbConn $ do
 336                 runMigrationSilent $
 337                   migrate (undefined :: SportInfo)
 338                 mapM_ dbimport msgs
 339                 countAll (undefined :: SportInfo)
 340
 341   actual @?= expected
 342   where
 343     expected = length sport_info_test_files