- doctypeA :: ArrowXml a => a XmlTree String
- doctypeA = getAttrl >>> hasName "doctype-SYSTEM" /> getText
-
- -- | Takes a 'Doctype', 'XmlTree' pair and uses the 'Doctype' to
- -- determine which function to call on the 'XmlTree'.
- import_with_dtd :: (String, XmlTree) -> IO ()
- import_with_dtd (dtd,xml)
- | dtd == "injuriesxml.dtd" = import_injuries xml
- | dtd == "Injuries_Detail_XML.dtd" = import_injuries_detail xml
- | otherwise = report_info $
- "Unrecognized DTD in " ++ path ++ ": " ++ dtd ++ "."
-
-
+ 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.
+ parse_and_import :: IO [ImportResult]
+ parse_and_import =
+ runX (readA >>> (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
+
+ importer
+ | dtd == "injuriesxml.dtd" = do
+ let m = unpickleDoc Injuries.pickle_message xml
+ let errmsg = "Could not unpickle injuriesxml."
+ maybe (return $ ImportFailed errmsg) migrate_and_import m
+
+ | dtd == "Injuries_Detail_XML.dtd" = do
+ let m = unpickleDoc InjuriesDetail.pickle_message xml
+ let errmsg = "Could not unpickle Injuries_Detail_XML."
+ maybe (return $ ImportFailed errmsg) migrate_and_import m
+
+
+ | dtd == "newsxml.dtd" = do
+ let m = unpickleDoc News.pickle_message xml
+ let errmsg = "Could not unpickle newsxml."
+ maybe (return $ ImportFailed errmsg) migrate_and_import m
+
+ | dtd == "Odds_XML.dtd" = do
+ let m = unpickleDoc Odds.pickle_message xml
+ let errmsg = "Could not unpickle Odds_XML."
+ maybe (return $ ImportFailed errmsg) migrate_and_import m
+
+ | otherwise = do
+ let infomsg =
+ "Unrecognized DTD in " ++ path ++ ": " ++ dtd ++ "."
+ return $ ImportUnsupported infomsg
+
+
+-- | Entry point of the program. It twiddles some knobs for
+-- configuration options and then calls 'import_file' on each XML
+-- file given on the command-line.
+--
+-- Any file successfully processed is then optionally removed, and
+-- we're done.
+--