1 {-# LANGUAGE DeriveGeneric #-}
2 {-# LANGUAGE ScopedTypeVariables #-}
4 -- | Handle documents defined by Heartbeat.dtd.
6 module TSN.XML.Heartbeat (
14 import Data.Time.Clock ( UTCTime )
15 import Data.Tuple.Curry ( uncurryN )
16 import qualified GHC.Generics as GHC ( Generic )
17 import Test.Tasty ( TestTree, testGroup )
18 import Test.Tasty.HUnit ( (@?=), testCase )
19 import Text.XML.HXT.Core (
30 import Generics ( Generic(..), to_tuple )
31 import TSN.DbImport ( ImportResult(..) )
32 import TSN.Picklers ( xp_time_stamp )
33 import Xml ( pickle_unpickle, unpickleable )
36 -- | The DTD to which this module corresponds.
41 -- | The data structure that holds the XML representation of a
49 deriving (Eq, GHC.Generic, Show)
51 -- | For 'Generics.to_tuple'.
53 instance Generic Message
56 -- | A (un)pickler that turns a Heartbeat XML file into a 'Message'
59 pickle_message :: PU Message
62 xpWrap (from_tuple, to_tuple) $
63 xpTriple (xpElem "XML_File_ID" xpInt)
64 (xpElem "heading" xpText)
65 (xpElem "time_stamp" xp_time_stamp)
67 from_tuple = uncurryN Message
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.
74 verify :: XmlTree -> IO ImportResult
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."
85 -- | A list of all tests for this module.
87 heartbeat_tests :: TestTree
91 [ test_pickle_of_unpickle_is_identity,
92 test_unpickle_succeeds ]
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.
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
107 -- | Make sure we can unpickle the sample file.
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