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