]> gitweb.michael.orlitzky.com - dead/htsn-import.git/blob - src/TSN/XML/Heartbeat.hs
Migrate TSN.XML.InjuriesDetail to fixed-vector-hetero.
[dead/htsn-import.git] / 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 GHC.Generics as GHC ( Generic )
17 import Test.Tasty ( TestTree, testGroup )
18 import Test.Tasty.HUnit ( (@?=), testCase )
19 import Text.XML.HXT.Core (
20 PU,
21 unpickleDoc,
22 XmlTree,
23 xpTriple,
24 xpElem,
25 xpInt,
26 xpText,
27 xpWrap )
28
29 -- Local imports.
30 import Generics ( Generic(..), to_tuple )
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 'Generics.to_tuple'.
52 --
53 instance Generic 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, to_tuple) $
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