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