diff --git a/doc/dbschema/AutoRacingResultsXML.png b/doc/dbschema/AutoRacingResultsXML.png Binary files a/doc/dbschema/AutoRacingResultsXML.png and b/doc/dbschema/AutoRacingResultsXML.png differ diff --git a/doc/dbschema/weatherxml.png b/doc/dbschema/weatherxml.png Binary files a/doc/dbschema/weatherxml.png and b/doc/dbschema/weatherxml.png differ diff --git a/htsn-import.cabal b/htsn-import.cabal --- a/htsn-import.cabal +++ b/htsn-import.cabal @@ -1,5 +1,5 @@ name: htsn-import -version: 0.1.0 +version: 0.1.1 cabal-version: >= 1.8 author: Michael Orlitzky maintainer: Michael Orlitzky diff --git a/schema/AutoRacingResultsXML.dtd b/schema/AutoRacingResultsXML.dtd --- a/schema/AutoRacingResultsXML.dtd +++ b/schema/AutoRacingResultsXML.dtd @@ -25,7 +25,7 @@ - + diff --git a/schemagen/AutoRacingResultsXML/21777587.xml b/schemagen/AutoRacingResultsXML/21777587.xml new file mode 100644 --- /dev/null +++ b/schemagen/AutoRacingResultsXML/21777587.xml @@ -0,0 +1,1 @@ + 21777587 ASX%BUSCH-FINAL-RESULTS Statistics NASCAR-B 1731 9/13/2014 3:30:00 PM NASCAR - Nationwide - Jimmy John's Freaky Fast 300 - Final Results Chicagoland Speedway - Joliet, IL 0 False 1.5 200 September 13, 2014, at 03:36 PM ET diff --git a/src/TSN/Parse.hs b/src/TSN/Parse.hs --- a/src/TSN/Parse.hs +++ b/src/TSN/Parse.hs @@ -184,15 +184,15 @@ --- | The format string for a time_stamp. We keep the leading/trailing --- space so that parseTime and formatTime are inverses are one --- another, even though there is some confusion as to how these two --- functions should behave: +-- | The format string for a time_stamp. We have removed the +-- leading/trailing space so that parseTime and formatTime are NOT +-- inverses of one another. We should be able to rectify this once +-- everything is updated to support time-1.5. See, -- -- -- time_stamp_format :: String -time_stamp_format = " %B %-d, %Y, at " ++ time_format ++ " ET " +time_stamp_format = "%B %-d, %Y, at " ++ time_format ++ " ET" diff --git a/src/TSN/Picklers.hs b/src/TSN/Picklers.hs --- a/src/TSN/Picklers.hs +++ b/src/TSN/Picklers.hs @@ -270,8 +270,8 @@ -- -- >>> import Data.Maybe ( fromJust ) -- >>> :{ --- let parse_date :: String -> Maybe UTCTime; --- parse_date = parseTime defaultTimeLocale date_format; +-- let parse_date :: String -> Maybe UTCTime +-- parse_date = parseTime defaultTimeLocale date_format -- :} -- -- >>> let dates = [ "1/" ++ (d : "/1970") | d <- ['1'..'9'] ] @@ -474,9 +474,12 @@ xp_time_stamp = (parse_time_stamp, from_time_stamp) `xpWrapMaybe` xpText where + -- | We have to re-pad the time_stamp_format with a leading and + -- trailing space; see the documentation of 'time_stamp_format' + -- for more information. from_time_stamp :: UTCTime -> String from_time_stamp = - formatTime defaultTimeLocale time_stamp_format + formatTime defaultTimeLocale (" " ++ time_stamp_format ++ " ") diff --git a/src/TSN/XML/AutoRacingResults.hs b/src/TSN/XML/AutoRacingResults.hs --- a/src/TSN/XML/AutoRacingResults.hs +++ b/src/TSN/XML/AutoRacingResults.hs @@ -46,6 +46,7 @@ xp11Tuple, xp13Tuple, xpAttr, + xpDefault, xpElem, xpInt, xpList, @@ -259,17 +260,27 @@ -- the \"db_\" prefix since our field namer is going to strip of -- everything before the first underscore. -- +-- We make the three fields optional because the entire +-- \ is apparently optional (although it is +-- usually present). A 'Nothing' in the XML should get turned into +-- three 'Nothing's in the DB. +-- data MostLapsLeading = MostLapsLeading { - db_most_laps_leading_driver_id :: Int, - db_most_laps_leading_driver :: String, - db_most_laps_leading_number_of_laps :: Int } + db_most_laps_leading_driver_id :: Maybe Int, + db_most_laps_leading_driver :: Maybe String, + db_most_laps_leading_number_of_laps :: Maybe Int } deriving (Data, Eq, Show, Typeable) -- | Database representation of a \ contained -- within a \. -- +-- The 'db_most_laps_leading' field is not optional because when we +-- convert from our XML representation, a missing 'MostLapsLeading' +-- will be replaced with a 'MostLapsLeading' with three missing +-- fields. +-- data AutoRacingResultsRaceInformation = AutoRacingResultsRaceInformation { -- Note the apostrophe to disambiguate it from the @@ -306,7 +317,7 @@ xml_cautions :: Maybe String, xml_lead_changes :: Maybe String, xml_lap_leaders :: Maybe String, - xml_most_laps_leading :: MostLapsLeading } + xml_most_laps_leading :: Maybe MostLapsLeading } deriving (Eq,Show) @@ -345,8 +356,15 @@ db_cautions = xml_cautions, db_lead_changes = xml_lead_changes, db_lap_leaders = xml_lap_leaders, - db_most_laps_leading = xml_most_laps_leading } - + db_most_laps_leading = most_laps_leading } + where + -- If we didn't get a \, indicate that in + -- the database with an (embedded) 'MostLapsLeading' with three + -- missing fields. + most_laps_leading = + case xml_most_laps_leading of + Just mll -> mll + Nothing -> MostLapsLeading Nothing Nothing Nothing -- | This allows us to insert the XML representation -- 'AutoRacingResultsRaceInformationXml' directly. @@ -507,24 +525,52 @@ -- | Pickler for the \ child of a --- \. +-- \. This is complicated by the fact that the +-- three fields we're trying to parse are not actually optional; +-- only the entire \ is. So we always wrap what +-- we parse in a 'Just', and when converting from the DB to XML, +-- we'll drop the entire element if any of its fields are missing +-- (which they never should be). -- -pickle_most_laps_leading :: PU MostLapsLeading +pickle_most_laps_leading :: PU (Maybe MostLapsLeading) pickle_most_laps_leading = xpElem "Most_Laps_Leading" $ xpWrap (from_tuple, to_tuple) $ - xpTriple (xpElem "DriverID" xpInt) - (xpElem "Driver" xpText) - (xpElem "NumberOfLaps" xpInt) + xpTriple (xpOption $ xpElem "DriverID" xpInt) + (xpOption $ xpElem "Driver" xpText) + (xpOption $ xpElem "NumberOfLaps" xpInt) where - from_tuple = uncurryN MostLapsLeading - to_tuple m = (db_most_laps_leading_driver_id m, - db_most_laps_leading_driver m, - db_most_laps_leading_number_of_laps m) + from_tuple :: (Maybe Int, Maybe String, Maybe Int) -> Maybe MostLapsLeading + from_tuple (Just x, Just y, Just z) = + Just $ MostLapsLeading (Just x) (Just y) (Just z) + from_tuple _ = Nothing + -- Sure had to go out of my way to avoid the warnings about unused + -- db_most_laps_foo fields here. + to_tuple :: Maybe MostLapsLeading -> (Maybe Int, Maybe String, Maybe Int) + to_tuple Nothing = (Nothing, Nothing, Nothing) + to_tuple (Just (MostLapsLeading Nothing _ _)) = (Nothing, Nothing, Nothing) + to_tuple (Just (MostLapsLeading _ Nothing _)) = (Nothing, Nothing, Nothing) + to_tuple (Just (MostLapsLeading _ _ Nothing)) = (Nothing, Nothing, Nothing) + to_tuple (Just m) = (db_most_laps_leading_driver_id m, + db_most_laps_leading_driver m, + db_most_laps_leading_number_of_laps m) + -- | Pickler for the \ child of \. -- +-- There's so much voodoo going on here. We have a double-layered +-- Maybe on top of the MostLapsLeading. When unpickling, we return a +-- Nothing (i.e. a Maybe MostLapsLeading) if any of its fields are +-- missing. But if the entire element is missing, unpickling +-- fails. 'xpOption' doesn't fix this because it would give us a +-- Maybe (Maybe MostLapsLeading). But we can use 'xpDefault' with a +-- default of (Nothing :: Maybe MostLapsLeading) to stick one in +-- there if unpicking a (Maybe MostLapsLeading) fails because +-- \ is missing. +-- +-- Clear as mud, I know. +-- pickle_race_information :: PU AutoRacingResultsRaceInformationXml pickle_race_information = xpElem "Race_Information" $ @@ -544,7 +590,7 @@ (xpOption $ xpElem "Cautions" xpText) (xpOption $ xpElem "LeadChanges" xpText) (xpOption $ xpElem "LapLeaders" xpText) - pickle_most_laps_leading + (xpDefault Nothing pickle_most_laps_leading) where -- Derp. Since the first two are paired, we have to -- manually unpack the bazillion arguments. @@ -589,7 +635,10 @@ "test/xml/AutoRacingResultsXML.xml", check "pickle composed with unpickle is the identity (fractional KPH)" - "test/xml/AutoRacingResultsXML-fractional-kph.xml" ] + "test/xml/AutoRacingResultsXML-fractional-kph.xml", + + check "pickle composed with unpickle is the identity (No Most_Laps_Leading)" + "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml"] where check desc path = testCase desc $ do (expected, actual) <- pickle_unpickle pickle_message path @@ -605,7 +654,10 @@ "test/xml/AutoRacingResultsXML.xml", check "unpickling succeeds (fractional KPH)" - "test/xml/AutoRacingResultsXML-fractional-kph.xml" ] + "test/xml/AutoRacingResultsXML-fractional-kph.xml", + + check "unpickling succeeds (no Most_Laps_Leading)" + "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml" ] where check desc path = testCase desc $ do actual <- unpickleable path pickle_message @@ -623,7 +675,11 @@ "test/xml/AutoRacingResultsXML.xml", check "deleting auto_racing_results deletes its children (fractional KPH)" - "test/xml/AutoRacingResultsXML-fractional-kph.xml" ] + "test/xml/AutoRacingResultsXML-fractional-kph.xml", + + check ("deleting auto_racing_results deletes its children " ++ + "(No Most_Laps_Leading)") + "test/xml/AutoRacingResultsXML-no-most-laps-leading.xml" ] where check desc path = testCase desc $ do results <- unsafe_unpickle path pickle_message diff --git a/src/TSN/XML/Weather.hs b/src/TSN/XML/Weather.hs --- a/src/TSN/XML/Weather.hs +++ b/src/TSN/XML/Weather.hs @@ -101,7 +101,7 @@ data WeatherForecastListingXml = WeatherForecastListingXml { xml_teams :: String, - xml_weather :: String } + xml_weather :: Maybe String } deriving (Eq, Show) @@ -114,7 +114,7 @@ db_weather_forecasts_id :: DefaultKey WeatherForecast, db_league_name :: Maybe String, db_teams :: String, - db_weather :: String } + db_weather :: Maybe String } -- | We don't make 'WeatherForecastListingXml' an instance of @@ -247,7 +247,7 @@ db_away_team :: String, db_home_team :: String, db_weather_type :: Int, - db_description :: String, + db_description :: Maybe String, db_temp_adjust :: Maybe String, db_temperature :: Int } @@ -263,7 +263,7 @@ xml_away_team :: String, xml_home_team :: String, xml_weather_type :: Int, - xml_description :: String, + xml_description :: Maybe String, xml_temp_adjust :: Maybe String, xml_temperature :: Int } deriving (Eq, Show) @@ -506,8 +506,9 @@ xpWrap (from_pair, to_pair) $ xpPair (xpElem "teams" xpText) - (xpElem "weather" xpText) + (xpElem "weather" (xpOption xpText)) where +-- from_pair (ts, Nothing) = WeatherForecastListingXml ts (Just "") from_pair = uncurry WeatherForecastListingXml to_pair WeatherForecastListingXml{..} = (xml_teams, xml_weather) @@ -554,7 +555,7 @@ (xpElem "AwayTeam" xpText) (xpElem "HomeTeam" xpText) (xpElem "WeatherType" xpInt) - (xpElem "Description" xpText) + (xpElem "Description" (xpOption xpText)) (xpElem "TempAdjust" (xpOption xpText)) (xpElem "Temperature" xpInt) where @@ -660,7 +661,9 @@ [ check "unpickling succeeds" "test/xml/weatherxml.xml", check "unpickling succeeds (detailed)" - "test/xml/weatherxml-detailed.xml" ] + "test/xml/weatherxml-detailed.xml", + check "unpickling succeeds (empty weather)" + "test/xml/weatherxml-empty-weather.xml"] where check desc path = testCase desc $ do actual <- unpickleable path pickle_message @@ -676,7 +679,9 @@ [ check "deleting weather deletes its children" "test/xml/weatherxml.xml", check "deleting weather deletes its children (detailed)" - "test/xml/weatherxml-detailed.xml" ] + "test/xml/weatherxml-detailed.xml", + check "deleting weather deletes its children (empty weather)" + "test/xml/weatherxml-empty-weather.xml"] where check desc path = testCase desc $ do weather <- unsafe_unpickle path pickle_message @@ -712,6 +717,9 @@ True, check "test/xml/weatherxml-detailed.xml" "first type detected correctly (detailed)" + True, + check "test/xml/weatherxml-empty-weather.xml" + "first type detected correctly (empty weather)" True, check "test/xml/weatherxml-type2.xml" "second type detected correctly" diff --git a/test/shell/import-duplicates.test b/test/shell/import-duplicates.test --- a/test/shell/import-duplicates.test +++ b/test/shell/import-duplicates.test @@ -16,15 +16,15 @@ # and a newsxml that aren't really supposed to import. find ./test/xml -maxdepth 1 -name '*.xml' | wc -l >>> -30 +32 >>>= 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*26 +# xml_file_ids. There are 2 errors for each violation, so we expect 2*28 # occurrences of the string 'ERROR'. ./dist/build/htsn-import/htsn-import -c 'shelltest.sqlite3' test/xml/*.xml 2>&1 | grep ERROR | wc -l >>> -52 +56 >>>= 0 # Finally, clean up after ourselves. diff --git a/test/xml/AutoRacingResultsXML-no-most-laps-leading.xml b/test/xml/AutoRacingResultsXML-no-most-laps-leading.xml new file mode 100644 --- /dev/null +++ b/test/xml/AutoRacingResultsXML-no-most-laps-leading.xml @@ -0,0 +1,1 @@ + 21777587 ASX%BUSCH-FINAL-RESULTS Statistics NASCAR-B 1731 9/13/2014 3:30:00 PM NASCAR - Nationwide - Jimmy John's Freaky Fast 300 - Final Results Chicagoland Speedway - Joliet, IL 0 False 1.5 200 September 13, 2014, at 03:36 PM ET diff --git a/test/xml/AutoRacingResultsXML.dtd b/test/xml/AutoRacingResultsXML.dtd --- a/test/xml/AutoRacingResultsXML.dtd +++ b/test/xml/AutoRacingResultsXML.dtd @@ -25,7 +25,7 @@ - + diff --git a/test/xml/weatherxml-empty-weather.xml b/test/xml/weatherxml-empty-weather.xml new file mode 100644 --- /dev/null +++ b/test/xml/weatherxml-empty-weather.xml @@ -0,0 +1,1 @@ + 21812233 AAW%BBWEATHER Weather MLB Major League Baseball Weather from The Sports Network Washington Nationals at Miami Marlins, 7:10 p.m. Partly cloudy with a 60-percent chance of rain. Winds blowing in from right field at 5-10 m.p.h. Game-time temperature: Around 80. Los Angeles Dodgers at Chicago Cubs, 8:05 p.m. Clear. Winds blowing in from center field at 5-10 m.p.h. Game-time temperature: Around 60. Milwaukee Brewers at St. Louis Cardinals, 8:15 p.m. Clear. Winds blowing in from center field at 5-10 m.p.h. Game-time temperature: Around 70. Arizona Diamondbacks at Colorado Rockies, 8:40 p.m. Clear. Winds blowing out to left field at 10-15 m.p.h. Game-time temperature: Around 85. Philadelphia Phillies at San Diego Padres, 9:10 p.m. Partly cloudy. Winds blowing in from left field at 10-15 m.p.h. Game-time temperature: Around 75. Boston Red Sox at Pittsburgh Pirates, 7:05 p.m. Partly cloudy. Winds blowing out to right field at 5-10 m.p.h. Game-time temperature: Around 65. Texas Rangers at Oakland Athletics, 3:35 p.m. Cloudy with a 40-percent chance of rain. Winds blowing out to center field at 5-10 m.p.h. Game-time temperature: Around 70. Toronto Blue Jays at New York Yankees, 7:05 p.m. Partly cloudy. Winds blowing out to right field at 5-10 m.p.h. Game-time temperature: Around 70. Cleveland Indians at Houston Astros, 8:10 p.m. Partly cloudy with a 70-percent chance of rain. Winds blowing out to left field at 5-10 m.p.h. Game-time temperature: Around 80. Seattle Mariners at LA Angels of Anaheim, 10:05 p.m. Clear. Winds blowing out to left field at 5-10 m.p.h. Game-time temperature: Around 80. Cleveland Indians at Kansas City Royals, 6:05 p.m. AA 41428 9/18/2014 7:10:00 PM Washington Nationals Miami Marlins 2 Partly cloudy with a 60-percent chance of rain. Winds blowing in from right field at 5-10 m.p.h. Around 80 AA 41430 9/18/2014 8:05:00 PM Los Angeles Dodgers Chicago Cubs 10 Clear. Winds blowing in from center field at 5-10 m.p.h. Around 60 AA 41431 9/18/2014 8:15:00 PM Milwaukee Brewers St. Louis Cardinals 10 Clear. Winds blowing in from center field at 5-10 m.p.h. Around 70 AA 41433 9/18/2014 8:40:00 PM Arizona Diamondbacks Colorado Rockies 10 Clear. Winds blowing out to left field at 10-15 m.p.h. Around 85 AA 41432 9/18/2014 9:10:00 PM Philadelphia Phillies San Diego Padres 2 Partly cloudy. Winds blowing in from left field at 10-15 m.p.h. Around 75 AA 41429 9/18/2014 7:05:00 PM Boston Red Sox Pittsburgh Pirates 2 Partly cloudy. Winds blowing out to right field at 5-10 m.p.h. Around 65 AA 41426 9/18/2014 3:35:00 PM Texas Rangers Oakland Athletics 3 Cloudy with a 40-percent chance of rain. Winds blowing out to center field at 5-10 m.p.h. Around 70 AA 41424 9/18/2014 7:05:00 PM Toronto Blue Jays New York Yankees 2 Partly cloudy. Winds blowing out to right field at 5-10 m.p.h. Around 70 AA 41425 9/18/2014 8:10:00 PM Cleveland Indians Houston Astros 2 Partly cloudy with a 70-percent chance of rain. Winds blowing out to left field at 5-10 m.p.h. Around 80 AA 41427 9/18/2014 10:05:00 PM Seattle Mariners LA Angels of Anaheim 10 Clear. Winds blowing out to left field at 5-10 m.p.h. Around 80 AA 41180 9/22/2014 6:05:00 PM Cleveland Indians Kansas City Royals 11 0 AB 4631 9/18/2014 8:25:00 PM Tampa Bay Buccaneers Atlanta Falcons 11 Game is being played inside a dome. 0 AJ 1247 9/19/2014 10:00:00 PM Toronto Argonauts British Columbia Lions 2 Partly cloudy. Winds southeast at 5-10 m.p.h. Near 65 AF 42695 9/18/2014 7:30:00 PM Auburn Kansas State 2 Partly cloudy. Winds southeast at 10-15 m.p.h. Around 75 AF 44032 9/19/2014 8:00:00 PM Connecticut So Florida 2 Partly cloudy with a 50-percent chance of rain. Winds northeast at 5-10 m.p.h. Around 80 September 18, 2014, at 09:19 AM ET