]> gitweb.michael.orlitzky.com - dead/htsn-import.git/blob - src/TSN/XML/Injuries.hs
Add a minor TODO note.
[dead/htsn-import.git] / src / TSN / XML / Injuries.hs
1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE GADTs #-}
4 {-# LANGUAGE QuasiQuotes #-}
5 {-# LANGUAGE RecordWildCards #-}
6 {-# LANGUAGE StandaloneDeriving #-}
7 {-# LANGUAGE TemplateHaskell #-}
8 {-# LANGUAGE TypeFamilies #-}
9
10 -- | Parse TSN XML for the DTD "injuriesxml.dtd". Each document
11 -- contains a root element \<message\> that in turn contains zero or
12 -- more \<listing\>s.
13 --
14 -- The listings will be mapped to a database table called
15 -- \"injuries_listings\" automatically. The root message is retained
16 -- so that we can easily delete its associated listings based on its
17 -- time_stamp.
18 --
19 module TSN.XML.Injuries (
20 dtd,
21 pickle_message,
22 -- * Tests
23 injuries_tests,
24 -- * WARNING: these are private but exported to silence warnings
25 InjuriesConstructor(..),
26 InjuriesListingConstructor(..) )
27 where
28
29 -- System imports.
30 import Data.Data ( Data )
31 import Data.Time ( UTCTime )
32 import Data.Typeable ( Typeable )
33 import Database.Groundhog (
34 countAll,
35 deleteAll,
36 migrate,
37 runMigration,
38 silentMigrationLogger )
39 import Database.Groundhog.Core ( DefaultKey )
40 import Database.Groundhog.Generic ( runDbConn )
41 import Database.Groundhog.TH (
42 groundhog,
43 mkPersist )
44 import Database.Groundhog.Sqlite ( withSqliteConn )
45 import Data.Tuple.Curry ( uncurryN )
46 import Test.Tasty ( TestTree, testGroup )
47 import Test.Tasty.HUnit ( (@?=), testCase )
48 import Text.XML.HXT.Core (
49 PU,
50 xp4Tuple,
51 xp6Tuple,
52 xpAttrImplied,
53 xpElem,
54 xpInt,
55 xpList,
56 xpOption,
57 xpPair,
58 xpPrim,
59 xpText,
60 xpWrap )
61
62 -- Local imports.
63 import TSN.Codegen ( tsn_codegen_config )
64 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
65 import TSN.Picklers ( xp_time_stamp )
66 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
67 import Xml (
68 FromXml(..),
69 FromXmlFk(..),
70 ToDb(..),
71 pickle_unpickle,
72 unpickleable,
73 unsafe_unpickle )
74
75
76
77 -- | The DTD to which this module corresponds. Used to invoke dbimport.
78 --
79 dtd :: String
80 dtd = "injuriesxml.dtd"
81
82 --
83 -- DB/XML Data types
84 --
85
86 -- * InjuriesTeam
87
88 -- | XML/Database representation of a team as they appear in the
89 -- injuries documents.
90 --
91 data InjuriesTeam =
92 InjuriesTeam {
93 db_team_name :: String,
94 db_team_league :: Maybe String }
95 deriving (Data, Eq, Show, Typeable)
96
97
98 -- * InjuriesListing/InjuriesListingXml
99
100 -- | XML representation of the injury listings.
101 --
102 data InjuriesListingXml =
103 InjuriesListingXml {
104 xml_team :: InjuriesTeam,
105 xml_teamno :: Maybe Int,
106 xml_injuries :: String,
107 xml_updated :: Maybe Bool }
108 deriving (Eq, Show)
109
110 -- | Database representation of a 'InjuriesListing'. It possesses a
111 -- foreign key to an 'Injuries' object so that we can easily delete
112 -- 'InjuriesListing's based on the parent message's time_stamp.
113 --
114 data InjuriesListing =
115 InjuriesListing {
116 db_injuries_id :: DefaultKey Injuries,
117 db_team :: InjuriesTeam,
118 db_teamno :: Maybe Int,
119 db_injuries :: String,
120 db_updated :: Maybe Bool }
121
122 instance ToDb InjuriesListingXml where
123 -- | The DB analogue of a 'InjuriesListingXml' is a 'InjuriesListing'
124 type Db InjuriesListingXml = InjuriesListing
125
126 instance FromXmlFk InjuriesListingXml where
127 -- | Our foreign key points to an 'Injuries'.
128 type Parent InjuriesListingXml = Injuries
129
130 -- | To convert between a 'InjuriesListingXml' and a
131 -- 'InjuriesListing', we simply append the foreign key.
132 from_xml_fk fk InjuriesListingXml{..} =
133 InjuriesListing {
134 db_injuries_id = fk,
135 db_team = xml_team,
136 db_teamno = xml_teamno,
137 db_injuries = xml_injuries,
138 db_updated = xml_updated }
139
140 -- | This allows us to insert the XML representation
141 -- 'InjuriesListingXml' directly.
142 --
143 instance XmlImportFk InjuriesListingXml
144
145
146 -- * Injuries/Message
147
148 -- | XML representation of an injuriesxml \<message\>.
149 --
150 data Message =
151 Message {
152 xml_xml_file_id :: Int,
153 xml_heading :: String,
154 xml_category :: String,
155 xml_sport :: String,
156 xml_listings :: [InjuriesListingXml],
157 xml_time_stamp :: UTCTime }
158 deriving (Eq, Show)
159
160 -- | Database representation of a 'Message'.
161 --
162 data Injuries =
163 Injuries {
164 db_xml_file_id :: Int,
165 db_sport :: String,
166 db_time_stamp :: UTCTime }
167
168 instance ToDb Message where
169 -- | The database analogue of a 'Message' is an 'Injuries'.
170 type Db Message = Injuries
171
172 instance FromXml Message where
173 -- | To convert from XML to DB, we simply drop the fields we don't
174 -- care about.
175 --
176 from_xml Message{..} =
177 Injuries {
178 db_xml_file_id = xml_xml_file_id,
179 db_sport = xml_sport,
180 db_time_stamp = xml_time_stamp }
181
182 -- | This allows us to insert the XML representation 'Message'
183 -- directly.
184 --
185 instance XmlImport Message
186
187
188 --
189 -- Database code
190 --
191
192 instance DbImport Message where
193 dbmigrate _ =
194 run_dbmigrate $ do
195 migrate (undefined :: Injuries)
196 migrate (undefined :: InjuriesListing)
197
198 -- | We import a 'Message' by inserting all of its 'listings', but
199 -- the listings require a foreign key to the parent 'Message'.
200 --
201 dbimport msg = do
202 msg_id <- insert_xml msg
203
204 -- Convert each XML listing to a DB one using the message id and
205 -- insert it (disregarding the result).
206 mapM_ (insert_xml_fk_ msg_id) (xml_listings msg)
207
208 return ImportSucceeded
209
210
211 mkPersist tsn_codegen_config [groundhog|
212 - entity: Injuries
213 constructors:
214 - name: Injuries
215 uniques:
216 - name: unique_injuries
217 type: constraint
218 # Prevent multiple imports of the same message.
219 fields: [db_xml_file_id]
220
221 - entity: InjuriesListing
222 dbName: injuries_listings
223 constructors:
224 - name: InjuriesListing
225 fields:
226 - name: db_team
227 embeddedType:
228 - {name: team_name, dbName: team_name}
229 - {name: team_league, dbName: team_league}
230 - name: db_injuries_id
231 reference:
232 onDelete: cascade
233
234 - embedded: InjuriesTeam
235 fields:
236 - name: db_team_name
237 - name: db_team_league
238 |]
239
240
241 --
242 -- XML Picklers
243 --
244
245
246 -- | A pickler for 'InjuriesTeam's that can convert them to/from XML.
247 --
248 pickle_injuries_team :: PU InjuriesTeam
249 pickle_injuries_team =
250 xpElem "team" $
251 xpWrap (from_tuple, to_tuple) $
252 xpPair xpText (xpAttrImplied "league" xpText)
253 where
254 from_tuple = uncurryN InjuriesTeam
255 to_tuple m = (db_team_name m, db_team_league m)
256
257
258 -- | A pickler for 'InjuriesListingXml's that can convert them to/from
259 -- XML.
260 --
261 pickle_listing :: PU InjuriesListingXml
262 pickle_listing =
263 xpElem "listing" $
264 xpWrap (from_tuple, to_tuple) $
265 xp4Tuple pickle_injuries_team
266 (xpOption $ xpElem "teamno" xpInt)
267 (xpElem "injuries" xpText)
268 (xpOption $ xpElem "updated" xpPrim)
269 where
270 from_tuple = uncurryN InjuriesListingXml
271 to_tuple l = (xml_team l, xml_teamno l, xml_injuries l, xml_updated l)
272
273
274 -- | A pickler for 'Message's that can convert them to/from XML.
275 --
276 pickle_message :: PU Message
277 pickle_message =
278 xpElem "message" $
279 xpWrap (from_tuple, to_tuple) $
280 xp6Tuple (xpElem "XML_File_ID" xpInt)
281 (xpElem "heading" xpText)
282 (xpElem "category" xpText)
283 (xpElem "sport" xpText)
284 (xpList pickle_listing)
285 (xpElem "time_stamp" xp_time_stamp)
286 where
287 from_tuple = uncurryN Message
288 to_tuple m = (xml_xml_file_id m,
289 xml_heading m,
290 xml_category m,
291 xml_sport m,
292 xml_listings m,
293 xml_time_stamp m)
294
295
296 --
297 -- Tasty Tests
298 --
299
300 -- | A list of all tests for this module.
301 --
302 injuries_tests :: TestTree
303 injuries_tests =
304 testGroup
305 "Injuries tests"
306 [ test_on_delete_cascade,
307 test_pickle_of_unpickle_is_identity,
308 test_unpickle_succeeds ]
309
310
311 -- | If we unpickle something and then pickle it, we should wind up
312 -- with the same thing we started with. WARNING: success of this
313 -- test does not mean that unpickling succeeded.
314 --
315 test_pickle_of_unpickle_is_identity :: TestTree
316 test_pickle_of_unpickle_is_identity =
317 testCase "pickle composed with unpickle is the identity" $ do
318 let path = "test/xml/injuriesxml.xml"
319 (expected, actual) <- pickle_unpickle pickle_message path
320 actual @?= expected
321
322
323 -- | Make sure we can actually unpickle these things.
324 --
325 test_unpickle_succeeds :: TestTree
326 test_unpickle_succeeds =
327 testCase "unpickling succeeds" $ do
328 let path = "test/xml/injuriesxml.xml"
329 actual <- unpickleable path pickle_message
330 let expected = True
331 actual @?= expected
332
333
334 -- | Make sure everything gets deleted when we delete the top-level
335 -- record.
336 --
337 test_on_delete_cascade :: TestTree
338 test_on_delete_cascade =
339 testCase "deleting an injuries deletes its children" $ do
340 let path = "test/xml/injuriesxml.xml"
341 inj <- unsafe_unpickle path pickle_message
342 let a = undefined :: Injuries
343 let b = undefined :: InjuriesListing
344 actual <- withSqliteConn ":memory:" $ runDbConn $ do
345 runMigration silentMigrationLogger $ do
346 migrate a
347 migrate b
348 _ <- dbimport inj
349 deleteAll a
350 count_a <- countAll a
351 count_b <- countAll b
352 return $ count_a + count_b
353 let expected = 0
354 actual @?= expected