1 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE QuasiQuotes #-}
4 {-# LANGUAGE RecordWildCards #-}
5 {-# LANGUAGE TemplateHaskell #-}
6 {-# LANGUAGE TypeFamilies #-}
8 -- | Parse TSN XML for the DTD \"weatherxml.dtd\". Each document
9 -- contains a bunch of forecasts, which each contain zero or more
10 -- leagues, which in turn (each) contain a bunch of listings.
12 module TSN.XML.Weather (
17 -- * WARNING: these are private but exported to silence warnings
18 WeatherConstructor(..),
19 WeatherDetailedWeatherListingItemConstructor(..),
20 WeatherForecastConstructor(..),
21 WeatherForecastListingConstructor(..) )
25 import Control.Monad ( forM_ )
26 import Data.Time ( UTCTime )
27 import Data.Tuple.Curry ( uncurryN )
28 import Database.Groundhog (
34 silentMigrationLogger )
35 import Database.Groundhog.Core ( DefaultKey )
36 import Database.Groundhog.Generic ( runDbConn )
37 import Database.Groundhog.Sqlite ( withSqliteConn )
38 import Database.Groundhog.TH (
41 import Test.Tasty ( TestTree, testGroup )
42 import Test.Tasty.HUnit ( (@?=), testCase )
43 import Text.XML.HXT.Core (
60 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
61 import TSN.Picklers ( xp_datetime, xp_gamedate, xp_time_stamp )
62 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
74 -- | The DTD to which this module corresponds. Used to invoke dbimport.
77 dtd = "weatherxml.dtd"
84 -- * WeatherForecastListing/WeatherForecastListingXml
86 -- | XML representation of a weather forecast listing.
88 data WeatherForecastListingXml =
89 WeatherForecastListingXml {
91 xml_weather :: String }
95 -- | Database representation of a weather forecast listing. The
96 -- 'db_league_name' field should come from the containing \<league\>
97 -- element which is not stored in the database.
99 data WeatherForecastListing =
100 WeatherForecastListing {
101 db_weather_forecasts_id :: DefaultKey WeatherForecast,
102 db_league_name :: Maybe String,
104 db_weather :: String }
107 -- | We don't make 'WeatherForecastListingXml' an instance of
108 -- 'FromXmlFk' because it needs some additional information, namely
109 -- the league name from its containing \<league\> element.
111 -- When supplied with a forecast id and a league name, this will
112 -- turn an XML listing into a database one.
114 from_xml_fk_league :: DefaultKey WeatherForecast
116 -> WeatherForecastListingXml
117 -> WeatherForecastListing
118 from_xml_fk_league fk ln WeatherForecastListingXml{..} =
119 WeatherForecastListing {
120 db_weather_forecasts_id = fk,
122 db_teams = xml_teams,
123 db_weather = xml_weather }
128 -- | XML representation of a league, as they appear in the weather
129 -- documents. There is no associated database representation because
130 -- the league element really adds no information besides its own
131 -- (usually empty) name. The leagues contain listings, so we
132 -- associate the league name with each listing instead.
136 league_name :: Maybe String,
137 listings :: [WeatherForecastListingXml] }
141 -- * WeatherForecast/WeatherForecastXml
143 -- | Database representation of a weather forecast.
145 data WeatherForecast =
147 db_weather_id :: DefaultKey Weather,
148 db_game_date :: UTCTime }
151 -- | XML representation of a weather forecast.
153 data WeatherForecastXml =
155 xml_game_date :: UTCTime,
156 xml_leagues :: [WeatherLeague] }
160 instance ToDb WeatherForecastXml where
161 -- | The database representation of a 'WeatherForecastXml' is a
162 -- 'WeatherForecast'.
164 type Db WeatherForecastXml = WeatherForecast
167 instance Child WeatherForecastXml where
168 -- | The database type containing a 'WeatherForecastXml' is
170 type Parent WeatherForecastXml = Weather
173 instance FromXmlFk WeatherForecastXml where
175 -- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
176 -- just copy everything verbatim.
178 from_xml_fk fk WeatherForecastXml{..} =
181 db_game_date = xml_game_date }
184 -- | This allows us to call 'insert_xml' on an 'WeatherForecastXml'
185 -- without first converting it to the database representation.
187 instance XmlImportFk WeatherForecastXml
189 -- * WeatherDetailedWeatherXml
191 -- | XML Representation of a \<Detailed_Weather\>, which just contains
192 -- a bunch iof \<DW_Listing\>s. There is no associated database type
193 -- since these don't really contain any information.
195 data WeatherDetailedWeatherXml =
196 WeatherDetailedWeatherXml {
197 xml_detailed_listings :: [WeatherDetailedWeatherListingXml] }
201 -- * WeatherDetailedWeatherXml
203 -- | XML Representation of a \<DW_Listing\>. The sport and sport code
204 -- come as attributes, but then these just contain a bunch of
205 -- \<Item\>s. There is no associated database type since these don't
206 -- contain much information. The sport we already know from the
207 -- \<message\>, while the sport code is ignored since it's already
208 -- present in each \<Item\>s.
210 data WeatherDetailedWeatherListingXml =
211 WeatherDetailedWeatherListingXml {
212 xml_dtl_listing_sport :: String,
213 xml_dtl_listing_sport_code :: String,
214 xml_items :: [WeatherDetailedWeatherListingItemXml] }
217 -- * WeatherDetailedWeatherListingItem / WeatherDetailedWeatherListingItemXml
219 -- | Database representation of a detailed weather item. The away/home
220 -- teams don't use the representation in "TSN.Team" because all
221 -- we're given is a name, and a team id is required for "TSN.Team".
223 -- We also drop the sport name, because it's given in the parent
226 data WeatherDetailedWeatherListingItem =
227 WeatherDetailedWeatherListingItem {
228 db_dtl_weather_id :: DefaultKey Weather, -- ^ Avoid name collision by
229 -- using \"dtl\" prefix.
230 db_sport_code :: String,
232 db_dtl_game_date :: UTCTime, -- ^ Avoid name clash with \"dtl\" prefix
233 db_away_team :: String,
234 db_home_team :: String,
235 db_weather_type :: Int,
236 db_description :: String,
237 db_temp_adjust :: String,
238 db_temperature :: Int }
241 -- | XML representation of a detailed weather item. Same as the
242 -- database representation, only without the foreign key and the
243 -- sport name that comes from the containing listing.
244 data WeatherDetailedWeatherListingItemXml =
245 WeatherDetailedWeatherListingItemXml {
246 xml_sport_code :: String,
248 xml_dtl_game_date :: UTCTime,
249 xml_away_team :: String,
250 xml_home_team :: String,
251 xml_weather_type :: Int,
252 xml_description :: String,
253 xml_temp_adjust :: String,
254 xml_temperature :: Int }
258 instance ToDb WeatherDetailedWeatherListingItemXml where
259 -- | Our database analogue is a 'WeatherDetailedWeatherListingItem'.
260 type Db WeatherDetailedWeatherListingItemXml =
261 WeatherDetailedWeatherListingItem
263 instance Child WeatherDetailedWeatherListingItemXml where
264 -- | We skip two levels of containers and say that the items belong
265 -- to the top-level 'Weather'.
266 type Parent WeatherDetailedWeatherListingItemXml = Weather
268 instance FromXmlFk WeatherDetailedWeatherListingItemXml where
269 -- | To convert from the XML to database representation, we simply
270 -- add the foreign key (to Weather) and copy the rest of the fields.
271 from_xml_fk fk WeatherDetailedWeatherListingItemXml{..} =
272 WeatherDetailedWeatherListingItem {
273 db_dtl_weather_id = fk,
274 db_sport_code = xml_sport_code,
275 db_game_id = xml_game_id,
276 db_dtl_game_date = xml_dtl_game_date,
277 db_away_team = xml_away_team,
278 db_home_team = xml_home_team,
279 db_weather_type = xml_weather_type,
280 db_description = xml_description,
281 db_temp_adjust = xml_temp_adjust,
282 db_temperature = xml_temperature }
284 -- | This allows us to insert the XML representation directly without
285 -- having to do the manual XML -\> DB conversion.
287 instance XmlImportFk WeatherDetailedWeatherListingItemXml
291 -- | The database representation of a weather message. We don't
292 -- contain the forecasts or the detailed weather since those are
293 -- foreigned-keyed to us.
297 db_xml_file_id :: Int,
300 db_time_stamp :: UTCTime }
303 -- | The XML representation of a weather message.
307 xml_xml_file_id :: Int,
308 xml_heading :: String,
309 xml_category :: String,
312 xml_forecasts :: [WeatherForecastXml],
313 xml_detailed_weather :: Maybe WeatherDetailedWeatherXml,
314 xml_time_stamp :: UTCTime }
317 instance ToDb Message where
318 -- | The database representation of 'Message' is 'Weather'.
320 type Db Message = Weather
322 instance FromXml Message where
323 -- | To get a 'Weather' from a 'Message', we drop a bunch of
326 from_xml Message{..} =
328 db_xml_file_id = xml_xml_file_id,
329 db_sport = xml_sport,
330 db_title = xml_title,
331 db_time_stamp = xml_time_stamp }
333 -- | This allows us to insert the XML representation 'Message'
336 instance XmlImport Message
343 mkPersist tsn_codegen_config [groundhog|
348 - name: unique_weather
350 # Prevent multiple imports of the same message.
351 fields: [db_xml_file_id]
353 - entity: WeatherForecast
354 dbName: weather_forecasts
356 - name: WeatherForecast
358 - name: db_weather_id
362 - entity: WeatherForecastListing
363 dbName: weather_forecast_listings
365 - name: WeatherForecastListing
367 - name: db_weather_forecasts_id
371 # We rename the two fields that needed a "dtl" prefix to avoid a name clash.
372 - entity: WeatherDetailedWeatherListingItem
373 dbName: weather_detailed_items
375 - name: WeatherDetailedWeatherListingItem
377 - name: db_dtl_weather_id
381 - name: db_dtl_game_date
387 instance DbImport Message where
390 migrate (undefined :: Weather)
391 migrate (undefined :: WeatherForecast)
392 migrate (undefined :: WeatherForecastListing)
393 migrate (undefined :: WeatherDetailedWeatherListingItem)
396 -- First we insert the top-level weather record.
397 weather_id <- insert_xml m
399 -- Next insert all of the forecasts, one at a time.
400 forM_ (xml_forecasts m) $ \forecast -> do
401 forecast_id <- insert_xml_fk weather_id forecast
403 -- With the forecast id in hand, loop through this forecast's
405 forM_ (xml_leagues forecast) $ \league -> do
406 -- Construct the function that converts an XML listing to a
408 let todb = from_xml_fk_league forecast_id (league_name league)
410 -- Now use it to convert all of the XML listings.
411 let db_listings = map todb (listings league)
413 -- And finally, insert those DB listings.
414 mapM_ insert_ db_listings
416 return ImportSucceeded
423 -- | Pickler to convert a 'WeatherForecastListingXml' to/from XML.
425 pickle_listing :: PU WeatherForecastListingXml
428 xpWrap (from_pair, to_pair) $
430 (xpElem "teams" xpText)
431 (xpElem "weather" xpText)
433 from_pair = uncurry WeatherForecastListingXml
434 to_pair WeatherForecastListingXml{..} = (xml_teams, xml_weather)
437 -- | Pickler to convert a 'WeatherLeague' to/from XML.
439 pickle_league :: PU WeatherLeague
442 xpWrap (from_pair, to_pair) $
444 (xpAttr "name" $ xpOption xpText)
445 (xpList pickle_listing)
447 from_pair = uncurry WeatherLeague
448 to_pair WeatherLeague{..} = (league_name, listings)
451 -- | Pickler to convert a 'WeatherForecastXml' to/from XML.
453 pickle_forecast :: PU WeatherForecastXml
456 xpWrap (from_pair, to_pair) $
458 (xpAttr "gamedate" xp_gamedate)
459 (xpList pickle_league)
461 from_pair = uncurry WeatherForecastXml
462 to_pair WeatherForecastXml{..} = (xml_game_date,
467 -- | (Un)pickle a 'WeatherDetailedWeatherListingItemXml'.
469 pickle_item :: PU WeatherDetailedWeatherListingItemXml
472 xpWrap (from_tuple, to_tuple) $
473 xp9Tuple (xpElem "Sportcode" xpText)
474 (xpElem "GameID" xpInt)
475 (xpElem "Gamedate" xp_datetime)
476 (xpElem "AwayTeam" xpText)
477 (xpElem "HomeTeam" xpText)
478 (xpElem "WeatherType" xpInt)
479 (xpElem "Description" xpText)
480 (xpElem "TempAdjust" xpText)
481 (xpElem "Temperature" xpInt)
483 from_tuple = uncurryN WeatherDetailedWeatherListingItemXml
484 to_tuple w = (xml_sport_code w,
495 -- | (Un)pickle a 'WeatherDetailedWeatherListingXml'.
497 pickle_dw_listing :: PU WeatherDetailedWeatherListingXml
499 xpElem "DW_Listing" $
500 xpWrap (from_tuple, to_tuple) $
501 xpTriple (xpAttr "SportCode" xpText)
502 (xpAttr "Sport" xpText)
505 from_tuple = uncurryN WeatherDetailedWeatherListingXml
506 to_tuple w = (xml_dtl_listing_sport w,
507 xml_dtl_listing_sport_code w,
511 -- | (Un)pickle a 'WeatherDetailedWeatherXml'
513 pickle_detailed_weather :: PU WeatherDetailedWeatherXml
514 pickle_detailed_weather =
515 xpElem "Detailed_Weather" $
516 xpWrap (WeatherDetailedWeatherXml, xml_detailed_listings)
517 (xpList pickle_dw_listing)
520 -- | Pickler to convert a 'Message' to/from XML.
522 pickle_message :: PU Message
525 xpWrap (from_tuple, to_tuple) $
527 (xpElem "XML_File_ID" xpInt)
528 (xpElem "heading" xpText)
529 (xpElem "category" xpText)
530 (xpElem "sport" xpText)
531 (xpElem "title" xpText)
532 (xpList pickle_forecast)
533 (xpOption pickle_detailed_weather)
534 (xpElem "time_stamp" xp_time_stamp)
536 from_tuple = uncurryN Message
537 to_tuple Message{..} = (xml_xml_file_id,
543 xml_detailed_weather,
550 weather_tests :: TestTree
554 [ test_on_delete_cascade,
555 test_pickle_of_unpickle_is_identity,
556 test_unpickle_succeeds ]
559 -- | If we unpickle something and then pickle it, we should wind up
560 -- with the same thing we started with. WARNING: success of this
561 -- test does not mean that unpickling succeeded.
563 test_pickle_of_unpickle_is_identity :: TestTree
564 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
565 [ check "pickle composed with unpickle is the identity"
566 "test/xml/weatherxml.xml",
568 check "pickle composed with unpickle is the identity (detailed)"
569 "test/xml/weatherxml-detailed.xml" ]
571 check desc path = testCase desc $ do
572 (expected, actual) <- pickle_unpickle pickle_message path
576 -- | Make sure we can actually unpickle these things.
578 test_unpickle_succeeds :: TestTree
579 test_unpickle_succeeds = testGroup "unpickle tests"
580 [ check "unpickling succeeds"
581 "test/xml/weatherxml.xml",
582 check "unpickling succeeds (detailed)"
583 "test/xml/weatherxml-detailed.xml" ]
585 check desc path = testCase desc $ do
586 actual <- unpickleable path pickle_message
591 -- | Make sure everything gets deleted when we delete the top-level
594 test_on_delete_cascade :: TestTree
595 test_on_delete_cascade = testGroup "cascading delete tests"
596 [ check "deleting weather deletes its children"
597 "test/xml/weatherxml.xml",
598 check "deleting weather deletes its children (detailed)"
599 "test/xml/weatherxml-detailed.xml" ]
601 check desc path = testCase desc $ do
602 weather <- unsafe_unpickle path pickle_message
603 let a = undefined :: Weather
604 let b = undefined :: WeatherForecast
605 let c = undefined :: WeatherForecastListing
606 let d = undefined :: WeatherDetailedWeatherListingItem
607 actual <- withSqliteConn ":memory:" $ runDbConn $ do
608 runMigration silentMigrationLogger $ do
613 _ <- dbimport weather
615 count_a <- countAll a
616 count_b <- countAll b
617 count_c <- countAll c
618 count_d <- countAll d
619 return $ count_a + count_b + count_c + count_d