From da0885d061b23f99a6c9d24b6b823c4654893d9c Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Wed, 1 Jan 2014 00:15:27 -0500 Subject: [PATCH] Create an ImportResult type and refactor things around it. Add Heartbeat support. --- src/Main.hs | 85 +++++++++++++++++++++------------------- src/TSN/DbImport.hs | 27 ++++++++----- src/TSN/XML/Heartbeat.hs | 72 ++++++++++++++++++++++++++++++++++ src/TSN/XML/News.hs | 9 ++--- test/TestSuite.hs | 4 +- 5 files changed, 140 insertions(+), 57 deletions(-) create mode 100644 src/TSN/XML/Heartbeat.hs 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 () diff --git a/src/TSN/DbImport.hs b/src/TSN/DbImport.hs index 8309255..3646d7c 100644 --- a/src/TSN/DbImport.hs +++ b/src/TSN/DbImport.hs @@ -2,27 +2,39 @@ module TSN.DbImport where -import Control.Monad.IO.Class ( MonadIO, liftIO ) +import Control.Monad.IO.Class ( MonadIO ) import Database.Groundhog ( defaultMigrationLogger, insert, migrate, runMigration ) import Database.Groundhog.Core ( PersistBackend, PersistEntity ) -import Network.Services.TSN.Report ( report_error ) import Text.XML.HXT.Core ( XmlPickler, XmlTree, unpickleDoc, xpickle ) + +-- | The type that will be returned from every file import attempt. If +-- there was an error, its description will be wrapped in an Err. If +-- we successfully imported records, the number of records imported +-- will be wrapped in a Succ. +-- +-- Anything else will be wrapped in a "Info" constructor; +-- i.e. somewhere between success and failure. This is like an +-- 'Either' with three choices. A "Info" return value means that +-- the XML document *was* processed, so it should be removed. +-- +data ImportResult = Err String | Info String | Succ Int + -- | Instances of this type know how to insert themselves into a -- Groundhog database. class DbImport a where dbimport :: (MonadIO m, PersistBackend m) => a -> XmlTree - -> m (Maybe Int) + -> m ImportResult -- | We put the 'Configuration' and 'XmlTree' arguments last so that @@ -33,15 +45,12 @@ import_generic :: (XmlPickler a, MonadIO m, PersistEntity b, PersistBackend m) => (a -> [b]) -- ^ listings getter -> b -- ^ Dummy Listing instance needed for 'migrate' -> XmlTree - -> m (Maybe Int) -- ^ Return the number of records inserted. + -> m ImportResult -- ^ Return the number of records inserted. import_generic g dummy xml = do runMigration defaultMigrationLogger $ migrate dummy let root_element = unpickleDoc xpickle xml case root_element of - Nothing -> do - let msg = "Could not unpickle document in import_generic." - liftIO $ report_error msg - return Nothing + Nothing -> return $ Err "Could not unpickle document in import_generic." Just elt -> do ids <- mapM insert (g elt) - return $ Just (length ids) + return $ Succ (length ids) diff --git a/src/TSN/XML/Heartbeat.hs b/src/TSN/XML/Heartbeat.hs new file mode 100644 index 0000000..c408483 --- /dev/null +++ b/src/TSN/XML/Heartbeat.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module TSN.XML.Heartbeat ( + heartbeat_tests, + verify ) +where + +import Data.Tuple.Curry ( uncurryN ) +import Test.Tasty ( TestTree, testGroup ) +import Test.Tasty.HUnit ( (@?=), testCase ) +import Text.XML.HXT.Core ( + PU, + unpickleDoc, + XmlPickler(..), + XmlTree, + xpTriple, + xpElem, + xpPrim, + xpText, + xpWrap ) + +import TSN.DbImport ( ImportResult(..) ) +import Xml ( pickle_unpickle ) + +data Message = + Message { + xml_file_id :: Int, + heading :: String, + time_stamp :: String } + deriving (Eq, Show) + +pickle_message :: PU Message +pickle_message = + xpElem "message" $ + xpWrap (from_tuple, to_tuple) $ + xpTriple (xpElem "XML_File_ID" xpPrim) + (xpElem "heading" xpText) + (xpElem "time_stamp" xpText) + where + from_tuple = uncurryN Message + to_tuple m = (xml_file_id m, + heading m, + time_stamp m) + +instance XmlPickler Message where + xpickle = pickle_message + + +-- | Verify (and report) the received heartbeat. We always return +-- Nothing to avoid spurious "successfully imported..." notices. +-- +verify :: XmlTree -> IO ImportResult +verify xml = do + let root_element = unpickleDoc xpickle xml :: Maybe Message + case root_element of + Nothing -> return $ Err "Could not unpickle document in import_generic." + Just _ -> return $ Info "Heartbeat received." + +-- * Tasty Tests +heartbeat_tests :: TestTree +heartbeat_tests = + testGroup + "Heartbeat tests" + [ test_pickle_of_unpickle_is_identity ] + + +test_pickle_of_unpickle_is_identity :: TestTree +test_pickle_of_unpickle_is_identity = + testCase "pickle composed with unpickle is the identity" $ do + let path = "test/xml/Heartbeat.xml" + (expected :: [Message], actual) <- pickle_unpickle "message" path + actual @?= expected diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs index 550f26c..bc443d2 100644 --- a/src/TSN/XML/News.hs +++ b/src/TSN/XML/News.hs @@ -17,7 +17,6 @@ module TSN.XML.News ( news_tests ) where -import Control.Monad.IO.Class ( MonadIO, liftIO ) import Data.Data ( Data, constrFields, dataTypeConstrs, dataTypeOf ) import Data.List.Utils ( join, split ) import Data.Tuple.Curry ( uncurryN ) @@ -48,12 +47,11 @@ import Text.XML.HXT.Core ( xpTriple, xpWrap ) -import Network.Services.TSN.Report ( report_error ) import TSN.Codegen ( tsn_codegen_config, tsn_db_field_namer -- Used in a test. ) -import TSN.DbImport ( DbImport(..) ) +import TSN.DbImport ( DbImport(..), ImportResult(..) ) import Xml ( ToFromXml(..), pickle_unpickle ) @@ -317,8 +315,7 @@ instance DbImport Message where case root_element of Nothing -> do let errmsg = "Could not unpickle News message in dbimport." - liftIO $ report_error errmsg - return Nothing + return $ Err errmsg Just message -> do news_id <- insert (from_xml message :: Message) let nts :: [NewsTeam] = map (from_xml_fk news_id) @@ -328,7 +325,7 @@ instance DbImport Message where nt_ids <- mapM insert nts loc_ids <- mapM insert nlocs - return $ Just (1 + (length nt_ids) + (length loc_ids)) + return $ Succ (1 + (length nt_ids) + (length loc_ids)) -- * Tasty Tests diff --git a/test/TestSuite.hs b/test/TestSuite.hs index 4446f8c..9e2e09c 100644 --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -1,5 +1,6 @@ import Test.Tasty ( TestTree, defaultMain, testGroup ) +import TSN.XML.Heartbeat ( heartbeat_tests ) import TSN.XML.Injuries ( injuries_tests ) import TSN.XML.InjuriesDetail ( injuries_detail_tests ) import TSN.XML.News ( news_tests ) @@ -7,7 +8,8 @@ import TSN.XML.News ( news_tests ) tests :: TestTree tests = testGroup "All tests" - [ injuries_tests, + [ heartbeat_tests, + injuries_tests, injuries_detail_tests, news_tests ] -- 2.43.2