Heartbeat.hs

{-# LANGUAGE ScopedTypeVariables #-}

-- | Handle documents defined by Heartbeat.dtd.
--
module TSN.XML.Heartbeat (
  dtd,
  verify,
  -- * Tests
  heartbeat_tests )
where

-- System imports.
import Data.Tuple.Curry ( uncurryN )
import Test.Tasty ( TestTree, testGroup )
import Test.Tasty.HUnit ( (@?=), testCase )
import Text.XML.HXT.Core (
  PU,
  unpickleDoc,
  XmlTree,
  xpTriple,
  xpElem,
  xpInt,
  xpText,
  xpWrap )

-- Local imports.
import TSN.DbImport ( ImportResult(..) )
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 }
  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" xpInt)
             (xpElem "heading" xpText)
             (xpElem "time_stamp" xpText)
  where
    from_tuple = uncurryN Message
    to_tuple m = (xml_file_id m,
                  heading m,
                  time_stamp m)


-- | 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 pickle_message xml
  return $ case root_element of
    Nothing -> ImportFailed "Could not unpickle document to be verified."
    Just _  -> ImportSkipped "Heartbeat received. Thump."

--
-- 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_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 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