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 (
19 -- * WARNING: these are private but exported to silence warnings
20 WeatherConstructor(..),
21 WeatherDetailedWeatherListingItemConstructor(..),
22 WeatherForecastConstructor(..),
23 WeatherForecastListingConstructor(..) )
27 import Control.Monad ( forM_ )
28 import Data.Time ( UTCTime )
29 import Data.Tuple.Curry ( uncurryN )
30 import Database.Groundhog (
36 silentMigrationLogger )
37 import Database.Groundhog.Core ( DefaultKey )
38 import Database.Groundhog.Generic ( runDbConn )
39 import Database.Groundhog.Sqlite ( withSqliteConn )
40 import Database.Groundhog.TH (
43 import Test.Tasty ( TestTree, testGroup )
44 import Test.Tasty.HUnit ( (@?=), testCase )
45 import Text.XML.HXT.Core (
72 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
73 import TSN.Picklers ( xp_datetime, xp_gamedate, xp_time_stamp )
74 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
87 -- | The DTD to which this module corresponds. Used to invoke dbimport.
90 dtd = "weatherxml.dtd"
97 -- * WeatherForecastListing/WeatherForecastListingXml
99 -- | XML representation of a weather forecast listing.
101 data WeatherForecastListingXml =
102 WeatherForecastListingXml {
104 xml_weather :: Maybe String }
108 -- | Database representation of a weather forecast listing. The
109 -- 'db_league_name' field should come from the containing \<league\>
110 -- element which is not stored in the database.
112 data WeatherForecastListing =
113 WeatherForecastListing {
114 db_weather_forecasts_id :: DefaultKey WeatherForecast,
115 db_league_name :: Maybe String,
117 db_weather :: Maybe String }
120 -- | We don't make 'WeatherForecastListingXml' an instance of
121 -- 'FromXmlFk' because it needs some additional information, namely
122 -- the league name from its containing \<league\> element.
124 -- When supplied with a forecast id and a league name, this will
125 -- turn an XML listing into a database one.
127 from_xml_fk_league :: DefaultKey WeatherForecast
129 -> WeatherForecastListingXml
130 -> WeatherForecastListing
131 from_xml_fk_league fk ln WeatherForecastListingXml{..} =
132 WeatherForecastListing {
133 db_weather_forecasts_id = fk,
135 db_teams = xml_teams,
136 db_weather = xml_weather }
141 -- | XML representation of a league, as they appear in the weather
142 -- documents. There is no associated database representation because
143 -- the league element really adds no information besides its own
144 -- (usually empty) name. The leagues contain listings, so we
145 -- associate the league name with each listing instead.
149 league_name :: Maybe String,
150 listings :: [WeatherForecastListingXml] }
154 -- * WeatherForecast/WeatherForecastXml
156 -- | Database representation of a weather forecast.
158 data WeatherForecast =
160 db_weather_id :: DefaultKey Weather,
161 db_game_date :: UTCTime }
164 -- | XML representation of a weather forecast.
166 data WeatherForecastXml =
168 xml_game_date :: UTCTime,
169 xml_leagues :: [WeatherLeague] }
173 instance ToDb WeatherForecastXml where
174 -- | The database representation of a 'WeatherForecastXml' is a
175 -- 'WeatherForecast'.
177 type Db WeatherForecastXml = WeatherForecast
180 instance Child WeatherForecastXml where
181 -- | The database type containing a 'WeatherForecastXml' is
183 type Parent WeatherForecastXml = Weather
186 instance FromXmlFk WeatherForecastXml where
188 -- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
189 -- add the foreign key to the containing 'Weather', and copy the
192 from_xml_fk fk WeatherForecastXml{..} =
195 db_game_date = xml_game_date }
198 -- | This allows us to call 'insert_xml' on an 'WeatherForecastXml'
199 -- without first converting it to the database representation.
201 instance XmlImportFk WeatherForecastXml
203 -- * WeatherDetailedWeatherXml
205 -- | XML Representation of a \<Detailed_Weather\>, which just contains
206 -- a bunch iof \<DW_Listing\>s. There is no associated database type
207 -- since these don't really contain any information.
209 data WeatherDetailedWeatherXml =
210 WeatherDetailedWeatherXml {
211 xml_detailed_listings :: [WeatherDetailedWeatherListingXml] }
215 -- * WeatherDetailedWeatherXml
217 -- | XML Representation of a \<DW_Listing\>. The sport and sport code
218 -- come as attributes, but then these just contain a bunch of
219 -- \<Item\>s. There is no associated database type since these don't
220 -- contain much information. The sport we already know from the
221 -- \<message\>, while the sport code is ignored since it's already
222 -- present in each \<Item\>s.
224 data WeatherDetailedWeatherListingXml =
225 WeatherDetailedWeatherListingXml {
226 xml_dtl_listing_sport :: String,
227 xml_dtl_listing_sport_code :: String,
228 xml_items :: [WeatherDetailedWeatherListingItemXml] }
231 -- * WeatherDetailedWeatherListingItem / WeatherDetailedWeatherListingItemXml
233 -- | Database representation of a detailed weather item. The away/home
234 -- teams don't use the representation in "TSN.Team" because all
235 -- we're given is a name, and a team id is required for "TSN.Team".
237 -- We also drop the sport name, because it's given in the parent
240 data WeatherDetailedWeatherListingItem =
241 WeatherDetailedWeatherListingItem {
242 db_dtl_weather_id :: DefaultKey Weather, -- ^ Avoid name collision by
243 -- using \"dtl\" prefix.
244 db_sport_code :: String,
246 db_dtl_game_date :: UTCTime, -- ^ Avoid name clash with \"dtl\" prefix
247 db_away_team :: String,
248 db_home_team :: String,
249 db_weather_type :: Int,
250 db_description :: Maybe String,
251 db_temp_adjust :: Maybe String,
252 db_temperature :: Int }
255 -- | XML representation of a detailed weather item. Same as the
256 -- database representation, only without the foreign key and the
257 -- sport name that comes from the containing listing.
258 data WeatherDetailedWeatherListingItemXml =
259 WeatherDetailedWeatherListingItemXml {
260 xml_sport_code :: String,
262 xml_dtl_game_date :: UTCTime,
263 xml_away_team :: String,
264 xml_home_team :: String,
265 xml_weather_type :: Int,
266 xml_description :: Maybe String,
267 xml_temp_adjust :: Maybe String,
268 xml_temperature :: Int }
272 instance ToDb WeatherDetailedWeatherListingItemXml where
273 -- | Our database analogue is a 'WeatherDetailedWeatherListingItem'.
274 type Db WeatherDetailedWeatherListingItemXml =
275 WeatherDetailedWeatherListingItem
277 instance Child WeatherDetailedWeatherListingItemXml where
278 -- | We skip two levels of containers and say that the items belong
279 -- to the top-level 'Weather'.
280 type Parent WeatherDetailedWeatherListingItemXml = Weather
282 instance FromXmlFk WeatherDetailedWeatherListingItemXml where
283 -- | To convert from the XML to database representation, we simply
284 -- add the foreign key (to Weather) and copy the rest of the fields.
285 from_xml_fk fk WeatherDetailedWeatherListingItemXml{..} =
286 WeatherDetailedWeatherListingItem {
287 db_dtl_weather_id = fk,
288 db_sport_code = xml_sport_code,
289 db_game_id = xml_game_id,
290 db_dtl_game_date = xml_dtl_game_date,
291 db_away_team = xml_away_team,
292 db_home_team = xml_home_team,
293 db_weather_type = xml_weather_type,
294 db_description = xml_description,
295 db_temp_adjust = xml_temp_adjust,
296 db_temperature = xml_temperature }
298 -- | This allows us to insert the XML representation directly without
299 -- having to do the manual XML -\> DB conversion.
301 instance XmlImportFk WeatherDetailedWeatherListingItemXml
305 -- | The database representation of a weather message. We don't
306 -- contain the forecasts or the detailed weather since those are
307 -- foreigned-keyed to us.
311 db_xml_file_id :: Int,
314 db_time_stamp :: UTCTime }
317 -- | The XML representation of a weather message.
321 xml_xml_file_id :: Int,
322 xml_heading :: String,
323 xml_category :: String,
326 xml_forecasts :: [WeatherForecastXml],
327 xml_detailed_weather :: Maybe WeatherDetailedWeatherXml,
328 xml_time_stamp :: UTCTime }
331 instance ToDb Message where
332 -- | The database representation of 'Message' is 'Weather'.
334 type Db Message = Weather
336 instance FromXml Message where
337 -- | To get a 'Weather' from a 'Message', we drop a bunch of
340 from_xml Message{..} =
342 db_xml_file_id = xml_xml_file_id,
343 db_sport = xml_sport,
344 db_title = xml_title,
345 db_time_stamp = xml_time_stamp }
347 -- | This allows us to insert the XML representation 'Message'
350 instance XmlImport Message
357 mkPersist tsn_codegen_config [groundhog|
362 - name: unique_weather
364 # Prevent multiple imports of the same message.
365 fields: [db_xml_file_id]
367 - entity: WeatherForecast
368 dbName: weather_forecasts
370 - name: WeatherForecast
372 - name: db_weather_id
376 - entity: WeatherForecastListing
377 dbName: weather_forecast_listings
379 - name: WeatherForecastListing
381 - name: db_weather_forecasts_id
385 # We rename the two fields that needed a "dtl" prefix to avoid a name
387 - entity: WeatherDetailedWeatherListingItem
388 dbName: weather_detailed_items
390 - name: WeatherDetailedWeatherListingItem
392 - name: db_dtl_weather_id
396 - name: db_dtl_game_date
403 -- | There are two different types of documents that claim to be
404 -- \"weatherxml.dtd\". The first, more common type has listings
405 -- within forecasts. The second type has forecasts within
406 -- listings. Clearly we can't parse both of these using the same
409 -- For now we're simply punting on the issue and refusing to parse
410 -- the second type. This will check the given @xmltree@ to see if
411 -- there are any forecasts contained within listings. If there are,
412 -- then it's the second type that we don't know what to do with.
414 is_type1 :: XmlTree -> Bool
420 parse :: XmlTree -> [XmlTree]
421 parse = runLA $ hasName "/"
424 /> hasName "forecast"
426 elements = parse xmltree
429 -- | Some weatherxml documents even have the Home/Away teams in the
430 -- wrong order. We can't parse that! This next bit of voodoo detects
431 -- whether or not there are any \<HomeTeam\> elements that are
432 -- directly followed by sibling \<AwayTeam\> elements. This is the
433 -- opposite of the usual order.
435 teams_are_normal :: XmlTree -> Bool
436 teams_are_normal xmltree =
441 parse :: XmlTree -> [XmlTree]
442 parse = runLA $ hasName "/"
444 /> hasName "Detailed_Weather"
445 /> hasName "DW_Listing"
449 >>> filterAxis (hasName "HomeTeam")
450 >>> followingSiblingAxis
452 >>> hasName "AwayTeam"
454 elements = parse xmltree
457 instance DbImport Message where
460 migrate (undefined :: Weather)
461 migrate (undefined :: WeatherForecast)
462 migrate (undefined :: WeatherForecastListing)
463 migrate (undefined :: WeatherDetailedWeatherListingItem)
466 -- First we insert the top-level weather record.
467 weather_id <- insert_xml m
469 -- Next insert all of the forecasts, one at a time.
470 forM_ (xml_forecasts m) $ \forecast -> do
471 forecast_id <- insert_xml_fk weather_id forecast
473 -- With the forecast id in hand, loop through this forecast's
475 forM_ (xml_leagues forecast) $ \league -> do
476 -- Construct the function that converts an XML listing to a
478 let todb = from_xml_fk_league forecast_id (league_name league)
480 -- Now use it to convert all of the XML listings.
481 let db_listings = map todb (listings league)
483 -- And finally, insert those DB listings.
484 mapM_ insert_ db_listings
486 -- Now we do the detailed weather items.
487 case (xml_detailed_weather m) of
490 let detailed_listings = xml_detailed_listings dw
491 let items = concatMap xml_items detailed_listings
492 mapM_ (insert_xml_fk_ weather_id) items
494 return ImportSucceeded
501 -- | Pickler to convert a 'WeatherForecastListingXml' to/from XML.
503 pickle_listing :: PU WeatherForecastListingXml
506 xpWrap (from_pair, to_pair) $
508 (xpElem "teams" xpText)
509 (xpElem "weather" (xpOption xpText))
511 -- from_pair (ts, Nothing) = WeatherForecastListingXml ts (Just "")
512 from_pair = uncurry WeatherForecastListingXml
513 to_pair WeatherForecastListingXml{..} = (xml_teams, xml_weather)
516 -- | Pickler to convert a 'WeatherLeague' to/from XML.
518 pickle_league :: PU WeatherLeague
521 xpWrap (from_pair, to_pair) $
523 (xpAttr "name" $ xpOption xpText)
524 (xpList pickle_listing)
526 from_pair = uncurry WeatherLeague
527 to_pair WeatherLeague{..} = (league_name, listings)
530 -- | Pickler to convert a 'WeatherForecastXml' to/from XML.
532 pickle_forecast :: PU WeatherForecastXml
535 xpWrap (from_pair, to_pair) $
537 (xpAttr "gamedate" xp_gamedate)
538 (xpList pickle_league)
540 from_pair = uncurry WeatherForecastXml
541 to_pair WeatherForecastXml{..} = (xml_game_date,
546 -- | (Un)pickle a 'WeatherDetailedWeatherListingItemXml'.
548 pickle_item :: PU WeatherDetailedWeatherListingItemXml
551 xpWrap (from_tuple, to_tuple) $
552 xp9Tuple (xpElem "Sportcode" xpText)
553 (xpElem "GameID" xpInt)
554 (xpElem "Gamedate" xp_datetime)
555 (xpElem "AwayTeam" xpText)
556 (xpElem "HomeTeam" xpText)
557 (xpElem "WeatherType" xpInt)
558 (xpElem "Description" (xpOption xpText))
559 (xpElem "TempAdjust" (xpOption xpText))
560 (xpElem "Temperature" xpInt)
562 from_tuple = uncurryN WeatherDetailedWeatherListingItemXml
563 to_tuple w = (xml_sport_code w,
574 -- | (Un)pickle a 'WeatherDetailedWeatherListingXml'.
576 pickle_dw_listing :: PU WeatherDetailedWeatherListingXml
578 xpElem "DW_Listing" $
579 xpWrap (from_tuple, to_tuple) $
580 xpTriple (xpAttr "SportCode" xpText)
581 (xpAttr "Sport" xpText)
584 from_tuple = uncurryN WeatherDetailedWeatherListingXml
585 to_tuple w = (xml_dtl_listing_sport w,
586 xml_dtl_listing_sport_code w,
590 -- | (Un)pickle a 'WeatherDetailedWeatherXml'
592 pickle_detailed_weather :: PU WeatherDetailedWeatherXml
593 pickle_detailed_weather =
594 xpElem "Detailed_Weather" $
595 xpWrap (WeatherDetailedWeatherXml, xml_detailed_listings)
596 (xpList pickle_dw_listing)
599 -- | Pickler to convert a 'Message' to/from XML.
601 pickle_message :: PU Message
604 xpWrap (from_tuple, to_tuple) $
606 (xpElem "XML_File_ID" xpInt)
607 (xpElem "heading" xpText)
608 (xpElem "category" xpText)
609 (xpElem "sport" xpText)
610 (xpElem "title" xpText)
611 (xpList pickle_forecast)
612 (xpOption pickle_detailed_weather)
613 (xpElem "time_stamp" xp_time_stamp)
615 from_tuple = uncurryN Message
616 to_tuple Message{..} = (xml_xml_file_id,
622 xml_detailed_weather,
629 weather_tests :: TestTree
633 [ test_on_delete_cascade,
634 test_pickle_of_unpickle_is_identity,
635 test_unpickle_succeeds,
636 test_types_detected_correctly,
637 test_normal_teams_detected_correctly ]
640 -- | If we unpickle something and then pickle it, we should wind up
641 -- with the same thing we started with. WARNING: success of this
642 -- test does not mean that unpickling succeeded.
644 test_pickle_of_unpickle_is_identity :: TestTree
645 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
646 [ check "pickle composed with unpickle is the identity"
647 "test/xml/weatherxml.xml",
649 check "pickle composed with unpickle is the identity (detailed)"
650 "test/xml/weatherxml-detailed.xml" ]
652 check desc path = testCase desc $ do
653 (expected, actual) <- pickle_unpickle pickle_message path
657 -- | Make sure we can actually unpickle these things.
659 test_unpickle_succeeds :: TestTree
660 test_unpickle_succeeds = testGroup "unpickle tests"
661 [ check "unpickling succeeds"
662 "test/xml/weatherxml.xml",
663 check "unpickling succeeds (detailed)"
664 "test/xml/weatherxml-detailed.xml",
665 check "unpickling succeeds (empty weather)"
666 "test/xml/weatherxml-empty-weather.xml"]
668 check desc path = testCase desc $ do
669 actual <- unpickleable path pickle_message
674 -- | Make sure everything gets deleted when we delete the top-level
677 test_on_delete_cascade :: TestTree
678 test_on_delete_cascade = testGroup "cascading delete tests"
679 [ check "deleting weather deletes its children"
680 "test/xml/weatherxml.xml",
681 check "deleting weather deletes its children (detailed)"
682 "test/xml/weatherxml-detailed.xml",
683 check "deleting weather deletes its children (empty weather)"
684 "test/xml/weatherxml-empty-weather.xml"]
686 check desc path = testCase desc $ do
687 weather <- unsafe_unpickle path pickle_message
688 let a = undefined :: Weather
689 let b = undefined :: WeatherForecast
690 let c = undefined :: WeatherForecastListing
691 let d = undefined :: WeatherDetailedWeatherListingItem
692 actual <- withSqliteConn ":memory:" $ runDbConn $ do
693 runMigration silentMigrationLogger $ do
698 _ <- dbimport weather
700 count_a <- countAll a
701 count_b <- countAll b
702 count_c <- countAll c
703 count_d <- countAll d
704 return $ count_a + count_b + count_c + count_d
709 -- | We want to make sure type1 documents are detected as type1, and
710 -- type2 documents detected as type2..
712 test_types_detected_correctly :: TestTree
713 test_types_detected_correctly =
714 testGroup "weatherxml types detected correctly"
715 [ check "test/xml/weatherxml.xml"
716 "first type detected correctly"
718 check "test/xml/weatherxml-detailed.xml"
719 "first type detected correctly (detailed)"
721 check "test/xml/weatherxml-empty-weather.xml"
722 "first type detected correctly (empty weather)"
724 check "test/xml/weatherxml-type2.xml"
725 "second type detected correctly"
728 check path desc expected = testCase desc $ do
729 xmltree <- unsafe_read_document path
730 let actual = is_type1 xmltree
734 -- | We want to make sure normal teams are detected as normal, and the
735 -- backwards ones are flagged as backwards.
737 test_normal_teams_detected_correctly :: TestTree
738 test_normal_teams_detected_correctly =
739 testGroup "team order is detected correctly" [
741 check "normal teams are detected correctly"
742 "test/xml/weatherxml.xml"
745 check "backwards teams are detected correctly"
746 "test/xml/weatherxml-backwards-teams.xml"
749 check desc path expected = testCase desc $ do
750 xmltree <- unsafe_read_document path
751 let actual = teams_are_normal xmltree