X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FHeartbeat.hs;h=8fafba1c6c80d6435793a1345ab733329ebfc9a9;hb=22ef5496c109815e1c97d9350181b4a96145fb94;hp=c408483f6e2af23e33ade6113be0470a79752a96;hpb=da0885d061b23f99a6c9d24b6b823c4654893d9c;p=dead%2Fhtsn-import.git

diff --git a/src/TSN/XML/Heartbeat.hs b/src/TSN/XML/Heartbeat.hs
index c408483..8fafba1 100644
--- a/src/TSN/XML/Heartbeat.hs
+++ b/src/TSN/XML/Heartbeat.hs
@@ -1,72 +1,111 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 
+-- | Handle documents defined by Heartbeat.dtd.
+--
 module TSN.XML.Heartbeat (
-  heartbeat_tests,
-  verify )
+  dtd,
+  verify,
+  -- * Tests
+  heartbeat_tests )
 where
 
+-- System imports.
+import Data.Time.Clock ( UTCTime )
 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,
+  xpInt,
   xpText,
   xpWrap )
 
+-- Local imports.
 import TSN.DbImport ( ImportResult(..) )
-import Xml ( pickle_unpickle )
+import TSN.Picklers ( xp_time_stamp )
+import Xml ( pickle_unpickle, unpickleable )
+
+
+-- | The DTD to which this module corresponds.
+--
+dtd :: String
+dtd = "Heartbeat.dtd"
 
+-- | The data structure that holds the XML representation of a
+--   Heartbeat message.
+--
 data Message =
   Message {
     xml_file_id :: Int,
     heading :: String,
-    time_stamp :: String }
+    time_stamp :: UTCTime }
   deriving (Eq, Show)
 
+
+-- | A (un)pickler that turns a Heartbeat XML file into a 'Message'
+--   and vice-versa.
+--
 pickle_message :: PU Message
 pickle_message =
   xpElem "message" $
     xpWrap (from_tuple, to_tuple) $
-    xpTriple (xpElem "XML_File_ID" xpPrim)
+    xpTriple (xpElem "XML_File_ID" xpInt)
              (xpElem "heading" xpText)
-             (xpElem "time_stamp" xpText)
+             (xpElem "time_stamp" xp_time_stamp)
   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 (and report) the received heartbeat. We return
+--   'ImportSkipped' because we want to indicate that we processed the
+--   file but there was nothing to import.
 --
 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."
+  let root_element = unpickleDoc pickle_message xml
+  return $ case root_element of
+    Nothing -> ImportFailed "Could not unpickle document to be verified."
+    Just _  -> ImportSkipped "Heartbeat received. Thump."
 
--- * Tasty Tests
+--
+-- Tasty Tests
+--
+
+-- | A list of all tests for this module.
+--
 heartbeat_tests :: TestTree
 heartbeat_tests =
   testGroup
     "Heartbeat tests"
-    [ test_pickle_of_unpickle_is_identity ]
+    [ test_pickle_of_unpickle_is_identity,
+      test_unpickle_succeeds ]
 
 
+-- | If we unpickle something and then pickle it, we should wind up
+--   with the same thing we started with. WARNING: success of this
+--   test does not mean that unpickling succeeded.
+--
 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
+    (expected :: [Message], actual) <- pickle_unpickle pickle_message path
     actual @?= expected
+
+
+-- | Make sure we can unpickle the sample file.
+--
+test_unpickle_succeeds :: TestTree
+test_unpickle_succeeds =
+  testCase "unpickling succeeds" $ do
+  let path = "test/xml/Heartbeat.xml"
+  actual <- unpickleable path pickle_message
+  let expected = True
+  actual @?= expected