src/TSN/XML/Heartbeat.hs

   1 {-# LANGUAGE ScopedTypeVariables #-}
   2
   3 module TSN.XML.Heartbeat (
   4   heartbeat_tests,
   5   verify )
   6 where
   7
   8 import Data.Tuple.Curry ( uncurryN )
   9 import Test.Tasty ( TestTree, testGroup )
  10 import Test.Tasty.HUnit ( (@?=), testCase )
  11 import Text.XML.HXT.Core (
  12   PU,
  13   unpickleDoc,
  14   XmlPickler(..),
  15   XmlTree,
  16   xpTriple,
  17   xpElem,
  18   xpPrim,
  19   xpText,
  20   xpWrap )
  21
  22 import TSN.DbImport ( ImportResult(..) )
  23 import Xml ( pickle_unpickle, unpickleable )
  24
  25 data Message =
  26   Message {
  27     xml_file_id :: Int,
  28     heading :: String,
  29     time_stamp :: String }
  30   deriving (Eq, Show)
  31
  32 pickle_message :: PU Message
  33 pickle_message =
  34   xpElem "message" $
  35     xpWrap (from_tuple, to_tuple) $
  36     xpTriple (xpElem "XML_File_ID" xpPrim)
  37              (xpElem "heading" xpText)
  38              (xpElem "time_stamp" xpText)
  39   where
  40     from_tuple = uncurryN Message
  41     to_tuple m = (xml_file_id m,
  42                   heading m,
  43                   time_stamp m)
  44
  45 instance XmlPickler Message where
  46   xpickle = pickle_message
  47
  48
  49 -- | Verify (and report) the received heartbeat. We always return
  50 --   Nothing to avoid spurious "successfully imported..." notices.
  51 --
  52 verify :: XmlTree -> IO ImportResult
  53 verify xml = do
  54   let root_element = unpickleDoc xpickle xml :: Maybe Message
  55   return $ case root_element of
  56     Nothing -> ImportFailed "Could not unpickle document in import_generic."
  57     Just _  -> ImportSkipped "Heartbeat received. Thump."
  58
  59 -- * Tasty Tests
  60 heartbeat_tests :: TestTree
  61 heartbeat_tests =
  62   testGroup
  63     "Heartbeat tests"
  64     [ test_pickle_of_unpickle_is_identity,
  65       test_unpickle_succeeds ]
  66
  67
  68 -- | Warning, succeess of this test does not mean that unpickling
  69 --   succeeded.
  70 test_pickle_of_unpickle_is_identity :: TestTree
  71 test_pickle_of_unpickle_is_identity =
  72   testCase "pickle composed with unpickle is the identity" $ do
  73     let path = "test/xml/Heartbeat.xml"
  74     (expected :: [Message], actual) <- pickle_unpickle "message" path
  75     actual @?= expected
  76
  77
  78 test_unpickle_succeeds :: TestTree
  79 test_unpickle_succeeds =
  80   testCase "unpickling succeeds" $ do
  81   let path = "test/xml/Heartbeat.xml"
  82   actual <- unpickleable path pickle_message
  83   let expected = True
  84   actual @?= expected