src/TSN/XML/Heartbeat.hs

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