src/TSN/XML/Heartbeat.hs

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