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 (
18 -- * WARNING: these are private but exported to silence warnings
19 WeatherConstructor(..),
20 WeatherDetailedWeatherListingItemConstructor(..),
21 WeatherForecastConstructor(..),
22 WeatherForecastListingConstructor(..) )
26 import Control.Monad ( forM_ )
27 import Data.Time ( UTCTime )
28 import Data.Tuple.Curry ( uncurryN )
29 import Database.Groundhog (
35 silentMigrationLogger )
36 import Database.Groundhog.Core ( DefaultKey )
37 import Database.Groundhog.Generic ( runDbConn )
38 import Database.Groundhog.Sqlite ( withSqliteConn )
39 import Database.Groundhog.TH (
42 import Test.Tasty ( TestTree, testGroup )
43 import Test.Tasty.HUnit ( (@?=), testCase )
44 import Text.XML.HXT.Core (
67 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
68 import TSN.Picklers ( xp_datetime, xp_gamedate, xp_time_stamp )
69 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
82 -- | The DTD to which this module corresponds. Used to invoke dbimport.
85 dtd = "weatherxml.dtd"
92 -- * WeatherForecastListing/WeatherForecastListingXml
94 -- | XML representation of a weather forecast listing.
96 data WeatherForecastListingXml =
97 WeatherForecastListingXml {
99 xml_weather :: String }
103 -- | Database representation of a weather forecast listing. The
104 -- 'db_league_name' field should come from the containing \<league\>
105 -- element which is not stored in the database.
107 data WeatherForecastListing =
108 WeatherForecastListing {
109 db_weather_forecasts_id :: DefaultKey WeatherForecast,
110 db_league_name :: Maybe String,
112 db_weather :: String }
115 -- | We don't make 'WeatherForecastListingXml' an instance of
116 -- 'FromXmlFk' because it needs some additional information, namely
117 -- the league name from its containing \<league\> element.
119 -- When supplied with a forecast id and a league name, this will
120 -- turn an XML listing into a database one.
122 from_xml_fk_league :: DefaultKey WeatherForecast
124 -> WeatherForecastListingXml
125 -> WeatherForecastListing
126 from_xml_fk_league fk ln WeatherForecastListingXml{..} =
127 WeatherForecastListing {
128 db_weather_forecasts_id = fk,
130 db_teams = xml_teams,
131 db_weather = xml_weather }
136 -- | XML representation of a league, as they appear in the weather
137 -- documents. There is no associated database representation because
138 -- the league element really adds no information besides its own
139 -- (usually empty) name. The leagues contain listings, so we
140 -- associate the league name with each listing instead.
144 league_name :: Maybe String,
145 listings :: [WeatherForecastListingXml] }
149 -- * WeatherForecast/WeatherForecastXml
151 -- | Database representation of a weather forecast.
153 data WeatherForecast =
155 db_weather_id :: DefaultKey Weather,
156 db_game_date :: UTCTime }
159 -- | XML representation of a weather forecast.
161 data WeatherForecastXml =
163 xml_game_date :: UTCTime,
164 xml_leagues :: [WeatherLeague] }
168 instance ToDb WeatherForecastXml where
169 -- | The database representation of a 'WeatherForecastXml' is a
170 -- 'WeatherForecast'.
172 type Db WeatherForecastXml = WeatherForecast
175 instance Child WeatherForecastXml where
176 -- | The database type containing a 'WeatherForecastXml' is
178 type Parent WeatherForecastXml = Weather
181 instance FromXmlFk WeatherForecastXml where
183 -- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
184 -- add the foreign key to the containing 'Weather', and copy the
187 from_xml_fk fk WeatherForecastXml{..} =
190 db_game_date = xml_game_date }
193 -- | This allows us to call 'insert_xml' on an 'WeatherForecastXml'
194 -- without first converting it to the database representation.
196 instance XmlImportFk WeatherForecastXml
198 -- * WeatherDetailedWeatherXml
200 -- | XML Representation of a \<Detailed_Weather\>, which just contains
201 -- a bunch iof \<DW_Listing\>s. There is no associated database type
202 -- since these don't really contain any information.
204 data WeatherDetailedWeatherXml =
205 WeatherDetailedWeatherXml {
206 xml_detailed_listings :: [WeatherDetailedWeatherListingXml] }
210 -- * WeatherDetailedWeatherXml
212 -- | XML Representation of a \<DW_Listing\>. The sport and sport code
213 -- come as attributes, but then these just contain a bunch of
214 -- \<Item\>s. There is no associated database type since these don't
215 -- contain much information. The sport we already know from the
216 -- \<message\>, while the sport code is ignored since it's already
217 -- present in each \<Item\>s.
219 data WeatherDetailedWeatherListingXml =
220 WeatherDetailedWeatherListingXml {
221 xml_dtl_listing_sport :: String,
222 xml_dtl_listing_sport_code :: String,
223 xml_items :: [WeatherDetailedWeatherListingItemXml] }
226 -- * WeatherDetailedWeatherListingItem / WeatherDetailedWeatherListingItemXml
228 -- | Database representation of a detailed weather item. The away/home
229 -- teams don't use the representation in "TSN.Team" because all
230 -- we're given is a name, and a team id is required for "TSN.Team".
232 -- We also drop the sport name, because it's given in the parent
235 data WeatherDetailedWeatherListingItem =
236 WeatherDetailedWeatherListingItem {
237 db_dtl_weather_id :: DefaultKey Weather, -- ^ Avoid name collision by
238 -- using \"dtl\" prefix.
239 db_sport_code :: String,
241 db_dtl_game_date :: UTCTime, -- ^ Avoid name clash with \"dtl\" prefix
242 db_away_team :: String,
243 db_home_team :: String,
244 db_weather_type :: Int,
245 db_description :: String,
246 db_temp_adjust :: String,
247 db_temperature :: Int }
250 -- | XML representation of a detailed weather item. Same as the
251 -- database representation, only without the foreign key and the
252 -- sport name that comes from the containing listing.
253 data WeatherDetailedWeatherListingItemXml =
254 WeatherDetailedWeatherListingItemXml {
255 xml_sport_code :: String,
257 xml_dtl_game_date :: UTCTime,
258 xml_away_team :: String,
259 xml_home_team :: String,
260 xml_weather_type :: Int,
261 xml_description :: String,
262 xml_temp_adjust :: String,
263 xml_temperature :: Int }
267 instance ToDb WeatherDetailedWeatherListingItemXml where
268 -- | Our database analogue is a 'WeatherDetailedWeatherListingItem'.
269 type Db WeatherDetailedWeatherListingItemXml =
270 WeatherDetailedWeatherListingItem
272 instance Child WeatherDetailedWeatherListingItemXml where
273 -- | We skip two levels of containers and say that the items belong
274 -- to the top-level 'Weather'.
275 type Parent WeatherDetailedWeatherListingItemXml = Weather
277 instance FromXmlFk WeatherDetailedWeatherListingItemXml where
278 -- | To convert from the XML to database representation, we simply
279 -- add the foreign key (to Weather) and copy the rest of the fields.
280 from_xml_fk fk WeatherDetailedWeatherListingItemXml{..} =
281 WeatherDetailedWeatherListingItem {
282 db_dtl_weather_id = fk,
283 db_sport_code = xml_sport_code,
284 db_game_id = xml_game_id,
285 db_dtl_game_date = xml_dtl_game_date,
286 db_away_team = xml_away_team,
287 db_home_team = xml_home_team,
288 db_weather_type = xml_weather_type,
289 db_description = xml_description,
290 db_temp_adjust = xml_temp_adjust,
291 db_temperature = xml_temperature }
293 -- | This allows us to insert the XML representation directly without
294 -- having to do the manual XML -\> DB conversion.
296 instance XmlImportFk WeatherDetailedWeatherListingItemXml
300 -- | The database representation of a weather message. We don't
301 -- contain the forecasts or the detailed weather since those are
302 -- foreigned-keyed to us.
306 db_xml_file_id :: Int,
309 db_time_stamp :: UTCTime }
312 -- | The XML representation of a weather message.
316 xml_xml_file_id :: Int,
317 xml_heading :: String,
318 xml_category :: String,
321 xml_forecasts :: [WeatherForecastXml],
322 xml_detailed_weather :: Maybe WeatherDetailedWeatherXml,
323 xml_time_stamp :: UTCTime }
326 instance ToDb Message where
327 -- | The database representation of 'Message' is 'Weather'.
329 type Db Message = Weather
331 instance FromXml Message where
332 -- | To get a 'Weather' from a 'Message', we drop a bunch of
335 from_xml Message{..} =
337 db_xml_file_id = xml_xml_file_id,
338 db_sport = xml_sport,
339 db_title = xml_title,
340 db_time_stamp = xml_time_stamp }
342 -- | This allows us to insert the XML representation 'Message'
345 instance XmlImport Message
352 mkPersist tsn_codegen_config [groundhog|
357 - name: unique_weather
359 # Prevent multiple imports of the same message.
360 fields: [db_xml_file_id]
362 - entity: WeatherForecast
363 dbName: weather_forecasts
365 - name: WeatherForecast
367 - name: db_weather_id
371 - entity: WeatherForecastListing
372 dbName: weather_forecast_listings
374 - name: WeatherForecastListing
376 - name: db_weather_forecasts_id
380 # We rename the two fields that needed a "dtl" prefix to avoid a name clash.
381 - entity: WeatherDetailedWeatherListingItem
382 dbName: weather_detailed_items
384 - name: WeatherDetailedWeatherListingItem
386 - name: db_dtl_weather_id
390 - name: db_dtl_game_date
397 -- | There are two different types of documents that claim to be
398 -- \"weatherxml.dtd\". The first, more common type has listings
399 -- within forecasts. The second type has forecasts within
400 -- listings. Clearly we can't parse both of these using the same
403 -- For now we're simply punting on the issue and refusing to parse
404 -- the second type. This will check the given @xmltree@ to see if
405 -- there are any forecasts contained within listings. If there are,
406 -- then it's the second type that we don't know what to do with.
408 is_type1 :: XmlTree -> Bool
414 parse :: XmlTree -> [XmlTree]
415 parse = runLA $ hasName "/"
418 /> hasName "forecast"
420 elements = parse xmltree
423 instance DbImport Message where
426 migrate (undefined :: Weather)
427 migrate (undefined :: WeatherForecast)
428 migrate (undefined :: WeatherForecastListing)
429 migrate (undefined :: WeatherDetailedWeatherListingItem)
432 -- First we insert the top-level weather record.
433 weather_id <- insert_xml m
435 -- Next insert all of the forecasts, one at a time.
436 forM_ (xml_forecasts m) $ \forecast -> do
437 forecast_id <- insert_xml_fk weather_id forecast
439 -- With the forecast id in hand, loop through this forecast's
441 forM_ (xml_leagues forecast) $ \league -> do
442 -- Construct the function that converts an XML listing to a
444 let todb = from_xml_fk_league forecast_id (league_name league)
446 -- Now use it to convert all of the XML listings.
447 let db_listings = map todb (listings league)
449 -- And finally, insert those DB listings.
450 mapM_ insert_ db_listings
452 return ImportSucceeded
459 -- | Pickler to convert a 'WeatherForecastListingXml' to/from XML.
461 pickle_listing :: PU WeatherForecastListingXml
464 xpWrap (from_pair, to_pair) $
466 (xpElem "teams" xpText)
467 (xpElem "weather" xpText)
469 from_pair = uncurry WeatherForecastListingXml
470 to_pair WeatherForecastListingXml{..} = (xml_teams, xml_weather)
473 -- | Pickler to convert a 'WeatherLeague' to/from XML.
475 pickle_league :: PU WeatherLeague
478 xpWrap (from_pair, to_pair) $
480 (xpAttr "name" $ xpOption xpText)
481 (xpList pickle_listing)
483 from_pair = uncurry WeatherLeague
484 to_pair WeatherLeague{..} = (league_name, listings)
487 -- | Pickler to convert a 'WeatherForecastXml' to/from XML.
489 pickle_forecast :: PU WeatherForecastXml
492 xpWrap (from_pair, to_pair) $
494 (xpAttr "gamedate" xp_gamedate)
495 (xpList pickle_league)
497 from_pair = uncurry WeatherForecastXml
498 to_pair WeatherForecastXml{..} = (xml_game_date,
503 -- | (Un)pickle a 'WeatherDetailedWeatherListingItemXml'.
505 pickle_item :: PU WeatherDetailedWeatherListingItemXml
508 xpWrap (from_tuple, to_tuple) $
509 xp9Tuple (xpElem "Sportcode" xpText)
510 (xpElem "GameID" xpInt)
511 (xpElem "Gamedate" xp_datetime)
512 (xpElem "AwayTeam" xpText)
513 (xpElem "HomeTeam" xpText)
514 (xpElem "WeatherType" xpInt)
515 (xpElem "Description" xpText)
516 (xpElem "TempAdjust" xpText)
517 (xpElem "Temperature" xpInt)
519 from_tuple = uncurryN WeatherDetailedWeatherListingItemXml
520 to_tuple w = (xml_sport_code w,
531 -- | (Un)pickle a 'WeatherDetailedWeatherListingXml'.
533 pickle_dw_listing :: PU WeatherDetailedWeatherListingXml
535 xpElem "DW_Listing" $
536 xpWrap (from_tuple, to_tuple) $
537 xpTriple (xpAttr "SportCode" xpText)
538 (xpAttr "Sport" xpText)
541 from_tuple = uncurryN WeatherDetailedWeatherListingXml
542 to_tuple w = (xml_dtl_listing_sport w,
543 xml_dtl_listing_sport_code w,
547 -- | (Un)pickle a 'WeatherDetailedWeatherXml'
549 pickle_detailed_weather :: PU WeatherDetailedWeatherXml
550 pickle_detailed_weather =
551 xpElem "Detailed_Weather" $
552 xpWrap (WeatherDetailedWeatherXml, xml_detailed_listings)
553 (xpList pickle_dw_listing)
556 -- | Pickler to convert a 'Message' to/from XML.
558 pickle_message :: PU Message
561 xpWrap (from_tuple, to_tuple) $
563 (xpElem "XML_File_ID" xpInt)
564 (xpElem "heading" xpText)
565 (xpElem "category" xpText)
566 (xpElem "sport" xpText)
567 (xpElem "title" xpText)
568 (xpList pickle_forecast)
569 (xpOption pickle_detailed_weather)
570 (xpElem "time_stamp" xp_time_stamp)
572 from_tuple = uncurryN Message
573 to_tuple Message{..} = (xml_xml_file_id,
579 xml_detailed_weather,
586 weather_tests :: TestTree
590 [ test_on_delete_cascade,
591 test_pickle_of_unpickle_is_identity,
592 test_unpickle_succeeds,
593 test_types_detected_correctly ]
596 -- | If we unpickle something and then pickle it, we should wind up
597 -- with the same thing we started with. WARNING: success of this
598 -- test does not mean that unpickling succeeded.
600 test_pickle_of_unpickle_is_identity :: TestTree
601 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
602 [ check "pickle composed with unpickle is the identity"
603 "test/xml/weatherxml.xml",
605 check "pickle composed with unpickle is the identity (detailed)"
606 "test/xml/weatherxml-detailed.xml" ]
608 check desc path = testCase desc $ do
609 (expected, actual) <- pickle_unpickle pickle_message path
613 -- | Make sure we can actually unpickle these things.
615 test_unpickle_succeeds :: TestTree
616 test_unpickle_succeeds = testGroup "unpickle tests"
617 [ check "unpickling succeeds"
618 "test/xml/weatherxml.xml",
619 check "unpickling succeeds (detailed)"
620 "test/xml/weatherxml-detailed.xml" ]
622 check desc path = testCase desc $ do
623 actual <- unpickleable path pickle_message
628 -- | Make sure everything gets deleted when we delete the top-level
631 test_on_delete_cascade :: TestTree
632 test_on_delete_cascade = testGroup "cascading delete tests"
633 [ check "deleting weather deletes its children"
634 "test/xml/weatherxml.xml",
635 check "deleting weather deletes its children (detailed)"
636 "test/xml/weatherxml-detailed.xml" ]
638 check desc path = testCase desc $ do
639 weather <- unsafe_unpickle path pickle_message
640 let a = undefined :: Weather
641 let b = undefined :: WeatherForecast
642 let c = undefined :: WeatherForecastListing
643 let d = undefined :: WeatherDetailedWeatherListingItem
644 actual <- withSqliteConn ":memory:" $ runDbConn $ do
645 runMigration silentMigrationLogger $ do
650 _ <- dbimport weather
652 count_a <- countAll a
653 count_b <- countAll b
654 count_c <- countAll c
655 count_d <- countAll d
656 return $ count_a + count_b + count_c + count_d
661 test_types_detected_correctly :: TestTree
662 test_types_detected_correctly =
663 testGroup "weatherxml types detected correctly" $
664 [ check "test/xml/weatherxml.xml"
665 "first type detected correctly"
667 check "test/xml/weatherxml-detailed.xml"
668 "first type detected correctly (detailed)"
670 check "test/xml/weatherxml-type2.xml"
671 "second type detected correctly"
674 unsafe_get_xmltree :: String -> IO XmlTree
675 unsafe_get_xmltree path =
676 fmap head $ runX $ readDocument parse_opts path
678 check path desc expected = testCase desc $ do
679 xmltree <- unsafe_get_xmltree path
680 let actual = is_type1 xmltree