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 WeatherForecastConstructor(..),
20 WeatherForecastListingConstructor(..) )
24 import Control.Monad ( forM_ )
25 import Data.Time ( UTCTime )
26 import Data.Tuple.Curry ( uncurryN )
27 import Database.Groundhog (
33 silentMigrationLogger )
34 import Database.Groundhog.Core ( DefaultKey )
35 import Database.Groundhog.Generic ( runDbConn )
36 import Database.Groundhog.Sqlite ( withSqliteConn )
37 import Database.Groundhog.TH (
40 import Test.Tasty ( TestTree, testGroup )
41 import Test.Tasty.HUnit ( (@?=), testCase )
42 import Text.XML.HXT.Core (
57 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
58 import TSN.Picklers ( xp_gamedate, xp_time_stamp )
59 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
71 -- | The DTD to which this module corresponds. Used to invoke dbimport.
74 dtd = "weatherxml.dtd"
81 -- * WeatherForecastListing/WeatherForecastListingXml
83 -- | XML representation of a weather forecast listing.
85 data WeatherForecastListingXml =
86 WeatherForecastListingXml {
88 xml_weather :: String }
92 -- | Database representation of a weather forecast listing. The
93 -- 'db_league_name' field should come from the containing \<league\>
94 -- element which is not stored in the database.
96 data WeatherForecastListing =
97 WeatherForecastListing {
98 db_weather_forecasts_id :: DefaultKey WeatherForecast,
99 db_league_name :: Maybe String,
101 db_weather :: String }
104 -- | We don't make 'WeatherForecastListingXml' an instance of
105 -- 'FromXmlFk' because it needs some additional information, namely
106 -- the league name from its containing \<league\> element.
108 -- When supplied with a forecast id and a league name, this will
109 -- turn an XML listing into a database one.
111 from_xml_fk_league :: DefaultKey WeatherForecast
113 -> WeatherForecastListingXml
114 -> WeatherForecastListing
115 from_xml_fk_league fk ln WeatherForecastListingXml{..} =
116 WeatherForecastListing {
117 db_weather_forecasts_id = fk,
119 db_teams = xml_teams,
120 db_weather = xml_weather }
125 -- | XML representation of a league, as they appear in the weather
126 -- documents. There is no associated database representation because
127 -- the league element really adds no information besides its own
128 -- (usually empty) name. The leagues contain listings, so we
129 -- associate the league name with each listing instead.
133 league_name :: Maybe String,
134 listings :: [WeatherForecastListingXml] }
138 -- * WeatherForecast/WeatherForecastXml
140 -- | Database representation of a weather forecast.
142 data WeatherForecast =
144 db_weather_id :: DefaultKey Weather,
145 db_game_date :: UTCTime }
148 -- | XML representation of a weather forecast.
150 data WeatherForecastXml =
152 xml_game_date :: UTCTime,
153 xml_leagues :: [WeatherLeague] }
157 instance ToDb WeatherForecastXml where
158 -- | The database representation of a 'WeatherForecastXml' is a
159 -- 'WeatherForecast'.
161 type Db WeatherForecastXml = WeatherForecast
164 instance Child WeatherForecastXml where
165 -- | The database type containing a 'WeatherForecastXml' is
167 type Parent WeatherForecastXml = Weather
170 instance FromXmlFk WeatherForecastXml where
172 -- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
173 -- just copy everything verbatim.
175 from_xml_fk fk WeatherForecastXml{..} =
178 db_game_date = xml_game_date }
181 -- | This allows us to call 'insert_xml' on an 'WeatherForecastXml'
182 -- without first converting it to the database representation.
184 instance XmlImportFk WeatherForecastXml
189 -- | The database representation of a weather message.
193 db_xml_file_id :: Int,
196 db_time_stamp :: UTCTime }
199 -- | The XML representation of a weather message.
203 xml_xml_file_id :: Int,
204 xml_heading :: String,
205 xml_category :: String,
208 xml_forecasts :: [WeatherForecastXml],
209 xml_time_stamp :: UTCTime }
212 instance ToDb Message where
213 -- | The database representation of 'Message' is 'Weather'.
215 type Db Message = Weather
217 instance FromXml Message where
218 -- | To get a 'Weather' from a 'Message', we drop a bunch of
221 from_xml Message{..} =
223 db_xml_file_id = xml_xml_file_id,
224 db_sport = xml_sport,
225 db_title = xml_title,
226 db_time_stamp = xml_time_stamp }
228 -- | This allows us to insert the XML representation 'Message'
231 instance XmlImport Message
238 mkPersist tsn_codegen_config [groundhog|
243 - name: unique_weather
245 # Prevent multiple imports of the same message.
246 fields: [db_xml_file_id]
248 - entity: WeatherForecast
249 dbName: weather_forecasts
251 - name: WeatherForecast
253 - name: db_weather_id
257 - entity: WeatherForecastListing
258 dbName: weather_forecast_listings
260 - name: WeatherForecastListing
262 - name: db_weather_forecasts_id
269 instance DbImport Message where
272 migrate (undefined :: Weather)
273 migrate (undefined :: WeatherForecast)
274 migrate (undefined :: WeatherForecastListing)
277 -- First we insert the top-level weather record.
278 weather_id <- insert_xml m
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
284 -- With the forecast id in hand, loop through this forecast's
286 forM_ (xml_leagues forecast) $ \league -> do
287 -- Construct the function that converts an XML listing to a
289 let todb = from_xml_fk_league forecast_id (league_name league)
291 -- Now use it to convert all of the XML listings.
292 let db_listings = map todb (listings league)
294 -- And finally, insert those DB listings.
295 mapM_ insert_ db_listings
297 return ImportSucceeded
304 -- | Pickler to convert a 'WeatherForecastListingXml' to/from XML.
306 pickle_listing :: PU WeatherForecastListingXml
309 xpWrap (from_pair, to_pair) $
311 (xpElem "teams" xpText)
312 (xpElem "weather" xpText)
314 from_pair = uncurry WeatherForecastListingXml
315 to_pair WeatherForecastListingXml{..} = (xml_teams, xml_weather)
318 -- | Pickler to convert a 'WeatherLeague' to/from XML.
320 pickle_league :: PU WeatherLeague
323 xpWrap (from_pair, to_pair) $
325 (xpAttr "name" $ xpOption xpText)
326 (xpList pickle_listing)
328 from_pair = uncurry WeatherLeague
329 to_pair WeatherLeague{..} = (league_name, listings)
332 -- | Pickler to convert a 'WeatherForecastXml' to/from XML.
334 pickle_forecast :: PU WeatherForecastXml
337 xpWrap (from_pair, to_pair) $
339 (xpAttr "gamedate" xp_gamedate)
340 (xpList pickle_league)
342 from_pair = uncurry WeatherForecastXml
343 to_pair WeatherForecastXml{..} = (xml_game_date,
348 -- | Pickler to convert a 'Message' to/from XML.
350 pickle_message :: PU Message
353 xpWrap (from_tuple, to_tuple) $
355 (xpElem "XML_File_ID" xpInt)
356 (xpElem "heading" xpText)
357 (xpElem "category" xpText)
358 (xpElem "sport" xpText)
359 (xpElem "title" xpText)
360 (xpList pickle_forecast)
361 (xpElem "time_stamp" xp_time_stamp)
363 from_tuple = uncurryN Message
364 to_tuple Message{..} = (xml_xml_file_id,
376 weather_tests :: TestTree
380 [ test_on_delete_cascade,
381 test_pickle_of_unpickle_is_identity,
382 test_unpickle_succeeds ]
385 -- | If we unpickle something and then pickle it, we should wind up
386 -- with the same thing we started with. WARNING: success of this
387 -- test does not mean that unpickling succeeded.
389 test_pickle_of_unpickle_is_identity :: TestTree
390 test_pickle_of_unpickle_is_identity =
391 testCase "pickle composed with unpickle is the identity" $ do
392 let path = "test/xml/weatherxml.xml"
393 (expected, actual) <- pickle_unpickle pickle_message path
397 -- | Make sure we can actually unpickle these things.
399 test_unpickle_succeeds :: TestTree
400 test_unpickle_succeeds =
401 testCase "unpickling succeeds" $ do
402 let path = "test/xml/weatherxml.xml"
403 actual <- unpickleable path pickle_message
408 -- | Make sure everything gets deleted when we delete the top-level
411 test_on_delete_cascade :: TestTree
412 test_on_delete_cascade =
413 testCase "deleting weather deletes its children" $ do
414 let path = "test/xml/weatherxml.xml"
415 weather <- unsafe_unpickle path pickle_message
416 let a = undefined :: Weather
417 let b = undefined :: WeatherForecast
418 let c = undefined :: WeatherForecastListing
419 actual <- withSqliteConn ":memory:" $ runDbConn $ do
420 runMigration silentMigrationLogger $ do
424 _ <- dbimport weather
426 count_a <- countAll a
427 count_b <- countAll b
428 count_c <- countAll c
429 return $ count_a + count_b + count_c