diff --git a/doc/TODO b/doc/TODO --- a/doc/TODO +++ b/doc/TODO @@ -1,15 +1,9 @@ -1. Re-enable DTD validation once - https://github.com/UweSchmidt/hxt/issues/15 is fixed. - -2. Write a test for test/xml/Odds_XML-long-import.xml once it no - longer takes 10 minutes to import (Postgres only?). - -3. We have DTDs but no sample XML for the following SportInfo types, +1. We have DTDs but no sample XML for the following SportInfo types, which have therefore been left unimplmented for now: * CBASK_StealsXML.dtd -4. The following DTD types were handled (in some form) by the old +2. The following DTD types were handled (in some form) by the old FeedGrabber. They are not yet handled by htsn-import (some may not be valid): @@ -45,10 +39,13 @@ * WNBA_Individual_Stats_XML * WNBATeamScheduleXML -5. Consolidate all of the make_game_time functions which take a +3. Consolidate all of the make_game_time functions which take a date/time and produce a combined time. -6. Factor out test code where possible; a lot of them differ only in +4. Factor out test code where possible; a lot of them differ only in the filename. -7. Combine test XML files where possible. +5. Combine test XML files where possible. We don't need to e.g. import + two copies of newsxml just because one has an empty attribute that + we want to test: we could just delete an attribute from the first + file. 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.2.1 +version: 0.2.2 cabal-version: >= 1.8 author: Michael Orlitzky maintainer: Michael Orlitzky @@ -283,6 +283,7 @@ Configuration ConnectionString ExitCodes + Misc OptionalConfiguration TSN.Codegen TSN.Database diff --git a/schema/earlylineXML.dtd b/schema/earlylineXML.dtd --- a/schema/earlylineXML.dtd +++ b/schema/earlylineXML.dtd @@ -9,7 +9,7 @@ - + diff --git a/schema/nflstandxml.dtd b/schema/nflstandxml.dtd --- a/schema/nflstandxml.dtd +++ b/schema/nflstandxml.dtd @@ -6,7 +6,7 @@ - + diff --git a/schemagen/earlylineXML/22064237.xml b/schemagen/earlylineXML/22064237.xml new file mode 100644 --- /dev/null +++ b/schemagen/earlylineXML/22064237.xml @@ -0,0 +1,1 @@ + 22064237 ADO;NHL-EARLY-LINE Odds NHL National Hockey League Overnight Line Ottawa Over/Under: Pittsburgh Over/Under: Los Angeles Philadelphia Winnipeg NY Islanders 5.5o Minnesota Boston 5u Buffalo Toronto 5.5u Arizona Tampa Bay 5.5p St. Louis Dallas 5o Anaheim Chicago 5.5u San Jose Colorado 5.5p Montreal Calgary Carolina Vancouver 5.5u October 27, 2014, at 02:44 PM ET diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -22,6 +22,7 @@ import Text.XML.HXT.Core ( ArrowXml, IOStateArrow, + SysConfigList, XmlTree, (>>>), (/>), @@ -83,7 +84,7 @@ is_type1, pickle_message, teams_are_normal ) -import Xml ( DtdName(..), parse_opts ) +import Xml ( DtdName(..), parse_opts, parse_opts_novalidate ) -- | This is where most of the work happens. This function is called @@ -140,9 +141,11 @@ -- we couldn't parse the DTD. return [ImportFailed errdesc] - -- | An arrow that reads a document into an 'XmlTree'. - readA :: IOStateArrow s a XmlTree - readA = readDocument parse_opts path + -- | An arrow that reads a document into an 'XmlTree'. We take a + -- SysConfigList so our caller can decide whether or not to + -- e.g. validate the document against its DTD. + readA :: SysConfigList -> IOStateArrow s a XmlTree + readA scl = readDocument scl path -- | An arrow which parses the doctype "SYSTEM" of an 'XmlTree'. -- We use these to determine the parser to use. @@ -156,11 +159,27 @@ -- The result of runX has type IO [IO ImportResult]. We thus use -- bind (>>=) and sequence to combine all of the IOs into one -- big one outside of the list. + -- + -- Before we actually run the import, we check it against a list + -- of problem DTDs. These can produce weird errors, and we have + -- checks for them. But with DTD validation enabled, we can't + -- even look inside the document to see what's wrong -- parsing + -- will fail! So for those special document types, we proceed + -- using 'parse_opts_novalidate' instead of the default + -- 'parse_opts'. + -- parse_and_import :: IO [ImportResult] - parse_and_import = - runX (readA >>> (dtdnameA &&& returnA) >>> (arr import_with_dtd)) - >>= - sequence + parse_and_import = do + -- Get the DTD name without validating against it. + ((DtdName dtd) : _) <- runX $ (readA parse_opts_novalidate) >>> dtdnameA + + let problem_dtds = [ News.dtd, Weather.dtd ] + let opts = if dtd `elem` problem_dtds + then parse_opts_novalidate + else parse_opts + + runX ((readA opts) >>> (dtdnameA &&& returnA) >>> (arr import_with_dtd)) + >>= sequence -- | Takes a ('DtdName', 'XmlTree') pair and uses the 'DtdName' -- to determine which function to call on the 'XmlTree'. diff --git a/src/Misc.hs b/src/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Misc.hs @@ -0,0 +1,24 @@ +-- | Miscellaneous utility functions +module Misc ( + double_just ) +where + +-- | If given 'Nothing', return 'Nothing'. Otherwise wrap our argument +-- in another 'Just'. This is used when handling optional XML +-- elements that are optionally empty. If the element is missing, we +-- want 'Nothing'. And if the contents are missing, we want +-- 'Nothing' then too. But if something is present, we need @Just +-- (Just foo)@ for the types to match up. +-- +-- ==== __Examples__: +-- +-- >>> double_just Nothing +-- Nothing +-- >>> double_just (Just 2) +-- Just (Just 2) +-- +double_just :: (Maybe a) -> Maybe (Maybe a) +double_just val = + case val of + Nothing -> Nothing + just_something -> Just just_something diff --git a/src/TSN/DbImport.hs b/src/TSN/DbImport.hs --- a/src/TSN/DbImport.hs +++ b/src/TSN/DbImport.hs @@ -27,12 +27,11 @@ import Control.Monad.IO.Class ( MonadIO( liftIO ) ) import qualified Data.Map as Map ( elems ) import Database.Groundhog ( executeRaw ) -import Database.Groundhog.Core ( NamedMigrations ) import Database.Groundhog.Generic ( createMigration, getQueries, mergeMigrations ) -import Database.Groundhog.Core ( Migration, PersistBackend ) +import Database.Groundhog.Core ( Migration, NamedMigrations, PersistBackend ) import Network.Services.TSN.Report ( report_info ) diff --git a/src/TSN/Picklers.hs b/src/TSN/Picklers.hs --- a/src/TSN/Picklers.hs +++ b/src/TSN/Picklers.hs @@ -1,9 +1,12 @@ +{-# LANGUAGE ScopedTypeVariables #-} + -- | (Un)picklers for data types present in The Sports Network XML -- feed. -- module TSN.Picklers ( pickler_tests, xp_ambiguous_time, + xp_attr_option, xp_date, xp_date_padded, xp_datetime, @@ -568,6 +571,23 @@ upper_suffix = map toUpper (date_suffix t) fmt = "%A, %B %-d" ++ upper_suffix ++ " (" ++ date_format_padded ++ ")" + +-- | This is a replacement for @xpOption xpFoo@ within an 'xpAttr'. +-- There's a bug in +-- newer versions of HXT that prevents us from using the usual +-- 'xpOption' solution, so this is our stopgap. It should work on +-- any type that can be unpickled with a plain read/show. +-- +xp_attr_option :: forall a. (Read a, Show a) => PU (Maybe a) +xp_attr_option = + (to_a, from_a) `xpWrap` xpText + where + to_a :: String -> Maybe a + to_a = readMaybe + + from_a :: Maybe a -> String + from_a Nothing = "" + from_a (Just x) = show x -- | Create an 'XmlTree' containing only the given text. This is diff --git a/src/TSN/XML/EarlyLine.hs b/src/TSN/XML/EarlyLine.hs --- a/src/TSN/XML/EarlyLine.hs +++ b/src/TSN/XML/EarlyLine.hs @@ -67,10 +67,12 @@ xpWrap ) -- Local imports. +import Misc ( double_just ) import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) import TSN.Picklers ( xp_ambiguous_time, + xp_attr_option, xp_early_line_date, xp_time_stamp ) import TSN.XmlImport ( XmlImport(..) ) @@ -559,7 +561,7 @@ pickle_team :: PU EarlyLineGameTeamXml pickle_team = xpWrap (from_tuple, to_tuple') $ - xp6Tuple (xpAttr "rotation" (xpOption xpInt)) + xp6Tuple (xpAttr "rotation" xp_attr_option) (xpOption $ xpAttr "line" (xpOption xpText)) (xpOption $ xpAttr "name" xpText) (xpOption xpText) @@ -571,10 +573,6 @@ to_tuple' (EarlyLineGameTeamXml u v w x y z) = (u, double_just v, w, x, double_just y, double_just z) - where - double_just val = case val of - Nothing -> Nothing - just_something -> Just just_something diff --git a/src/TSN/XML/JFile.hs b/src/TSN/XML/JFile.hs --- a/src/TSN/XML/JFile.hs +++ b/src/TSN/XML/JFile.hs @@ -23,7 +23,7 @@ where -- System imports -import Control.Monad ( forM_ ) +import Control.Monad ( forM_, join ) import Data.List ( intercalate ) import Data.String.Utils ( split ) import Data.Time ( UTCTime(..) ) @@ -61,6 +61,7 @@ -- Local imports +import Misc ( double_just ) import TSN.Codegen ( tsn_codegen_config ) import TSN.Database ( insert_or_select ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) @@ -458,7 +459,7 @@ pickle_game :: PU JFileGameXml pickle_game = xpElem "game" $ - xpWrap (from_tuple, H.convert) $ + xpWrap (from_tuple, to_tuple') $ xp14Tuple (xpElem "game_id" xpInt) (xpElem "schedule_id" xpInt) pickle_odds_info @@ -466,7 +467,7 @@ (xpElem "Game_Date" xp_date_padded) (xpElem "Game_Time" xp_tba_time) pickle_away_team - (xpOption $ xpElem "vleague" xpText) + (xpOption $ xpElem "vleague" (xpOption xpText)) pickle_home_team (xpOption $ xpElem "hleague" xpText) (xpElem "vscore" xpInt) @@ -474,7 +475,11 @@ (xpOption $ xpElem "time_r" xpText) pickle_status where - from_tuple = uncurryN JFileGameXml + from_tuple (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = + JFileGameXml a b c d e f g (join h) i j k l m n + + to_tuple' (JFileGameXml a b c d e f g h i j k l m n) = + (a, b, c, d, e, f, g, double_just h, i, j, k, l, m, n) pickle_odds_info :: PU JFileGameOddsInfo diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs --- a/src/TSN/XML/News.hs +++ b/src/TSN/XML/News.hs @@ -72,7 +72,7 @@ import TSN.Database ( insert_or_select ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) import TSN.Location ( Location(..), pickle_location ) -import TSN.Picklers ( xp_time_stamp ) +import TSN.Picklers ( xp_attr_option, xp_time_stamp ) import TSN.Team ( Team(..) ) import TSN.XmlImport ( XmlImport(..) ) import Xml ( @@ -80,7 +80,7 @@ ToDb(..), pickle_unpickle, unpickleable, - unsafe_read_document, + unsafe_read_invalid_document, unsafe_unpickle ) @@ -389,7 +389,7 @@ pickle_msg_id = xpElem "msg_id" $ xpWrap (from_tuple, H.convert) $ - xpPair xpInt (xpAttr "EventId" (xpOption xpInt)) + xpPair xpInt (xpAttr "EventId" xp_attr_option) where from_tuple = uncurryN MsgId @@ -574,6 +574,6 @@ False ] where check path desc expected = testCase desc $ do - xmltree <- unsafe_read_document path + xmltree <- unsafe_read_invalid_document path let actual = has_only_single_sms xmltree actual @?= expected diff --git a/src/TSN/XML/Odds.hs b/src/TSN/XML/Odds.hs --- a/src/TSN/XML/Odds.hs +++ b/src/TSN/XML/Odds.hs @@ -66,7 +66,11 @@ import TSN.Codegen ( tsn_codegen_config ) import TSN.Database ( insert_or_select ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) -import TSN.Picklers ( xp_date_padded, xp_tba_time, xp_time_stamp ) +import TSN.Picklers ( + xp_attr_option, + xp_date_padded, + xp_tba_time, + xp_time_stamp ) import TSN.Team ( FromXmlFkTeams(..), Team(..) ) import TSN.XmlImport ( XmlImport(..), XmlImportFkTeams(..) ) import Xml ( @@ -648,7 +652,7 @@ xpElem "Casino" $ xpWrap (from_tuple, H.convert) $ xpTriple - (xpAttr "ClientID" $ xpOption xpInt) + (xpAttr "ClientID" xp_attr_option) (xpAttr "Name" $ xpOption xpText) (xpOption xpText) where @@ -805,7 +809,10 @@ "test/xml/Odds_XML-tba-game-time.xml", check "pickle composed with unpickle is the identity (empty casino)" - "test/xml/Odds_XML-empty-casino.xml" ] + "test/xml/Odds_XML-empty-casino.xml", + + check "pickle composed with unpickle is the identity (long import)" + "test/xml/Odds_XML-long-import.xml" ] where check desc path = testCase desc $ do (expected, actual) <- pickle_unpickle pickle_message path @@ -838,7 +845,10 @@ "test/xml/Odds_XML-tba-game-time.xml", check "unpickling succeeds (empty casino)" - "test/xml/Odds_XML-empty-casino.xml" ] + "test/xml/Odds_XML-empty-casino.xml", + + check "unpickling succeeds (long-import)" + "test/xml/Odds_XML-long-import.xml" ] where check desc path = testCase desc $ do actual <- unpickleable path pickle_message @@ -885,6 +895,10 @@ check "deleting odds deleted its children (empty casino)" "test/xml/Odds_XML-empty-casino.xml" 11 -- 5 casinos, 6 teams + , + check "deleting odds deleted its children (long import)" + "test/xml/Odds_XML-long-import.xml" + 219 -- 5 casinos, 214 teams ] where check desc path expected = testCase desc $ do diff --git a/src/TSN/XML/Scores.hs b/src/TSN/XML/Scores.hs --- a/src/TSN/XML/Scores.hs +++ b/src/TSN/XML/Scores.hs @@ -57,11 +57,12 @@ xpWrap ) -- Local imports. +import Misc ( double_just ) import TSN.Codegen ( tsn_codegen_config ) import TSN.Database ( insert_or_select ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) import TSN.Location ( Location(..), pickle_location ) -import TSN.Picklers ( xp_time_stamp ) +import TSN.Picklers ( xp_attr_option, xp_time_stamp ) import TSN.Team ( FromXmlFkTeams(..), HTeam(..), @@ -444,17 +445,13 @@ pickle_status = xpElem "status" $ xpWrap (from_tuple, to_tuple') $ - xpTriple (xpAttr "numeral" $ xpOption xpInt) + xpTriple (xpAttr "numeral" xp_attr_option) (xpOption $ xpAttr "type" $ xpOption xpText) xpText where from_tuple (x,y,z) = ScoreGameStatus x (join y) z to_tuple' ScoreGameStatus{..} = - (db_status_numeral, s, db_status_text) - where - s = case db_status_type of - Nothing -> Nothing - Just _ -> Just db_status_type + (db_status_numeral, double_just db_status_type, db_status_text) -- | Convert a 'ScoreGameXml' to/from \. @@ -522,8 +519,7 @@ (xpOption xpText) -- Team name where from_tuple (x,y,z)= HTeamXml (HTeam (Team x Nothing z)) (join y) - to_tuple' (HTeamXml (HTeam t) Nothing) = (team_id t, Nothing, name t) - to_tuple' (HTeamXml (HTeam t) jhp) = (team_id t, Just jhp, name t) + to_tuple' (HTeamXml (HTeam t) jhp) = (team_id t, double_just jhp, name t) 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 @@ -80,7 +80,7 @@ ToDb(..), pickle_unpickle, unpickleable, - unsafe_read_document, + unsafe_read_invalid_document, unsafe_unpickle ) @@ -743,7 +743,7 @@ False ] where check path desc expected = testCase desc $ do - xmltree <- unsafe_read_document path + xmltree <- unsafe_read_invalid_document path let actual = is_type1 xmltree actual @?= expected @@ -764,6 +764,6 @@ False ] where check desc path expected = testCase desc $ do - xmltree <- unsafe_read_document path + xmltree <- unsafe_read_invalid_document path let actual = teams_are_normal xmltree actual @?= expected diff --git a/src/Xml.hs b/src/Xml.hs --- a/src/Xml.hs +++ b/src/Xml.hs @@ -10,9 +10,11 @@ FromXmlFk(..), ToDb(..), parse_opts, + parse_opts_novalidate, pickle_unpickle, unpickleable, unsafe_read_document, + unsafe_read_invalid_document, unsafe_unpickle ) where @@ -97,10 +99,16 @@ -- parse_opts :: SysConfigList parse_opts = [ withRemoveWS yes, - withSubstDTDEntities no, - withValidate no ] + withSubstDTDEntities no ] +-- | Like 'parse_opts' except we don't validate the document against +-- its DTD. This is useful when we need to parse a document that we +-- /know/ is invalid so that we can deliver a better error message. +-- +parse_opts_novalidate :: SysConfigList +parse_opts_novalidate = (withValidate no) : parse_opts + -- | Given an @unpickler@ and a @filepath@, attempt to unpickle the -- root element of @filepath@ using @unpickler@ and return both the -- original unpickled object and one constructed by pickling and @@ -174,3 +182,10 @@ unsafe_read_document :: FilePath -> IO XmlTree unsafe_read_document filepath = fmap head $ runX $ readDocument parse_opts filepath + +-- | The same as 'unsafe_read_document', except it allows you to read +-- documents which don't validate against their DTDs. +-- +unsafe_read_invalid_document :: FilePath -> IO XmlTree +unsafe_read_invalid_document filepath = + fmap head $ runX $ readDocument parse_opts_novalidate filepath diff --git a/test/Doctests.hs b/test/Doctests.hs --- a/test/Doctests.hs +++ b/test/Doctests.hs @@ -9,5 +9,6 @@ main :: IO () main = doctest [ "-isrc", "-idist/build/autogen", + "src/Misc.hs", "src/TSN/Codegen.hs", "src/TSN/Picklers.hs"] diff --git a/test/xml/Odds_XML.dtd b/test/xml/Odds_XML.dtd --- a/test/xml/Odds_XML.dtd +++ b/test/xml/Odds_XML.dtd @@ -13,12 +13,12 @@ - + - + @@ -28,11 +28,12 @@ of anything in any order. We know that the first couple of elements are required and appear in a fixed order. --> - - + + + + + + diff --git a/test/xml/earlylineXML.dtd b/test/xml/earlylineXML.dtd --- a/test/xml/earlylineXML.dtd +++ b/test/xml/earlylineXML.dtd @@ -9,7 +9,7 @@ - + diff --git a/test/xml/scoresxml.dtd b/test/xml/scoresxml.dtd --- a/test/xml/scoresxml.dtd +++ b/test/xml/scoresxml.dtd @@ -2,26 +2,28 @@ - + + + + - + - - - - - + + + + - + diff --git a/test/xml/sportinfo/nflstandxml.dtd b/test/xml/sportinfo/nflstandxml.dtd --- a/test/xml/sportinfo/nflstandxml.dtd +++ b/test/xml/sportinfo/nflstandxml.dtd @@ -6,7 +6,7 @@ - +