Heartbeat.hs

   1 {-# LANGUAGE ScopedTypeVariables #-}
   2
   3 -- | Handle documents defined by Heartbeat.dtd.
   4 --
   5 module TSN.XML.Heartbeat (
   6   verify,
   7   -- * Tests
   8   heartbeat_tests )
   9 where
  10
  11 -- System imports.
  12 import Data.Tuple.Curry ( uncurryN )
  13 import Test.Tasty ( TestTree, testGroup )
  14 import Test.Tasty.HUnit ( (@?=), testCase )
  15 import Text.XML.HXT.Core (
  16   PU,
  17   unpickleDoc,
  18   XmlTree,
  19   xpTriple,
  20   xpElem,
  21   xpInt,
  22   xpText,
  23   xpWrap )
  24
  25 -- Local imports.
  26 import TSN.DbImport ( ImportResult(..) )
  27 import Xml ( pickle_unpickle, unpickleable )
  28
  29
  30 -- | The data structure that holds the XML representation of a
  31 --   Heartbeat message.
  32 --
  33 data Message =
  34   Message {
  35     xml_file_id :: Int,
  36     heading :: String,
  37     time_stamp :: String }
  38   deriving (Eq, Show)
  39
  40
  41 -- | A (un)pickler that turns a Heartbeat XML file into a 'Message'
  42 --   and vice-versa.
  43 --
  44 pickle_message :: PU Message
  45 pickle_message =
  46   xpElem "message" $
  47     xpWrap (from_tuple, to_tuple) $
  48     xpTriple (xpElem "XML_File_ID" xpInt)
  49              (xpElem "heading" xpText)
  50              (xpElem "time_stamp" xpText)
  51   where
  52     from_tuple = uncurryN Message
  53     to_tuple m = (xml_file_id m,
  54                   heading m,
  55                   time_stamp m)
  56
  57
  58 -- | Verify (and report) the received heartbeat. We return
  59 --   'ImportSkipped' because we want to indicate that we processed the
  60 --   file but there was nothing to import.
  61 --
  62 verify :: XmlTree -> IO ImportResult
  63 verify xml = do
  64   let root_element = unpickleDoc pickle_message xml
  65   return $ case root_element of
  66     Nothing -> ImportFailed "Could not unpickle document to be verified."
  67     Just _  -> ImportSkipped "Heartbeat received. Thump."
  68
  69 --
  70 -- Tasty Tests
  71 --
  72
  73 -- | A list of all tests for this module.
  74 --
  75 heartbeat_tests :: TestTree
  76 heartbeat_tests =
  77   testGroup
  78     "Heartbeat tests"
  79     [ test_pickle_of_unpickle_is_identity,
  80       test_unpickle_succeeds ]
  81
  82
  83 -- | If we unpickle something and then pickle it, we should wind up
  84 --   with the same thing we started with. WARNING: success of this
  85 --   test does not mean that unpickling succeeded.
  86 --
  87 test_pickle_of_unpickle_is_identity :: TestTree
  88 test_pickle_of_unpickle_is_identity =
  89   testCase "pickle composed with unpickle is the identity" $ do
  90     let path = "test/xml/Heartbeat.xml"
  91     (expected :: [Message], actual) <- pickle_unpickle pickle_message path
  92     actual @?= expected
  93
  94
  95 -- | Make sure we can unpickle the sample file.
  96 --
  97 test_unpickle_succeeds :: TestTree
  98 test_unpickle_succeeds =
  99   testCase "unpickling succeeds" $ do
 100   let path = "test/xml/Heartbeat.xml"
 101   actual <- unpickleable path pickle_message
 102   let expected = True
 103   actual @?= expected