X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FMain.hs;h=7932bf353f014d83b86eb83f7600d779dd2539f7;hb=da0885d061b23f99a6c9d24b6b823c4654893d9c;hp=9a9532124e53273ad0b2b475acd8df51151ed6cf;hpb=0e37f70a58d512858b38e1458c6d83bc1727269c;p=dead%2Fhtsn-import.git diff --git a/src/Main.hs b/src/Main.hs index 9a95321..7932bf3 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -7,7 +7,6 @@ import Control.Arrow ( (&&&), arr, returnA ) import Control.Concurrent ( threadDelay ) import Control.Exception ( SomeException, catch ) import Control.Monad ( when ) -import Control.Monad.IO.Class ( MonadIO, liftIO ) import Database.Groundhog.Generic ( runDbConn ) import Database.Groundhog.Sqlite ( withSqliteConn ) @@ -42,7 +41,8 @@ import qualified OptionalConfiguration as OC ( import Network.Services.TSN.Report ( report_info, report_error ) -import TSN.DbImport +import TSN.DbImport ( DbImport(..), ImportResult(..) ) +import qualified TSN.XML.Heartbeat as Heartbeat ( verify ) import qualified TSN.XML.Injuries as Injuries ( Listing ) import qualified TSN.XML.InjuriesDetail as InjuriesDetail ( PlayerListing ) import qualified TSN.XML.News as News ( Message ) @@ -58,22 +58,24 @@ import_file cfg path = do [] -> do report_error $ "Unable to determine DTD for file " ++ path ++ "." return False - (r:_) -> - case r of - Nothing -> return False - Just cnt -> do - report_info $ "Successfully imported " ++ - (show cnt) ++ - " records from " ++ path ++ "." - return True + (Err errmsg:_) -> do + report_error errmsg + return False + (Info infomsg:_) -> do + report_info infomsg + return True + (Succ count:_) -> do + report_info $ "Successfully imported " ++ (show count) ++ + " records from " ++ path ++ "." + return True where - exception_handler :: SomeException -> IO [Maybe Int] + exception_handler :: SomeException -> IO [ImportResult] exception_handler e = do report_error (show e) - report_error $ "Failed to import file " ++ path ++ "." + let errdesc = "Failed to import file " ++ path ++ "." -- Return a nonempty list so we don't claim incorrectly that -- we couldn't parse the DTD. - return [Nothing] + return [Err errdesc] -- | An arrow that reads a document into an 'XmlTree'. readA :: IOStateArrow s a XmlTree @@ -88,10 +90,10 @@ import_file cfg path = do -- (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 (Maybe Int)]. We thus use + -- 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 [Maybe Int] + parse_and_import :: IO [ImportResult] parse_and_import = runX (readA >>> (doctypeA &&& returnA) >>> (arr import_with_dtd)) >>= @@ -99,32 +101,33 @@ import_file cfg path = do -- | Takes a 'Doctype', 'XmlTree' pair and uses the 'Doctype' to -- determine which function to call on the 'XmlTree'. - import_with_dtd :: (String, XmlTree) -> IO (Maybe Int) - import_with_dtd (dtd,xml) = - -- We need NoMonomorphismRestriction here. - if backend cfg == Postgres - then withPostgresqlConn cs $ runDbConn $ importer xml - else withSqliteConn cs $ runDbConn $ importer xml - where - -- | Pull the real connection String out of the configuration. - cs :: String - cs = get_connection_string $ connection_string cfg - - importer - | dtd == "injuriesxml.dtd" = - dbimport (undefined :: Injuries.Listing) - - | dtd == "Injuries_Detail_XML.dtd" = - dbimport (undefined :: InjuriesDetail.PlayerListing) - - | dtd == "newsxml.dtd" = - dbimport (undefined :: News.Message) - - | otherwise = \_ -> do -- Dummy arg simplifies the other cases. - let errmsg = "Unrecognized DTD in " ++ path ++ ": " ++ dtd ++ "." - liftIO $ report_info errmsg - return Nothing - + import_with_dtd :: (String, XmlTree) -> IO ImportResult + import_with_dtd (dtd,xml) + | dtd == "Heartbeat.dtd" = Heartbeat.verify xml + | otherwise = + -- We need NoMonomorphismRestriction here. + if backend cfg == Postgres + then withPostgresqlConn cs $ runDbConn $ importer xml + else withSqliteConn cs $ runDbConn $ importer xml + where + -- | Pull the real connection String out of the configuration. + cs :: String + cs = get_connection_string $ connection_string cfg + + importer + | dtd == "injuriesxml.dtd" = + dbimport (undefined :: Injuries.Listing) + + | dtd == "Injuries_Detail_XML.dtd" = + dbimport (undefined :: InjuriesDetail.PlayerListing) + + | dtd == "newsxml.dtd" = + dbimport (undefined :: News.Message) + + | otherwise = \_ -> do -- Dummy arg simplifies the other cases. + let infomsg = + "Unrecognized DTD in " ++ path ++ ": " ++ dtd ++ "." + return $ Info infomsg main :: IO ()