+ dtdnameA :: ArrowXml a => a XmlTree DtdName
+ dtdnameA = getAttrl >>> hasName "doctype-SYSTEM" /> getText >>^ DtdName
+
+ -- | Combine the arrows above as well as the function below
+ -- (arrowized with 'arr') into an IO action that does everything
+ -- (parses and then runs the import on what was parsed).
+ --
+ -- 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 = 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'.
+ import_with_dtd :: (DtdName, XmlTree) -> IO ImportResult
+ import_with_dtd (DtdName dtd,xml)
+ -- We special-case the heartbeat so it doesn't have to run in
+ -- the database monad.
+ | dtd == Heartbeat.dtd = Heartbeat.verify xml
+ | otherwise =
+ -- We need NoMonomorphismRestriction here.
+ if backend cfg == Postgres
+ then withPostgresqlConn cs $ runDbConn importer
+ else withSqliteConn cs $ runDbConn importer
+ where
+ -- | Pull the real connection String out of the configuration.
+ --
+ cs :: String
+ cs = get_connection_string $ connection_string cfg
+
+ -- | Convenience; we use this everywhere below in 'importer'.
+ --
+ migrate_and_import m = dbmigrate m >> dbimport m
+
+ -- | The error message we return if unpickling fails.
+ --
+ errmsg = "Could not unpickle " ++ dtd ++ "."
+
+ -- | Try to migrate and import using the given pickler @f@;
+ -- if it works, return the result. Otherwise, return an
+ -- 'ImportFailed' along with our error message.
+ --
+ go f = maybe
+ (return $ ImportFailed errmsg)
+ migrate_and_import
+ (unpickleDoc f xml)
+
+ importer
+ | dtd == AutoRacingDriverList.dtd =
+ go AutoRacingDriverList.pickle_message
+
+ | dtd == AutoRacingResults.dtd =
+ go AutoRacingResults.pickle_message
+
+ | dtd == AutoRacingSchedule.dtd =
+ go AutoRacingSchedule.pickle_message
+
+ | dtd == EarlyLine.dtd =
+ go EarlyLine.pickle_message
+
+ -- GameInfo and SportInfo appear last in the guards
+ | dtd == Injuries.dtd = go Injuries.pickle_message
+
+ | dtd == InjuriesDetail.dtd = go InjuriesDetail.pickle_message
+
+ | dtd == JFile.dtd = go JFile.pickle_message