From: Michael Orlitzky Date: Sat, 5 Jul 2014 17:34:09 +0000 (-0400) Subject: Add support for the new Detailed_Weather elements. X-Git-Tag: 0.0.6~30 X-Git-Url: http://gitweb.michael.orlitzky.com/?p=dead%2Fhtsn-import.git;a=commitdiff_plain;h=6ccdf3223bd4025a8e57cec1c99633a381a9698e Add support for the new Detailed_Weather elements. Add another test case for the weather. Update the TODO. --- diff --git a/doc/TODO b/doc/TODO index 66f8d3a..9413031 100644 --- a/doc/TODO +++ b/doc/TODO @@ -4,7 +4,8 @@ 2. Write a test for test/xml/Odds_XML-long-import.xml once it no longer takes 10 minutes to import (Postgres only?). -3. Add support the the second type of weatherxml (see man page). +3. Return ImportUnsupported for the second type of weatherxml (see man + page). 4. We have DTDs but no sample XML for the following SportInfo types, which have therefore been left unimplmented for now: diff --git a/src/TSN/XML/Weather.hs b/src/TSN/XML/Weather.hs index 6df3ce3..c2eee4a 100644 --- a/src/TSN/XML/Weather.hs +++ b/src/TSN/XML/Weather.hs @@ -16,6 +16,7 @@ module TSN.XML.Weather ( weather_tests, -- * WARNING: these are private but exported to silence warnings WeatherConstructor(..), + WeatherDetailedWeatherListingItemConstructor(..), WeatherForecastConstructor(..), WeatherForecastListingConstructor(..) ) where @@ -41,7 +42,8 @@ import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) import Text.XML.HXT.Core ( PU, - xp7Tuple, + xp8Tuple, + xp9Tuple, xpAttr, xpElem, xpInt, @@ -49,13 +51,14 @@ import Text.XML.HXT.Core ( xpOption, xpPair, xpText, + xpTriple, xpWrap ) -- Local imports. import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) -import TSN.Picklers ( xp_gamedate, xp_time_stamp ) +import TSN.Picklers ( xp_datetime, xp_gamedate, xp_time_stamp ) import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) ) import Xml ( Child(..), @@ -183,10 +186,111 @@ instance FromXmlFk WeatherForecastXml where -- instance XmlImportFk WeatherForecastXml +-- * WeatherDetailedWeatherXml + +-- | XML Representation of a \, which just contains +-- a bunch iof \s. There is no associated database type +-- since these don't really contain any information. +-- +data WeatherDetailedWeatherXml = + WeatherDetailedWeatherXml { + xml_detailed_listings :: [WeatherDetailedWeatherListingXml] } + deriving (Eq, Show) + + +-- * WeatherDetailedWeatherXml + +-- | XML Representation of a \. The sport and sport code +-- come as attributes, but then these just contain a bunch of +-- \s. There is no associated database type since these don't +-- contain much information. The sport we already know from the +-- \, while the sport code is ignored since it's already +-- present in each \s. +-- +data WeatherDetailedWeatherListingXml = + WeatherDetailedWeatherListingXml { + xml_dtl_listing_sport :: String, + xml_dtl_listing_sport_code :: String, + xml_items :: [WeatherDetailedWeatherListingItemXml] } + deriving (Eq, Show) + +-- * WeatherDetailedWeatherListingItem / WeatherDetailedWeatherListingItemXml + +-- | Database representation of a detailed weather item. The away/home +-- teams don't use the representation in "TSN.Team" because all +-- we're given is a name, and a team id is required for "TSN.Team". +-- +-- We also drop the sport name, because it's given in the parent +-- 'Weather'. +-- +data WeatherDetailedWeatherListingItem = + WeatherDetailedWeatherListingItem { + db_dtl_weather_id :: DefaultKey Weather, -- ^ Avoid name collision by + -- using \"dtl\" prefix. + db_sport_code :: String, + db_game_id :: Int, + db_dtl_game_date :: UTCTime, -- ^ Avoid name clash with \"dtl\" prefix + db_away_team :: String, + db_home_team :: String, + db_weather_type :: Int, + db_description :: String, + db_temp_adjust :: String, + db_temperature :: Int } + + +-- | XML representation of a detailed weather item. Same as the +-- database representation, only without the foreign key and the +-- sport name that comes from the containing listing. +data WeatherDetailedWeatherListingItemXml = + WeatherDetailedWeatherListingItemXml { + xml_sport_code :: String, + xml_game_id :: Int, + xml_dtl_game_date :: UTCTime, + xml_away_team :: String, + xml_home_team :: String, + xml_weather_type :: Int, + xml_description :: String, + xml_temp_adjust :: String, + xml_temperature :: Int } + deriving (Eq, Show) + + +instance ToDb WeatherDetailedWeatherListingItemXml where + -- | Our database analogue is a 'WeatherDetailedWeatherListingItem'. + type Db WeatherDetailedWeatherListingItemXml = + WeatherDetailedWeatherListingItem + +instance Child WeatherDetailedWeatherListingItemXml where + -- | We skip two levels of containers and say that the items belong + -- to the top-level 'Weather'. + type Parent WeatherDetailedWeatherListingItemXml = Weather + +instance FromXmlFk WeatherDetailedWeatherListingItemXml where + -- | To convert from the XML to database representation, we simply + -- add the foreign key (to Weather) and copy the rest of the fields. + from_xml_fk fk WeatherDetailedWeatherListingItemXml{..} = + WeatherDetailedWeatherListingItem { + db_dtl_weather_id = fk, + db_sport_code = xml_sport_code, + db_game_id = xml_game_id, + db_dtl_game_date = xml_dtl_game_date, + db_away_team = xml_away_team, + db_home_team = xml_home_team, + db_weather_type = xml_weather_type, + db_description = xml_description, + db_temp_adjust = xml_temp_adjust, + db_temperature = xml_temperature } + +-- | This allows us to insert the XML representation directly without +-- having to do the manual XML -\> DB conversion. +-- +instance XmlImportFk WeatherDetailedWeatherListingItemXml -- * Weather/Message --- | The database representation of a weather message. +-- | The database representation of a weather message. We don't +-- contain the forecasts or the detailed weather since those are +-- foreigned-keyed to us. -- data Weather = Weather { @@ -206,6 +310,7 @@ data Message = xml_sport :: String, xml_title :: String, xml_forecasts :: [WeatherForecastXml], + xml_detailed_weather :: Maybe WeatherDetailedWeatherXml, xml_time_stamp :: UTCTime } deriving (Eq, Show) @@ -232,7 +337,7 @@ instance XmlImport Message -- --- Database stuff +-- * Database stuff -- mkPersist tsn_codegen_config [groundhog| @@ -263,6 +368,19 @@ mkPersist tsn_codegen_config [groundhog| reference: onDelete: cascade +# We rename the two fields that needed a "dtl" prefix to avoid a name clash. +- entity: WeatherDetailedWeatherListingItem + dbName: weather_detailed_items + constructors: + - name: WeatherDetailedWeatherListingItem + fields: + - name: db_dtl_weather_id + dbName: weather_id + reference: + onDelete: cascade + - name: db_dtl_game_date + dbName: game_date + |] @@ -272,6 +390,7 @@ instance DbImport Message where migrate (undefined :: Weather) migrate (undefined :: WeatherForecast) migrate (undefined :: WeatherForecastListing) + migrate (undefined :: WeatherDetailedWeatherListingItem) dbimport m = do -- First we insert the top-level weather record. @@ -297,9 +416,9 @@ instance DbImport Message where return ImportSucceeded ---- ---- Pickling ---- +-- +-- * Pickling +-- -- | Pickler to convert a 'WeatherForecastListingXml' to/from XML. -- @@ -345,19 +464,73 @@ pickle_forecast = +-- | (Un)pickle a 'WeatherDetailedWeatherListingItemXml'. +-- +pickle_item :: PU WeatherDetailedWeatherListingItemXml +pickle_item = + xpElem "Item" $ + xpWrap (from_tuple, to_tuple) $ + xp9Tuple (xpElem "Sportcode" xpText) + (xpElem "GameID" xpInt) + (xpElem "Gamedate" xp_datetime) + (xpElem "AwayTeam" xpText) + (xpElem "HomeTeam" xpText) + (xpElem "WeatherType" xpInt) + (xpElem "Description" xpText) + (xpElem "TempAdjust" xpText) + (xpElem "Temperature" xpInt) + where + from_tuple = uncurryN WeatherDetailedWeatherListingItemXml + to_tuple w = (xml_sport_code w, + xml_game_id w, + xml_dtl_game_date w, + xml_away_team w, + xml_home_team w, + xml_weather_type w, + xml_description w, + xml_temp_adjust w, + xml_temperature w) + + +-- | (Un)pickle a 'WeatherDetailedWeatherListingXml'. +-- +pickle_dw_listing :: PU WeatherDetailedWeatherListingXml +pickle_dw_listing = + xpElem "DW_Listing" $ + xpWrap (from_tuple, to_tuple) $ + xpTriple (xpAttr "SportCode" xpText) + (xpAttr "Sport" xpText) + (xpList pickle_item) + where + from_tuple = uncurryN WeatherDetailedWeatherListingXml + to_tuple w = (xml_dtl_listing_sport w, + xml_dtl_listing_sport_code w, + xml_items w) + + +-- | (Un)pickle a 'WeatherDetailedWeatherXml' +-- +pickle_detailed_weather :: PU WeatherDetailedWeatherXml +pickle_detailed_weather = + xpElem "Detailed_Weather" $ + xpWrap (WeatherDetailedWeatherXml, xml_detailed_listings) + (xpList pickle_dw_listing) + + -- | Pickler to convert a 'Message' to/from XML. -- pickle_message :: PU Message pickle_message = xpElem "message" $ xpWrap (from_tuple, to_tuple) $ - xp7Tuple + xp8Tuple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) (xpElem "category" xpText) (xpElem "sport" xpText) (xpElem "title" xpText) (xpList pickle_forecast) + (xpOption pickle_detailed_weather) (xpElem "time_stamp" xp_time_stamp) where from_tuple = uncurryN Message @@ -367,12 +540,13 @@ pickle_message = xml_sport, xml_title, xml_forecasts, + xml_detailed_weather, xml_time_stamp) + -- --- Tasty tests +-- * Tasty tests -- - weather_tests :: TestTree weather_tests = testGroup @@ -387,45 +561,61 @@ weather_tests = -- test does not mean that unpickling succeeded. -- test_pickle_of_unpickle_is_identity :: TestTree -test_pickle_of_unpickle_is_identity = - testCase "pickle composed with unpickle is the identity" $ do - let path = "test/xml/weatherxml.xml" - (expected, actual) <- pickle_unpickle pickle_message path - actual @?= expected +test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" + [ check "pickle composed with unpickle is the identity" + "test/xml/weatherxml.xml", + + check "pickle composed with unpickle is the identity (detailed)" + "test/xml/weatherxml-detailed.xml" ] + where + check desc path = testCase desc $ do + (expected, actual) <- pickle_unpickle pickle_message path + actual @?= expected -- | Make sure we can actually unpickle these things. -- test_unpickle_succeeds :: TestTree -test_unpickle_succeeds = - testCase "unpickling succeeds" $ do - let path = "test/xml/weatherxml.xml" - actual <- unpickleable path pickle_message - let expected = True - actual @?= expected +test_unpickle_succeeds = testGroup "unpickle tests" + [ check "unpickling succeeds" + "test/xml/weatherxml.xml", + check "unpickling succeeds (detailed)" + "test/xml/weatherxml-detailed.xml" ] + where + check desc path = testCase desc $ do + actual <- unpickleable path pickle_message + let expected = True + actual @?= expected -- | Make sure everything gets deleted when we delete the top-level -- record. -- test_on_delete_cascade :: TestTree -test_on_delete_cascade = - testCase "deleting weather deletes its children" $ do - let path = "test/xml/weatherxml.xml" - weather <- unsafe_unpickle path pickle_message - let a = undefined :: Weather - let b = undefined :: WeatherForecast - let c = undefined :: WeatherForecastListing - actual <- withSqliteConn ":memory:" $ runDbConn $ do - runMigration silentMigrationLogger $ do - migrate a - migrate b - migrate c - _ <- dbimport weather - deleteAll a - count_a <- countAll a - count_b <- countAll b - count_c <- countAll c - return $ count_a + count_b + count_c - let expected = 0 - actual @?= expected +test_on_delete_cascade = testGroup "cascading delete tests" + [ check "deleting weather deletes its children" + "test/xml/weatherxml.xml", + check "deleting weather deletes its children (detailed)" + "test/xml/weatherxml-detailed.xml" ] + where + check desc path = testCase desc $ do + weather <- unsafe_unpickle path pickle_message + let a = undefined :: Weather + let b = undefined :: WeatherForecast + let c = undefined :: WeatherForecastListing + let d = undefined :: WeatherDetailedWeatherListingItem + actual <- withSqliteConn ":memory:" $ runDbConn $ do + runMigration silentMigrationLogger $ do + migrate a + migrate b + migrate c + migrate d + _ <- dbimport weather + deleteAll a + count_a <- countAll a + count_b <- countAll b + count_c <- countAll c + count_d <- countAll d + return $ count_a + count_b + count_c + count_d + let expected = 0 + actual @?= expected diff --git a/test/shell/import-duplicates.test b/test/shell/import-duplicates.test index 1cefc53..247a996 100644 --- a/test/shell/import-duplicates.test +++ b/test/shell/import-duplicates.test @@ -15,15 +15,15 @@ rm -f shelltest.sqlite3 # Heartbeat.xml that doesn't really count. find ./test/xml -maxdepth 1 -name '*.xml' | wc -l >>> -21 +22 >>>= 0 # Run the imports again; we should get complaints about the duplicate -# xml_file_ids. There are 2 errors for each violation, so we expect 2*20 +# xml_file_ids. There are 2 errors for each violation, so we expect 2*21 # occurrences of the string 'ERROR'. ./dist/build/htsn-import/htsn-import -c 'shelltest.sqlite3' test/xml/*.xml 2>&1 | grep ERROR | wc -l >>> -40 +42 >>>= 0 # Finally, clean up after ourselves. diff --git a/test/xml/weatherxml-detailed.xml b/test/xml/weatherxml-detailed.xml new file mode 100644 index 0000000..6c86f4d --- /dev/null +++ b/test/xml/weatherxml-detailed.xml @@ -0,0 +1 @@ + 21379214 AAW%BBWEATHER Weather MLB Major League Baseball Weather from The Sports Network Chicago Cubs at Washington Nationals, 11:05 a.m. Mostly cloudy. Winds blowing in from left field at 10-15 m.p.h. Game-time temperature: Around 75. Philadelphia Phillies at Pittsburgh Pirates, 5:05 p.m. Sunny. Winds blowing out to right field at 10-15 m.p.h. Game-time temperature: Near 75. San Francisco Giants at San Diego Padres, 6:40 p.m. Partly cloudy. Winds blowing out to right field at 5-10 m.p.h. Game-time temperature: Around 75. Milwaukee Brewers at Cincinnati Reds, 7:10 p.m. Sunny. Winds blowing out to right field at 5-10 m.p.h. Game-time temperature: Near 75. Miami Marlins at St. Louis Cardinals, 7:15 p.m. Sunny. Winds blowing in from right field at 5-10 m.p.h. Game-time temperature: Near 80. Arizona Diamondbacks at Atlanta Braves, 7:35 p.m. Mostly sunny. Winds blowing in from left field at 5-10 m.p.h. Game-time temperature: Around 80. Los Angeles Dodgers at Colorado Rockies, 8:10 p.m. Partly cloudy with a 30-percent chance of rain. Winds blowing out to right field at 5-10 m.p.h. Game-time temperature: Around 80. Texas Rangers at New York Mets, 7:10 p.m. Partly cloudy. Winds blowing in from left field at 10-20 m.p.h. Game-time temperature: Near 75. Baltimore Orioles at Boston Red Sox, 1:35 p.m. Cloudy with a 90-percent chance of rain. Winds blowing in from left field at 10-15 m.p.h. Game-time temperature: Around 75. New York Yankees at Minnesota Twins, 3:10 p.m. Partly cloudy. Winds blowing in from right field at 10-15 m.p.h. Game-time temperature: Around 75. Toronto Blue Jays at Oakland Athletics, 4:05 p.m. Sunny. Winds blowing out to center field at 10-15 m.p.h. Game-time temperature: Around 65. Tampa Bay Rays at Detroit Tigers, 7:08 p.m. Sunny. Winds blowing out to right field at 5-10 m.p.h. Game-time temperature: Around 75. Kansas City Royals at Cleveland Indians, 7:05 p.m. Sunny. Winds blowing in from left field at 5-10 m.p.h. Game-time temperature: Near 70. Seattle Mariners at Chicago White Sox, 7:10 p.m. Sunny. Winds blowing in from center field at 5-10 m.p.h. Game-time temperature: Around 60. Houston Astros at LA Angels of Anaheim, 9:05 p.m. Mostly sunny. Winds blowing out to center field at 5-10 m.p.h. Game-time temperature: Around 80. AA 40439 7/4/2014 11:05:00 AM Chicago Cubs Washington Nationals 3 Mostly cloudy. Winds blowing in from left field at 10-15 m.p.h. Around 75 AA 40442 7/4/2014 5:05:00 PM Philadelphia Phillies Pittsburgh Pirates 0 Sunny. Winds blowing out to right field at 10-15 m.p.h. Near 75 AA 40445 7/4/2014 6:40:00 PM San Francisco Giants San Diego Padres 2 Partly cloudy. Winds blowing out to right field at 5-10 m.p.h. Around 75 AA 40443 7/4/2014 7:10:00 PM Milwaukee Brewers Cincinnati Reds 0 Sunny. Winds blowing out to right field at 5-10 m.p.h. Near 75 AA 40444 7/4/2014 7:15:00 PM Miami Marlins St. Louis Cardinals 0 Sunny. Winds blowing in from right field at 5-10 m.p.h. Near 80 AA 40441 7/4/2014 7:35:00 PM Arizona Diamondbacks Atlanta Braves 1 Mostly sunny. Winds blowing in from left field at 5-10 m.p.h. Around 80 AA 40446 7/4/2014 8:10:00 PM Los Angeles Dodgers Colorado Rockies 2 Partly cloudy with a 30-percent chance of rain. Winds blowing out to right field at 5-10 m.p.h. Around 80 AA 40440 7/4/2014 7:10:00 PM Texas Rangers New York Mets 2 Partly cloudy. Winds blowing in from left field at 10-20 m.p.h. Near 75 AA 40432 7/4/2014 1:35:00 PM Baltimore Orioles Boston Red Sox 3 Cloudy with a 90-percent chance of rain. Winds blowing in from left field at 10-15 m.p.h. Around 75 AA 40436 7/4/2014 3:10:00 PM New York Yankees Minnesota Twins 2 Partly cloudy. Winds blowing in from right field at 10-15 m.p.h. Around 75 AA 40437 7/4/2014 4:05:00 PM Toronto Blue Jays Oakland Athletics 0 Sunny. Winds blowing out to center field at 10-15 m.p.h. Around 65 AA 40434 7/4/2014 7:08:00 PM Tampa Bay Rays Detroit Tigers 0 Sunny. Winds blowing out to right field at 5-10 m.p.h. Around 75 AA 40433 7/4/2014 7:05:00 PM Kansas City Royals Cleveland Indians 0 Sunny. Winds blowing in from left field at 5-10 m.p.h. Near 70 AA 40435 7/4/2014 7:10:00 PM Seattle Mariners Chicago White Sox 0 Sunny. Winds blowing in from center field at 5-10 m.p.h. Around 60 AA 40438 7/4/2014 9:05:00 PM Houston Astros LA Angels of Anaheim 1 Mostly sunny. Winds blowing out to center field at 5-10 m.p.h. Around 80 AJ 1223 7/4/2014 7:00:00 PM British Columbia Lions Montreal Alouettes 2 Partly cloudy. Winds northwest at 5-10 m.p.h. Around 65 AJ 1224 7/4/2014 10:00:00 PM Hamilton Tiger-Cats Edmonton Eskimos 1 Mostly sunny. Winds northwest at 5-10 m.p.h. Around 70 AJ 1225 7/5/2014 3:00:00 PM Saskatchewan Roughriders Toronto Argonauts 0 Sunny. Winds west at 5-10 m.p.h. Near 80 July 4, 2014, at 08:53 AM ET \ No newline at end of file