]> gitweb.michael.orlitzky.com - dead/htsn-import.git/blob - XML/Weather.hs
Allow "TBA" laps in TSN.XML.AutoRacingSchedule.
[dead/htsn-import.git] / XML / Weather.hs
1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE GADTs #-}
3 {-# LANGUAGE QuasiQuotes #-}
4 {-# LANGUAGE RecordWildCards #-}
5 {-# LANGUAGE TemplateHaskell #-}
6 {-# LANGUAGE TypeFamilies #-}
7
8 -- | Parse TSN XML for the DTD \"weatherxml.dtd\". Each document
9 -- contains a bunch of forecasts, which each contain one league, and
10 -- that league contains a bunch of listings.
11 --
12 module TSN.XML.Weather (
13 dtd,
14 pickle_message,
15 -- * Tests
16 weather_tests,
17 -- * WARNING: these are private but exported to silence warnings
18 WeatherConstructor(..),
19 WeatherForecastConstructor(..),
20 WeatherForecastListingConstructor(..) )
21 where
22
23 -- System imports.
24 import Control.Monad ( forM_ )
25 import Data.Time ( UTCTime )
26 import Data.Tuple.Curry ( uncurryN )
27 import Database.Groundhog (
28 countAll,
29 deleteAll,
30 migrate,
31 runMigration,
32 silentMigrationLogger )
33 import Database.Groundhog.Core ( DefaultKey )
34 import Database.Groundhog.Generic ( runDbConn )
35 import Database.Groundhog.Sqlite ( withSqliteConn )
36 import Database.Groundhog.TH (
37 groundhog,
38 mkPersist )
39 import Test.Tasty ( TestTree, testGroup )
40 import Test.Tasty.HUnit ( (@?=), testCase )
41 import Text.XML.HXT.Core (
42 PU,
43 xp7Tuple,
44 xpAttr,
45 xpElem,
46 xpInt,
47 xpList,
48 xpOption,
49 xpPair,
50 xpText,
51 xpWrap )
52
53 -- Local imports.
54 import TSN.Codegen (
55 tsn_codegen_config )
56 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
57 import TSN.Picklers ( xp_gamedate, xp_time_stamp )
58 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
59 import Xml (
60 Child(..),
61 FromXml(..),
62 FromXmlFk(..),
63 ToDb(..),
64 pickle_unpickle,
65 unpickleable,
66 unsafe_unpickle )
67
68
69
70 -- | The DTD to which this module corresponds. Used to invoke dbimport.
71 --
72 dtd :: String
73 dtd = "weatherxml.dtd"
74
75
76 --
77 -- DB/XML Data types
78 --
79
80 -- * WeatherForecastListing/WeatherForecastListingXml
81
82 -- | XML representation of a weather forecast listing.
83 --
84 data WeatherForecastListingXml =
85 WeatherForecastListingXml {
86 xml_teams :: String,
87 xml_weather :: String }
88 deriving (Eq, Show)
89
90 -- | Database representation of a weather forecast listing.
91 --
92 data WeatherForecastListing =
93 WeatherForecastListing {
94 db_weather_forecasts_id :: DefaultKey WeatherForecast,
95 db_teams :: String,
96 db_weather :: String }
97
98
99 -- | The database analogue of a 'WeatherForecastListingXml' is
100 -- 'WeatherForecastListing'.
101 --
102 instance ToDb WeatherForecastListingXml where
103 type Db WeatherForecastListingXml = WeatherForecastListing
104
105
106 instance Child WeatherForecastListingXml where
107 -- | Each 'WeatherForecastListingXml' is contained in a
108 -- 'WeatherForecast'.
109 --
110 type Parent WeatherForecastListingXml = WeatherForecast
111
112
113 -- | This is needed to define the 'XmlImportFk' instance for
114 -- 'WeatherForecastListing'.
115 --
116 instance FromXmlFk WeatherForecastListingXml where
117 from_xml_fk fk WeatherForecastListingXml{..} =
118 WeatherForecastListing {
119 db_weather_forecasts_id = fk,
120 db_teams = xml_teams,
121 db_weather = xml_weather }
122
123 -- | This allows us to insert the XML representation
124 -- 'WeatherForecastListingXml' directly.
125 --
126 instance XmlImportFk WeatherForecastListingXml
127
128
129 -- * WeatherLeague
130
131 -- | XML representation of a league, as they appear in the weather
132 -- documents. There is no associated database representation because
133 -- the league element really adds no information besides its own
134 -- (usually empty) name. Since there's exactly one league per
135 -- forecast, we just store the league_name in the database
136 -- representation of a forecast.
137 --
138 data WeatherLeague =
139 WeatherLeague {
140 league_name :: Maybe String,
141 listings :: [WeatherForecastListingXml] }
142 deriving (Eq, Show)
143
144
145 -- * WeatherForecast/WeatherForecastXml
146
147 -- | Database representation of a weather forecast.
148 --
149 data WeatherForecast =
150 WeatherForecast {
151 db_weather_id :: DefaultKey Weather,
152 db_game_date :: UTCTime,
153 db_league_name :: Maybe String }
154
155 -- | XML representation of a weather forecast. It would have been
156 -- cleaner to omit the 'WeatherLeague' middleman, but having it
157 -- simplifies parsing.
158 --
159 data WeatherForecastXml =
160 WeatherForecastXml {
161 xml_game_date :: UTCTime,
162 xml_league :: WeatherLeague }
163 deriving (Eq, Show)
164
165 instance ToDb WeatherForecastXml where
166 -- | The database representation of a 'WeatherForecastXml' is a
167 -- 'WeatherForecast'.
168 --
169 type Db WeatherForecastXml = WeatherForecast
170
171
172 instance Child WeatherForecastXml where
173 -- | The database type containing a 'WeatherForecastXml' is
174 -- 'Weather'.
175 type Parent WeatherForecastXml = Weather
176
177
178 instance FromXmlFk WeatherForecastXml where
179
180 -- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
181 -- replace the 'WeatherLeague' with its name.
182 --
183 from_xml_fk fk WeatherForecastXml{..} =
184 WeatherForecast {
185 db_weather_id = fk,
186 db_game_date = xml_game_date,
187 db_league_name = (league_name xml_league) }
188
189
190 -- | This allows us to call 'insert_xml' on an 'WeatherForecastXml'
191 -- without first converting it to the database representation.
192 --
193 instance XmlImportFk WeatherForecastXml
194
195
196 -- * Weather/Message
197
198 -- | The database representation of a weather message.
199 --
200 data Weather =
201 Weather {
202 db_xml_file_id :: Int,
203 db_sport :: String,
204 db_title :: String,
205 db_time_stamp :: UTCTime }
206
207
208 -- | The XML representation of a weather message.
209 --
210 data Message =
211 Message {
212 xml_xml_file_id :: Int,
213 xml_heading :: String,
214 xml_category :: String,
215 xml_sport :: String,
216 xml_title :: String,
217 xml_forecasts :: [WeatherForecastXml],
218 xml_time_stamp :: UTCTime }
219 deriving (Eq, Show)
220
221 instance ToDb Message where
222 -- | The database representation of 'Message' is 'Weather'.
223 --
224 type Db Message = Weather
225
226 instance FromXml Message where
227 -- | To get a 'Weather' from a 'Message', we drop a bunch of
228 -- unwanted fields.
229 --
230 from_xml Message{..} =
231 Weather {
232 db_xml_file_id = xml_xml_file_id,
233 db_sport = xml_sport,
234 db_title = xml_title,
235 db_time_stamp = xml_time_stamp }
236
237 -- | This allows us to insert the XML representation 'Message'
238 -- directly.
239 --
240 instance XmlImport Message
241
242
243 --
244 -- Database stuff
245 --
246
247 mkPersist tsn_codegen_config [groundhog|
248 - entity: Weather
249 constructors:
250 - name: Weather
251 uniques:
252 - name: unique_weather
253 type: constraint
254 # Prevent multiple imports of the same message.
255 fields: [db_xml_file_id]
256
257 - entity: WeatherForecast
258 dbName: weather_forecasts
259 constructors:
260 - name: WeatherForecast
261 fields:
262 - name: db_weather_id
263 reference:
264 onDelete: cascade
265
266 - entity: WeatherForecastListing
267 dbName: weather_forecast_listings
268 constructors:
269 - name: WeatherForecastListing
270 fields:
271 - name: db_weather_forecasts_id
272 reference:
273 onDelete: cascade
274
275 |]
276
277
278 instance DbImport Message where
279 dbmigrate _ =
280 run_dbmigrate $ do
281 migrate (undefined :: Weather)
282 migrate (undefined :: WeatherForecast)
283 migrate (undefined :: WeatherForecastListing)
284
285 dbimport m = do
286 -- The weather database schema has a nice linear structure. First
287 -- we insert the top-level weather record.
288 weather_id <- insert_xml m
289
290 -- Next insert all of the forecasts, one at a time.
291 forM_ (xml_forecasts m) $ \forecast -> do
292 forecast_id <- insert_xml_fk weather_id forecast
293
294 -- Insert all of this forecast's listings.
295 mapM_ (insert_xml_fk_ forecast_id) (listings $ xml_league forecast)
296
297 return ImportSucceeded
298
299
300 ---
301 --- Pickling
302 ---
303
304 -- | Pickler to convert a 'WeatherForecastListingXml' to/from XML.
305 --
306 pickle_listing :: PU WeatherForecastListingXml
307 pickle_listing =
308 xpElem "listing" $
309 xpWrap (from_pair, to_pair) $
310 xpPair
311 (xpElem "teams" xpText)
312 (xpElem "weather" xpText)
313 where
314 from_pair = uncurry WeatherForecastListingXml
315 to_pair WeatherForecastListingXml{..} = (xml_teams, xml_weather)
316
317
318 -- | Pickler to convert a 'WeatherLeague' to/from XML.
319 --
320 pickle_league :: PU WeatherLeague
321 pickle_league =
322 xpElem "league" $
323 xpWrap (from_pair, to_pair) $
324 xpPair
325 (xpAttr "name" $ xpOption xpText)
326 (xpList pickle_listing)
327 where
328 from_pair = uncurry WeatherLeague
329 to_pair WeatherLeague{..} = (league_name, listings)
330
331
332 -- | Pickler to convert a 'WeatherForecastXml' to/from XML.
333 --
334 pickle_forecast :: PU WeatherForecastXml
335 pickle_forecast =
336 xpElem "forecast" $
337 xpWrap (from_pair, to_pair) $
338 xpPair
339 (xpAttr "gamedate" xp_gamedate)
340 pickle_league
341 where
342 from_pair = uncurry WeatherForecastXml
343 to_pair WeatherForecastXml{..} = (xml_game_date,
344 xml_league)
345
346
347
348 -- | Pickler to convert a 'Message' to/from XML.
349 --
350 pickle_message :: PU Message
351 pickle_message =
352 xpElem "message" $
353 xpWrap (from_tuple, to_tuple) $
354 xp7Tuple
355 (xpElem "XML_File_ID" xpInt)
356 (xpElem "heading" xpText)
357 (xpElem "category" xpText)
358 (xpElem "sport" xpText)
359 (xpElem "title" xpText)
360 (xpList pickle_forecast)
361 (xpElem "time_stamp" xp_time_stamp)
362 where
363 from_tuple = uncurryN Message
364 to_tuple Message{..} = (xml_xml_file_id,
365 xml_heading,
366 xml_category,
367 xml_sport,
368 xml_title,
369 xml_forecasts,
370 xml_time_stamp)
371
372 --
373 -- Tasty tests
374 --
375
376 weather_tests :: TestTree
377 weather_tests =
378 testGroup
379 "Weather tests"
380 [ test_on_delete_cascade,
381 test_pickle_of_unpickle_is_identity,
382 test_unpickle_succeeds ]
383
384
385 -- | If we unpickle something and then pickle it, we should wind up
386 -- with the same thing we started with. WARNING: success of this
387 -- test does not mean that unpickling succeeded.
388 --
389 test_pickle_of_unpickle_is_identity :: TestTree
390 test_pickle_of_unpickle_is_identity =
391 testCase "pickle composed with unpickle is the identity" $ do
392 let path = "test/xml/weatherxml.xml"
393 (expected, actual) <- pickle_unpickle pickle_message path
394 actual @?= expected
395
396
397 -- | Make sure we can actually unpickle these things.
398 --
399 test_unpickle_succeeds :: TestTree
400 test_unpickle_succeeds =
401 testCase "unpickling succeeds" $ do
402 let path = "test/xml/weatherxml.xml"
403 actual <- unpickleable path pickle_message
404 let expected = True
405 actual @?= expected
406
407
408 -- | Make sure everything gets deleted when we delete the top-level
409 -- record.
410 --
411 test_on_delete_cascade :: TestTree
412 test_on_delete_cascade =
413 testCase "deleting weather deletes its children" $ do
414 let path = "test/xml/weatherxml.xml"
415 weather <- unsafe_unpickle path pickle_message
416 let a = undefined :: Weather
417 let b = undefined :: WeatherForecast
418 let c = undefined :: WeatherForecastListing
419 actual <- withSqliteConn ":memory:" $ runDbConn $ do
420 runMigration silentMigrationLogger $ do
421 migrate a
422 migrate b
423 migrate c
424 _ <- dbimport weather
425 deleteAll a
426 count_a <- countAll a
427 count_b <- countAll b
428 count_c <- countAll c
429 return $ count_a + count_b + count_c
430 let expected = 0
431 actual @?= expected