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