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