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   migrate,
  33   runMigration,
  34   silentMigrationLogger )
  35 import Database.Groundhog.Generic ( runDbConn )
  36 import Database.Groundhog.Sqlite ( withSqliteConn )
  37 import Database.Groundhog.TH (
  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.Codegen ( tsn_codegen_config )
  47 import TSN.DbImport (
  48   DbImport(..),
  49   ImportResult(..),
  50   run_dbmigrate )
  51 import TSN.Parse (
  52   parse_message,
  53   parse_xmlfid,
  54   parse_xml_time_stamp )
  55 import TSN.XmlImport ( XmlImport(..) )
  56 import Xml (
  57   FromXml(..),
  58   ToDb(..),
  59   unsafe_read_document )
  60
  61
  62 -- | The DTDs for everything that we consider \"Sport Info.\"
  63 --
  64 dtds :: [String]
  65 dtds =
  66   [ "CBASK_3PPctXML.dtd",
  67     "Cbask_All_Tourn_Teams_XML.dtd",
  68     "CBASK_AssistsXML.dtd",
  69     "Cbask_Awards_XML.dtd",
  70     "CBASK_BlocksXML.dtd",
  71     "Cbask_Conf_Standings_XML.dtd",
  72     "Cbask_DivII_III_Indv_Stats_XML.dtd",
  73     "Cbask_DivII_Team_Stats_XML.dtd",
  74     "Cbask_DivIII_Team_Stats_XML.dtd",
  75     "CBASK_FGPctXML.dtd",
  76     "CBASK_FoulsXML.dtd",
  77     "CBASK_FTPctXML.dtd",
  78     "Cbask_Indv_Scoring_XML.dtd",
  79     "CBASK_MinutesXML.dtd",
  80     "Cbask_Polls_XML.dtd",
  81     "CBASK_ReboundsXML.dtd",
  82     "CBASK_ScoringLeadersXML.dtd",
  83     "Cbask_Team_ThreePT_Made_XML.dtd",
  84     "Cbask_Team_ThreePT_PCT_XML.dtd",
  85     "Cbask_Team_Win_Pct_XML.dtd",
  86     "Cbask_Top_Twenty_Five_XML.dtd",
  87     "CBASK_TopTwentyFiveResult_XML.dtd",
  88     "Cbask_Tourn_Awards_XML.dtd",
  89     "Cbask_Tourn_Champs_XML.dtd",
  90     "Cbask_Tourn_Indiv_XML.dtd",
  91     "Cbask_Tourn_Leaders_XML.dtd",
  92     "Cbask_Tourn_MVP_XML.dtd",
  93     "Cbask_Tourn_Records_XML.dtd",
  94     "LeagueScheduleXML.dtd",
  95     "minorscoresxml.dtd",
  96     "Minor_Baseball_League_Leaders_XML.dtd",
  97     "Minor_Baseball_Standings_XML.dtd",
  98     "Minor_Baseball_Transactions_XML.dtd",
  99     "mlbbattingavgxml.dtd",
 100     "mlbdoublesleadersxml.dtd",
 101     "MLBGamesPlayedXML.dtd",
 102     "MLBGIDPXML.dtd",
 103     "MLBHitByPitchXML.dtd",
 104     "mlbhitsleadersxml.dtd",
 105     "mlbhomerunsxml.dtd",
 106     "MLBHRFreqXML.dtd",
 107     "MLBIntWalksXML.dtd",
 108     "MLBKORateXML.dtd",
 109     "mlbonbasepctxml.dtd",
 110     "MLBOPSXML.dtd",
 111     "MLBPlateAppsXML.dtd",
 112     "mlbrbisxml.dtd",
 113     "mlbrunsleadersxml.dtd",
 114     "MLBSacFliesXML.dtd",
 115     "MLBSacrificesXML.dtd",
 116     "MLBSBSuccessXML.dtd",
 117     "mlbsluggingpctxml.dtd",
 118     "mlbstandxml.dtd",
 119     "mlbstandxml_preseason.dtd",
 120     "mlbstolenbasexml.dtd",
 121     "mlbtotalbasesleadersxml.dtd",
 122     "mlbtriplesleadersxml.dtd",
 123     "MLBWalkRateXML.dtd",
 124     "mlbwalksleadersxml.dtd",
 125     "MLBXtraBaseHitsXML.dtd",
 126     "MLB_ERA_Leaders.dtd",
 127     "MLB_Fielding_XML.dtd",
 128     "MLB_Pitching_Appearances_Leaders.dtd",
 129     "MLB_Pitching_Balks_Leaders.dtd",
 130     "MLB_Pitching_CG_Leaders.dtd",
 131     "MLB_Pitching_ER_Allowed_Leaders.dtd",
 132     "MLB_Pitching_Hits_Allowed_Leaders.dtd",
 133     "MLB_Pitching_Hit_Batters_Leaders.dtd",
 134     "MLB_Pitching_HR_Allowed_Leaders.dtd",
 135     "MLB_Pitching_IP_Leaders.dtd",
 136     "MLB_Pitching_Runs_Allowed_Leaders.dtd",
 137     "MLB_Pitching_Saves_Leaders.dtd",
 138     "MLB_Pitching_Shut_Outs_Leaders.dtd",
 139     "MLB_Pitching_Starts_Leaders.dtd",
 140     "MLB_Pitching_Strike_Outs_Leaders.dtd",
 141     "MLB_Pitching_Walks_Leaders.dtd",
 142     "MLB_Pitching_WHIP_Leaders.dtd",
 143     "MLB_Pitching_Wild_Pitches_Leaders.dtd",
 144     "MLB_Pitching_Win_Percentage_Leaders.dtd",
 145     "MLB_Pitching_WL_Leaders.dtd",
 146     "NBA_Team_Stats_XML.dtd",
 147     "NBA3PPctXML.dtd",
 148     "NBAAssistsXML.dtd",
 149     "NBABlocksXML.dtd",
 150     "nbaconfrecxml.dtd",
 151     "nbadaysxml.dtd",
 152     "nbadivisionsxml.dtd",
 153     "NBAFGPctXML.dtd",
 154     "NBAFoulsXML.dtd",
 155     "NBAFTPctXML.dtd",
 156     "NBAMinutesXML.dtd",
 157     "NBAReboundsXML.dtd",
 158     "NBAScorersXML.dtd",
 159     "nbastandxml.dtd",
 160     "NBAStealsXML.dtd",
 161     "nbateamleadersxml.dtd",
 162     "nbatripledoublexml.dtd",
 163     "NBATurnoversXML.dtd",
 164     "NCAA_Conference_Schedule_XML.dtd",
 165     "nflfirstdownxml.dtd",
 166     "NFLFumbleLeaderXML.dtd",
 167     "NFLGiveTakeXML.dtd",
 168     "NFLInside20XML.dtd",
 169     "NFLKickoffsXML.dtd",
 170     "NFLMondayNightXML.dtd",
 171     "NFLPassLeadXML.dtd",
 172     "NFLQBStartsXML.dtd",
 173     "NFLSackLeadersXML.dtd",
 174     "nflstandxml.dtd",
 175     "NFLTeamRankingsXML.dtd",
 176     "NFLTopPerformanceXML.dtd",
 177     "NFLTotalYardageXML.dtd",
 178     "NFL_KickingLeaders_XML.dtd",
 179     "NFL_NBA_Draft_XML.dtd",
 180     "NFL_Roster_XML.dtd",
 181     "NFL_Team_Stats_XML.dtd",
 182     "Transactions_XML.dtd",
 183     "Weekly_Sched_XML.dtd",
 184     "WNBA_Team_Leaders_XML.dtd",
 185     "WNBA3PPctXML.dtd",
 186     "WNBAAssistsXML.dtd",
 187     "WNBABlocksXML.dtd",
 188     "WNBAFGPctXML.dtd",
 189     "WNBAFoulsXML.dtd",
 190     "WNBAFTPctXML.dtd",
 191     "WNBAMinutesXML.dtd",
 192     "WNBAReboundsXML.dtd",
 193     "WNBAScorersXML.dtd",
 194     "wnbastandxml.dtd",
 195     "WNBAStealsXML.dtd",
 196     "WNBATurnoversXML.dtd" ]
 197
 198
 199 -- | XML representation of a SportInfo \<message\>.
 200 --
 201 data Message =
 202   Message {
 203     xml_dtd :: String,
 204     xml_xml_file_id :: Int,
 205     xml_time_stamp :: UTCTime,
 206     xml_xml :: String }
 207   deriving (Eq, Show)
 208
 209
 210 -- | Attempt to parse a 'Message' from an 'XmlTree'. If we cannot,
 211 --   we fail with an error message.
 212 --
 213 parse_xml :: String -> XmlTree -> Either String Message
 214 parse_xml dtdname xmltree = do
 215   xmlfid <- parse_xmlfid xmltree
 216   timestamp <- parse_xml_time_stamp xmltree
 217   message <- parse_message xmltree
 218   return $ Message dtdname (fromInteger xmlfid) timestamp (xshow [message])
 219
 220
 221 -- | Database representation of a 'Message'.
 222 --
 223 data SportInfo =
 224   SportInfo {
 225     db_dtd :: String,
 226     db_xml_file_id :: Int,
 227     db_time_stamp :: UTCTime,
 228     db_xml :: String }
 229
 230
 231 instance ToDb Message where
 232   -- | The database analogue of a 'Message' is an 'SportInfo'.
 233   type Db Message = SportInfo
 234
 235 instance FromXml Message where
 236   -- | The XML to DB conversion is trivial here.
 237   --
 238   from_xml Message{..} = SportInfo {
 239                            db_dtd = xml_dtd,
 240                            db_xml_file_id = xml_xml_file_id,
 241                            db_time_stamp = xml_time_stamp,
 242                            db_xml = xml_xml }
 243
 244
 245 -- | This allows us to insert the XML representation 'Message'
 246 --   directly.
 247 --
 248 instance XmlImport Message
 249
 250
 251 --
 252 -- Database code
 253 --
 254
 255 instance DbImport Message where
 256   dbmigrate _ =
 257     run_dbmigrate $ migrate (undefined :: SportInfo)
 258
 259   -- | We import a 'Message' by inserting the whole thing at
 260   --   once. Nothing fancy going on here.
 261   dbimport msg = do
 262     insert_xml_ msg
 263     return ImportSucceeded
 264
 265
 266 -- | The database schema for SportInfo is trivial; all we need is for
 267 --   the XML_File_ID to be unique.
 268 --
 269 mkPersist tsn_codegen_config [groundhog|
 270 - entity: SportInfo
 271   constructors:
 272     - name: SportInfo
 273       uniques:
 274         - name: unique_sport_info
 275           type: constraint
 276           # Prevent multiple imports of the same message.
 277           fields: [db_xml_file_id]
 278 |]
 279
 280
 281 --
 282 -- Tasty Tests
 283 --
 284
 285 -- | A list of all tests for this module.
 286 --
 287 sport_info_tests :: TestTree
 288 sport_info_tests =
 289   testGroup
 290     "SportInfo tests"
 291     [ test_parse_xml_succeeds,
 292       test_dbimport_succeeds ]
 293
 294
 295 -- | Sample XML documents for SportInfo types.
 296 --
 297 sport_info_test_files :: [FilePath]
 298 sport_info_test_files =
 299   map (change_suffix . add_path) dtds
 300   where
 301      add_path = ("test/xml/sportinfo/" ++ )
 302      change_suffix = replace ".dtd" ".xml"
 303
 304
 305 -- | Make sure we can parse every element of 'sport_info_test_files'.
 306 --
 307 test_parse_xml_succeeds :: TestTree
 308 test_parse_xml_succeeds =
 309   testGroup "parse_xml" $ map check sport_info_test_files
 310   where
 311     check t = testCase t $ do
 312       x <- unsafe_read_document t
 313       let result = parse_xml "dummy" x
 314       let actual = case result of -- isRight appears in base-4.7
 315                      Left _  -> False
 316                      Right _ -> True
 317       let expected = True
 318       actual @?= expected
 319
 320
 321 -- | Ensure that each element of 'sport_info_test_files' can be imported
 322 --   by counting the total number of database records (after
 323 --   importing) and comparing it against the length of
 324 --   'sport_info_test_files'.
 325 --
 326 test_dbimport_succeeds :: TestTree
 327 test_dbimport_succeeds = testCase "dbimport succeeds" $ do
 328   xmltrees <- mapM unsafe_read_document sport_info_test_files
 329   let msgs = rights $ map (parse_xml "dummy") xmltrees
 330   actual <- withSqliteConn ":memory:" $ runDbConn $ do
 331                 runMigration silentMigrationLogger $ do
 332                   migrate (undefined :: SportInfo)
 333                 mapM_ dbimport msgs
 334                 countAll (undefined :: SportInfo)
 335
 336   actual @?= expected
 337   where
 338     expected = length sport_info_test_files