Add Heartbeat support.
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 )
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 )
[] -> 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
-- (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))
>>=
-- | 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 ()
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
=> (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)
--- /dev/null
+{-# 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
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 )
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 )
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)
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
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 )
tests :: TestTree
tests = testGroup
"All tests"
- [ injuries_tests,
+ [ heartbeat_tests,
+ injuries_tests,
injuries_detail_tests,
news_tests ]
projects / dead / htsn-import.git / commitdiff