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