1 {-# LANGUAGE DeriveGeneric #-}
2 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE QuasiQuotes #-}
5 {-# LANGUAGE RecordWildCards #-}
6 {-# LANGUAGE TemplateHaskell #-}
7 {-# LANGUAGE TypeFamilies #-}
9 -- | Parse TSN XML for the DTD \"weatherxml.dtd\". Each document
10 -- contains a bunch of forecasts, which each contain zero or more
11 -- leagues, which in turn (each) contain a bunch of listings.
13 module TSN.XML.Weather (
20 -- * WARNING: these are private but exported to silence warnings
21 WeatherConstructor(..),
22 WeatherDetailedWeatherListingItemConstructor(..),
23 WeatherForecastConstructor(..),
24 WeatherForecastListingConstructor(..) )
28 import Control.Monad ( forM_ )
29 import Data.Time ( UTCTime )
30 import Data.Tuple.Curry ( uncurryN )
31 import qualified Data.Vector.HFixed as H ( HVector, cons, convert )
32 import Database.Groundhog (
38 silentMigrationLogger )
39 import Database.Groundhog.Core ( DefaultKey )
40 import Database.Groundhog.Generic ( runDbConn )
41 import Database.Groundhog.Sqlite ( withSqliteConn )
42 import Database.Groundhog.TH (
45 import qualified GHC.Generics as GHC ( Generic )
46 import Test.Tasty ( TestTree, testGroup )
47 import Test.Tasty.HUnit ( (@?=), testCase )
48 import Text.XML.HXT.Core (
75 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
76 import TSN.Picklers ( xp_datetime, xp_gamedate, xp_time_stamp )
77 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
90 -- | The DTD to which this module corresponds. Used to invoke dbimport.
93 dtd = "weatherxml.dtd"
100 -- * WeatherForecastListing/WeatherForecastListingXml
102 -- | XML representation of a weather forecast listing.
104 data WeatherForecastListingXml =
105 WeatherForecastListingXml {
107 xml_weather :: Maybe String }
108 deriving (Eq, GHC.Generic, Show)
111 -- | For 'H.convert'.
113 instance H.HVector WeatherForecastListingXml
116 -- | Database representation of a weather forecast listing. The
117 -- 'db_league_name' field should come from the containing \<league\>
118 -- element which is not stored in the database.
120 data WeatherForecastListing =
121 WeatherForecastListing {
122 db_weather_forecasts_id :: DefaultKey WeatherForecast,
123 db_league_name :: Maybe String,
125 db_weather :: Maybe String }
128 -- | We don't make 'WeatherForecastListingXml' an instance of
129 -- 'FromXmlFk' because it needs some additional information, namely
130 -- the league name from its containing \<league\> element.
132 -- When supplied with a forecast id and a league name, this will
133 -- turn an XML listing into a database one.
135 from_xml_fk_league :: DefaultKey WeatherForecast
137 -> WeatherForecastListingXml
138 -> WeatherForecastListing
139 from_xml_fk_league fk ln WeatherForecastListingXml{..} =
140 WeatherForecastListing {
141 db_weather_forecasts_id = fk,
143 db_teams = xml_teams,
144 db_weather = xml_weather }
149 -- | XML representation of a league, as they appear in the weather
150 -- documents. There is no associated database representation because
151 -- the league element really adds no information besides its own
152 -- (usually empty) name. The leagues contain listings, so we
153 -- associate the league name with each listing instead.
157 league_name :: Maybe String,
158 listings :: [WeatherForecastListingXml] }
162 -- * WeatherForecast/WeatherForecastXml
164 -- | Database representation of a weather forecast.
166 data WeatherForecast =
168 db_weather_id :: DefaultKey Weather,
169 db_game_date :: UTCTime }
172 -- | XML representation of a weather forecast.
174 data WeatherForecastXml =
176 xml_game_date :: UTCTime,
177 xml_leagues :: [WeatherLeague] }
178 deriving (Eq, GHC.Generic, Show)
181 -- | For 'H.convert'.
183 instance H.HVector WeatherForecastXml
186 instance ToDb WeatherForecastXml where
187 -- | The database representation of a 'WeatherForecastXml' is a
188 -- 'WeatherForecast'.
190 type Db WeatherForecastXml = WeatherForecast
193 instance Child WeatherForecastXml where
194 -- | The database type containing a 'WeatherForecastXml' is
196 type Parent WeatherForecastXml = Weather
199 instance FromXmlFk WeatherForecastXml where
201 -- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
202 -- add the foreign key to the containing 'Weather', and copy the
205 -- This is so short it's pointless to do it generically.
207 from_xml_fk fk WeatherForecastXml{..} =
210 db_game_date = xml_game_date }
213 -- | This allows us to call 'insert_xml' on an 'WeatherForecastXml'
214 -- without first converting it to the database representation.
216 instance XmlImportFk WeatherForecastXml
218 -- * WeatherDetailedWeatherXml
220 -- | XML Representation of a \<Detailed_Weather\>, which just contains
221 -- a bunch iof \<DW_Listing\>s. There is no associated database type
222 -- since these don't really contain any information.
224 data WeatherDetailedWeatherXml =
225 WeatherDetailedWeatherXml {
226 xml_detailed_listings :: [WeatherDetailedWeatherListingXml] }
230 -- * WeatherDetailedWeatherXml
232 -- | XML Representation of a \<DW_Listing\>. The sport and sport code
233 -- come as attributes, but then these just contain a bunch of
234 -- \<Item\>s. There is no associated database type since these don't
235 -- contain much information. The sport we already know from the
236 -- \<message\>, while the sport code is ignored since it's already
237 -- present in each \<Item\>s.
239 data WeatherDetailedWeatherListingXml =
240 WeatherDetailedWeatherListingXml
241 String -- xml_dtl_listing_sport, unused
242 String -- xml_dtl_listing_sport_code, unused
243 [WeatherDetailedWeatherListingItemXml] -- xml_items
244 deriving (Eq, GHC.Generic, Show)
247 -- | Accessor for the third field of WeatherDetailedWeatherListingXml.
248 -- We don't use field names to avoid the unused field warnings that
249 -- we'd otherwise get for the first two fields.
251 xml_items :: WeatherDetailedWeatherListingXml
252 -> [WeatherDetailedWeatherListingItemXml]
253 xml_items (WeatherDetailedWeatherListingXml _ _ items) = items
256 -- | For 'H.convert'.
258 instance H.HVector WeatherDetailedWeatherListingXml
261 -- * WeatherDetailedWeatherListingItem / WeatherDetailedWeatherListingItemXml
263 -- | Database representation of a detailed weather item. The away/home
264 -- teams don't use the representation in "TSN.Team" because all
265 -- we're given is a name, and a team id is required for "TSN.Team".
267 -- We also drop the sport name, because it's given in the parent
270 -- The leading underscores prevent unused field warnings.
272 data WeatherDetailedWeatherListingItem =
273 WeatherDetailedWeatherListingItem {
274 _db_dtl_weather_id :: DefaultKey Weather, -- ^ Avoid name collision by
275 -- using \"dtl\" prefix.
276 _db_sport_code :: String,
278 _db_dtl_game_date :: UTCTime, -- ^ Avoid name clash with \"dtl\" prefix
279 _db_away_team :: String,
280 _db_home_team :: String,
281 _db_weather_type :: Int,
282 _db_description :: Maybe String,
283 _db_temp_adjust :: Maybe String,
284 _db_temperature :: Int }
285 deriving ( GHC.Generic )
287 -- | For 'H.cons' and 'H.convert'.
289 instance H.HVector WeatherDetailedWeatherListingItem
292 -- | XML representation of a detailed weather item. Same as the
293 -- database representation, only without the foreign key and the
294 -- sport name that comes from the containing listing.
296 -- The leading underscores prevent unused field warnings.
298 data WeatherDetailedWeatherListingItemXml =
299 WeatherDetailedWeatherListingItemXml {
300 _xml_sport_code :: String,
302 _xml_dtl_game_date :: UTCTime,
303 _xml_away_team :: String,
304 _xml_home_team :: String,
305 _xml_weather_type :: Int,
306 _xml_description :: Maybe String,
307 _xml_temp_adjust :: Maybe String,
308 _xml_temperature :: Int }
309 deriving (Eq, GHC.Generic, Show)
312 -- | For 'H.convert'.
314 instance H.HVector WeatherDetailedWeatherListingItemXml
316 instance ToDb WeatherDetailedWeatherListingItemXml where
317 -- | Our database analogue is a 'WeatherDetailedWeatherListingItem'.
318 type Db WeatherDetailedWeatherListingItemXml =
319 WeatherDetailedWeatherListingItem
321 instance Child WeatherDetailedWeatherListingItemXml where
322 -- | We skip two levels of containers and say that the items belong
323 -- to the top-level 'Weather'.
324 type Parent WeatherDetailedWeatherListingItemXml = Weather
326 instance FromXmlFk WeatherDetailedWeatherListingItemXml where
327 -- | To convert from the XML to database representation, we simply
328 -- add the foreign key (to Weather) and copy the rest of the fields.
331 -- | This allows us to insert the XML representation directly without
332 -- having to do the manual XML -\> DB conversion.
334 instance XmlImportFk WeatherDetailedWeatherListingItemXml
338 -- | The database representation of a weather message. We don't
339 -- contain the forecasts or the detailed weather since those are
340 -- foreigned-keyed to us.
344 db_xml_file_id :: Int,
347 db_time_stamp :: UTCTime }
350 -- | The XML representation of a weather message.
354 xml_xml_file_id :: Int,
355 xml_heading :: String,
356 xml_category :: String,
359 xml_forecasts :: [WeatherForecastXml],
360 xml_detailed_weather :: Maybe WeatherDetailedWeatherXml,
361 xml_time_stamp :: UTCTime }
362 deriving (Eq, GHC.Generic, Show)
365 -- | For 'H.convert'.
367 instance H.HVector Message
370 instance ToDb Message where
371 -- | The database representation of 'Message' is 'Weather'.
373 type Db Message = Weather
375 instance FromXml Message where
376 -- | To get a 'Weather' from a 'Message', we drop a bunch of
379 from_xml Message{..} =
381 db_xml_file_id = xml_xml_file_id,
382 db_sport = xml_sport,
383 db_title = xml_title,
384 db_time_stamp = xml_time_stamp }
386 -- | This allows us to insert the XML representation 'Message'
389 instance XmlImport Message
396 mkPersist tsn_codegen_config [groundhog|
401 - name: unique_weather
403 # Prevent multiple imports of the same message.
404 fields: [db_xml_file_id]
406 - entity: WeatherForecast
407 dbName: weather_forecasts
409 - name: WeatherForecast
411 - name: db_weather_id
415 - entity: WeatherForecastListing
416 dbName: weather_forecast_listings
418 - name: WeatherForecastListing
420 - name: db_weather_forecasts_id
424 # We rename the two fields that needed a "dtl" prefix to avoid a name
426 - entity: WeatherDetailedWeatherListingItem
427 dbName: weather_detailed_items
429 - name: WeatherDetailedWeatherListingItem
431 - name: _db_dtl_weather_id
435 - name: _db_dtl_game_date
442 -- | There are two different types of documents that claim to be
443 -- \"weatherxml.dtd\". The first, more common type has listings
444 -- within forecasts. The second type has forecasts within
445 -- listings. Clearly we can't parse both of these using the same
448 -- For now we're simply punting on the issue and refusing to parse
449 -- the second type. This will check the given @xmltree@ to see if
450 -- there are any forecasts contained within listings. If there are,
451 -- then it's the second type that we don't know what to do with.
453 is_type1 :: XmlTree -> Bool
459 parse :: XmlTree -> [XmlTree]
460 parse = runLA $ hasName "/"
463 /> hasName "forecast"
465 elements = parse xmltree
468 -- | Some weatherxml documents even have the Home/Away teams in the
469 -- wrong order. We can't parse that! This next bit of voodoo detects
470 -- whether or not there are any \<HomeTeam\> elements that are
471 -- directly followed by sibling \<AwayTeam\> elements. This is the
472 -- opposite of the usual order.
474 teams_are_normal :: XmlTree -> Bool
475 teams_are_normal xmltree =
480 parse :: XmlTree -> [XmlTree]
481 parse = runLA $ hasName "/"
483 /> hasName "Detailed_Weather"
484 /> hasName "DW_Listing"
488 >>> filterAxis (hasName "HomeTeam")
489 >>> followingSiblingAxis
491 >>> hasName "AwayTeam"
493 elements = parse xmltree
496 instance DbImport Message where
499 migrate (undefined :: Weather)
500 migrate (undefined :: WeatherForecast)
501 migrate (undefined :: WeatherForecastListing)
502 migrate (undefined :: WeatherDetailedWeatherListingItem)
505 -- First we insert the top-level weather record.
506 weather_id <- insert_xml m
508 -- Next insert all of the forecasts, one at a time.
509 forM_ (xml_forecasts m) $ \forecast -> do
510 forecast_id <- insert_xml_fk weather_id forecast
512 -- With the forecast id in hand, loop through this forecast's
514 forM_ (xml_leagues forecast) $ \league -> do
515 -- Construct the function that converts an XML listing to a
517 let todb = from_xml_fk_league forecast_id (league_name league)
519 -- Now use it to convert all of the XML listings.
520 let db_listings = map todb (listings league)
522 -- And finally, insert those DB listings.
523 mapM_ insert_ db_listings
525 -- Now we do the detailed weather items.
526 case (xml_detailed_weather m) of
529 let detailed_listings = xml_detailed_listings dw
530 let items = concatMap xml_items detailed_listings
531 mapM_ (insert_xml_fk_ weather_id) items
533 return ImportSucceeded
540 -- | Pickler to convert a 'WeatherForecastListingXml' to/from XML.
542 pickle_listing :: PU WeatherForecastListingXml
545 xpWrap (from_pair, H.convert) $
547 (xpElem "teams" xpText)
548 (xpElem "weather" (xpOption xpText))
550 from_pair = uncurry WeatherForecastListingXml
554 -- | Pickler to convert a 'WeatherLeague' to/from XML.
556 pickle_league :: PU WeatherLeague
559 xpWrap (from_pair, to_pair) $
561 (xpAttr "name" $ xpOption xpText)
562 (xpList pickle_listing)
564 from_pair = uncurry WeatherLeague
565 to_pair WeatherLeague{..} = (league_name, listings)
568 -- | Pickler to convert a 'WeatherForecastXml' to/from XML.
570 pickle_forecast :: PU WeatherForecastXml
573 xpWrap (from_pair, to_pair) $
575 (xpAttr "gamedate" xp_gamedate)
576 (xpList pickle_league)
578 from_pair = uncurry WeatherForecastXml
579 to_pair WeatherForecastXml{..} = (xml_game_date,
584 -- | (Un)pickle a 'WeatherDetailedWeatherListingItemXml'.
586 pickle_item :: PU WeatherDetailedWeatherListingItemXml
589 xpWrap (from_tuple, H.convert) $
590 xp9Tuple (xpElem "Sportcode" xpText)
591 (xpElem "GameID" xpInt)
592 (xpElem "Gamedate" xp_datetime)
593 (xpElem "AwayTeam" xpText)
594 (xpElem "HomeTeam" xpText)
595 (xpElem "WeatherType" xpInt)
596 (xpElem "Description" (xpOption xpText))
597 (xpElem "TempAdjust" (xpOption xpText))
598 (xpElem "Temperature" xpInt)
600 from_tuple = uncurryN WeatherDetailedWeatherListingItemXml
604 -- | (Un)pickle a 'WeatherDetailedWeatherListingXml'.
606 pickle_dw_listing :: PU WeatherDetailedWeatherListingXml
608 xpElem "DW_Listing" $
609 xpWrap (from_tuple, H.convert) $
610 xpTriple (xpAttr "SportCode" xpText)
611 (xpAttr "Sport" xpText)
614 from_tuple = uncurryN WeatherDetailedWeatherListingXml
617 -- | (Un)pickle a 'WeatherDetailedWeatherXml'
619 pickle_detailed_weather :: PU WeatherDetailedWeatherXml
620 pickle_detailed_weather =
621 xpElem "Detailed_Weather" $
622 xpWrap (WeatherDetailedWeatherXml, xml_detailed_listings)
623 (xpList pickle_dw_listing)
626 -- | Pickler to convert a 'Message' to/from XML.
628 pickle_message :: PU Message
631 xpWrap (from_tuple, H.convert) $
633 (xpElem "XML_File_ID" xpInt)
634 (xpElem "heading" xpText)
635 (xpElem "category" xpText)
636 (xpElem "sport" xpText)
637 (xpElem "title" xpText)
638 (xpList pickle_forecast)
639 (xpOption pickle_detailed_weather)
640 (xpElem "time_stamp" xp_time_stamp)
642 from_tuple = uncurryN Message
648 weather_tests :: TestTree
652 [ test_on_delete_cascade,
653 test_pickle_of_unpickle_is_identity,
654 test_unpickle_succeeds,
655 test_types_detected_correctly,
656 test_normal_teams_detected_correctly ]
659 -- | If we unpickle something and then pickle it, we should wind up
660 -- with the same thing we started with. WARNING: success of this
661 -- test does not mean that unpickling succeeded.
663 test_pickle_of_unpickle_is_identity :: TestTree
664 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
665 [ check "pickle composed with unpickle is the identity"
666 "test/xml/weatherxml.xml",
668 check "pickle composed with unpickle is the identity (detailed)"
669 "test/xml/weatherxml-detailed.xml" ]
671 check desc path = testCase desc $ do
672 (expected, actual) <- pickle_unpickle pickle_message path
676 -- | Make sure we can actually unpickle these things.
678 test_unpickle_succeeds :: TestTree
679 test_unpickle_succeeds = testGroup "unpickle tests"
680 [ check "unpickling succeeds"
681 "test/xml/weatherxml.xml",
682 check "unpickling succeeds (detailed)"
683 "test/xml/weatherxml-detailed.xml",
684 check "unpickling succeeds (empty weather)"
685 "test/xml/weatherxml-empty-weather.xml"]
687 check desc path = testCase desc $ do
688 actual <- unpickleable path pickle_message
693 -- | Make sure everything gets deleted when we delete the top-level
696 test_on_delete_cascade :: TestTree
697 test_on_delete_cascade = testGroup "cascading delete tests"
698 [ check "deleting weather deletes its children"
699 "test/xml/weatherxml.xml",
700 check "deleting weather deletes its children (detailed)"
701 "test/xml/weatherxml-detailed.xml",
702 check "deleting weather deletes its children (empty weather)"
703 "test/xml/weatherxml-empty-weather.xml"]
705 check desc path = testCase desc $ do
706 weather <- unsafe_unpickle path pickle_message
707 let a = undefined :: Weather
708 let b = undefined :: WeatherForecast
709 let c = undefined :: WeatherForecastListing
710 let d = undefined :: WeatherDetailedWeatherListingItem
711 actual <- withSqliteConn ":memory:" $ runDbConn $ do
712 runMigration silentMigrationLogger $ do
717 _ <- dbimport weather
719 count_a <- countAll a
720 count_b <- countAll b
721 count_c <- countAll c
722 count_d <- countAll d
723 return $ count_a + count_b + count_c + count_d
728 -- | We want to make sure type1 documents are detected as type1, and
729 -- type2 documents detected as type2..
731 test_types_detected_correctly :: TestTree
732 test_types_detected_correctly =
733 testGroup "weatherxml types detected correctly"
734 [ check "test/xml/weatherxml.xml"
735 "first type detected correctly"
737 check "test/xml/weatherxml-detailed.xml"
738 "first type detected correctly (detailed)"
740 check "test/xml/weatherxml-empty-weather.xml"
741 "first type detected correctly (empty weather)"
743 check "test/xml/weatherxml-type2.xml"
744 "second type detected correctly"
747 check path desc expected = testCase desc $ do
748 xmltree <- unsafe_read_document path
749 let actual = is_type1 xmltree
753 -- | We want to make sure normal teams are detected as normal, and the
754 -- backwards ones are flagged as backwards.
756 test_normal_teams_detected_correctly :: TestTree
757 test_normal_teams_detected_correctly =
758 testGroup "team order is detected correctly" [
760 check "normal teams are detected correctly"
761 "test/xml/weatherxml.xml"
764 check "backwards teams are detected correctly"
765 "test/xml/weatherxml-backwards-teams.xml"
768 check desc path expected = testCase desc $ do
769 xmltree <- unsafe_read_document path
770 let actual = teams_are_normal xmltree