Create an ImportResult type and refactor things around it.

[dead/htsn-import.git] / src / Main.hs

diff --git a/src/Main.hs b/src/Main.hs
index 9a9532124e53273ad0b2b475acd8df51151ed6cf..7932bf353f014d83b86eb83f7600d779dd2539f7 100644 (file)
--- 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 ()