]> gitweb.michael.orlitzky.com - dead/htsn-import.git/blob - src/TSN/XML/InjuriesDetail.hs
Add a minor TODO note.
[dead/htsn-import.git] / src / TSN / XML / InjuriesDetail.hs
1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE GADTs #-}
3 {-# LANGUAGE QuasiQuotes #-}
4 {-# LANGUAGE RecordWildCards #-}
5 {-# LANGUAGE StandaloneDeriving #-}
6 {-# LANGUAGE TemplateHaskell #-}
7 {-# LANGUAGE TypeFamilies #-}
8
9 -- | Parse TSN XML for the DTD "Injuries_Detail_XML.dtd". Each
10 -- document contains a root element \<message\> that in turn
11 -- contains zero or more \<Listing\>s (note: capitalization). The
12 -- \<Listing\>s contain \<PlayerListing\>s which then contain the
13 -- real meat.
14 --
15 module TSN.XML.InjuriesDetail (
16 dtd,
17 pickle_message,
18 -- * Tests
19 injuries_detail_tests,
20 -- * WARNING: these are private but exported to silence warnings
21 InjuriesDetailConstructor(..),
22 InjuriesDetailListingConstructor(..),
23 InjuriesDetailListingPlayerListingConstructor(..) )
24 where
25
26 -- System imports.
27 import Control.Monad ( forM_ )
28 import Data.Time ( UTCTime )
29 import Data.Tuple.Curry ( uncurryN )
30 import Database.Groundhog (
31 DefaultKey,
32 countAll,
33 deleteAll,
34 migrate,
35 runMigration,
36 silentMigrationLogger )
37 import Database.Groundhog.Generic ( runDbConn )
38 import Database.Groundhog.Sqlite ( withSqliteConn )
39 import Database.Groundhog.TH (
40 groundhog,
41 mkPersist )
42 import Test.Tasty ( TestTree, testGroup )
43 import Test.Tasty.HUnit ( (@?=), testCase )
44 import Text.XML.HXT.Core (
45 PU,
46 xpTriple,
47 xp6Tuple,
48 xp10Tuple,
49 xpElem,
50 xpInt,
51 xpList,
52 xpOption,
53 xpPrim,
54 xpText,
55 xpWrap )
56
57 -- Local imports.
58 import TSN.Codegen ( tsn_codegen_config )
59 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
60 import TSN.Picklers( xp_date, xp_time_stamp )
61 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
62 import Xml (
63 FromXml(..),
64 FromXmlFk(..),
65 ToDb(..),
66 pickle_unpickle,
67 unpickleable,
68 unsafe_unpickle )
69
70
71
72 -- | The DTD to which this module corresponds. Used to invoke dbimport.
73 --
74 dtd :: String
75 dtd = "Injuries_Detail_XML.dtd"
76
77
78 --
79 -- Data types
80 --
81
82
83 -- * InjuriesDetail/Message
84
85
86 -- | XML representation of the top-level \<message\> element. These
87 -- are not stored; the data type is used only for parsing.
88 --
89 data Message =
90 Message {
91 xml_xml_file_id :: Int,
92 xml_heading :: String,
93 xml_category :: String,
94 xml_sport :: String,
95 xml_listings :: [InjuriesDetailListingXml],
96 xml_time_stamp :: UTCTime }
97 deriving (Eq, Show)
98
99 -- | Database representation of a 'Message'.
100 --
101 data InjuriesDetail =
102 InjuriesDetail {
103 db_xml_file_id :: Int,
104 db_sport :: String,
105 db_time_stamp :: UTCTime }
106 deriving (Eq, Show)
107
108 instance ToDb Message where
109 -- | The database representation of a 'Message' is an
110 -- 'InjuriesDetail'.
111 --
112 type Db Message = InjuriesDetail
113
114 instance FromXml Message where
115 -- | To convert a 'Message' into an 'InjuriesDetail', we simply drop
116 -- a few fields.
117 --
118 from_xml Message{..} =
119 InjuriesDetail {
120 db_xml_file_id = xml_xml_file_id,
121 db_sport = xml_sport,
122 db_time_stamp = xml_time_stamp }
123
124
125 -- | This allows us to insert the XML representation 'Message'
126 -- directly.
127 --
128 instance XmlImport Message
129
130
131
132 -- * InjuriesDetailListing/InjuriesDetailListingXml
133
134 -- | Database representation of a \<Listing\> element. It has a
135 -- foreign key pointing to its parent 'InjuriesDetail', and does not
136 -- contain the list of 'xml_player_listings' (which get their own
137 -- table).
138 --
139 data InjuriesDetailListing =
140 InjuriesDetailListing {
141 db_injuries_detail_id :: DefaultKey InjuriesDetail,
142 db_team_id :: String,
143 db_full_name :: String }
144
145
146 -- | XML incarnation of a \<Listing\> element. We don't store these;
147 -- the data type is used only for parsing.
148 --
149 data InjuriesDetailListingXml =
150 InjuriesDetailListingXml {
151 xml_team_id :: String, -- ^ TeamIDs are (apparently) three
152 -- characters long and not necessarily
153 -- numeric.
154
155 xml_full_name :: String, -- ^ Team full name
156 xml_player_listings :: [InjuriesDetailListingPlayerListingXml] }
157 deriving (Eq, Show)
158
159 instance ToDb InjuriesDetailListingXml where
160 -- | The database analogue of an 'InjuriesDetailListingXml' is a
161 -- 'InjuriesDetailListing'.
162 type Db InjuriesDetailListingXml = InjuriesDetailListing
163
164 instance FromXmlFk InjuriesDetailListingXml where
165 -- | Each 'InjuriesDetailListingXml' is contained in an
166 -- 'InjuriesDetail'.
167 type Parent InjuriesDetailListingXml = InjuriesDetail
168
169 -- | Construct a 'InjuriesDetailListing' from a
170 -- 'InjuriesDetailListingXml' and a foreign key to a
171 -- 'InjuriesDetail'.
172 --
173 from_xml_fk fk InjuriesDetailListingXml{..} =
174 InjuriesDetailListing {
175 db_injuries_detail_id = fk,
176 db_team_id = xml_team_id,
177 db_full_name = xml_full_name }
178
179 -- | This allows us to insert the XML representation
180 -- 'InjuriesDetailListingXml' directly.
181 --
182 instance XmlImportFk InjuriesDetailListingXml
183
184
185 -- * InjuriesDetailListingPlayerListing
186
187 -- | XML representation of a \<PlayerListing\>, the main type of
188 -- element contains in Injuries_Detail_XML messages.
189 --
190 data InjuriesDetailListingPlayerListingXml =
191 InjuriesDetailListingPlayerListingXml {
192 xml_player_team_id :: String, -- ^ TeamIDs are (apparently) three
193 -- characters long and not
194 -- necessarily numeric. Postgres
195 -- imposes no performance penalty
196 -- on a lengthless text field, so
197 -- we ignore the likely upper
198 -- bound of three characters.
199 -- We add the \"player\" to avoid conflict
200 -- with 'InjuriesDetailListingXml'.
201 xml_player_id :: Int,
202 xml_date :: UTCTime,
203 xml_pos :: String,
204 xml_name :: String,
205 xml_injury :: String,
206 xml_status :: String,
207 xml_fantasy :: Maybe String, -- ^ Nobody knows what this is.
208 xml_injured :: Bool,
209 xml_type :: String }
210 deriving (Eq, Show)
211
212
213
214 -- | Database representation of a
215 -- 'InjuriesDetailListingPlayerListingXml'. We drop the team_id
216 -- because it's redundant.
217 --
218 data InjuriesDetailListingPlayerListing =
219 InjuriesDetailListingPlayerListing {
220 db_injuries_detail_listings_id :: DefaultKey InjuriesDetailListing,
221 db_player_id :: Int,
222 db_date :: UTCTime,
223 db_pos :: String,
224 db_name :: String,
225 db_injury :: String,
226 db_status :: String,
227 db_fantasy :: Maybe String, -- ^ Nobody knows what this is.
228 db_injured :: Bool,
229 db_type :: String }
230
231
232 instance ToDb InjuriesDetailListingPlayerListingXml where
233 -- | The DB analogue of a 'InjuriesDetailListingPlayerListingXml' is
234 -- 'InjuriesDetailListingPlayerListing'.
235 type Db InjuriesDetailListingPlayerListingXml =
236 InjuriesDetailListingPlayerListing
237
238 instance FromXmlFk InjuriesDetailListingPlayerListingXml where
239 -- | Each 'InjuriesDetailListingPlayerListingXml' is contained in an
240 -- 'InjuriesDetailListing'.
241 --
242 type Parent InjuriesDetailListingPlayerListingXml = InjuriesDetailListing
243
244 -- | To construct a 'InjuriesDetailListingPlayerListing' from a
245 -- 'InjuriesDetailListingPlayerListingXml' we need to supply a
246 -- foreign key to an 'InjuriesDetailListing'.
247 --
248 from_xml_fk fk InjuriesDetailListingPlayerListingXml{..} =
249 InjuriesDetailListingPlayerListing {
250 db_injuries_detail_listings_id = fk,
251 db_player_id = xml_player_id,
252 db_date = xml_date,
253 db_pos = xml_pos,
254 db_name = xml_name,
255 db_injury = xml_injury,
256 db_status = xml_status,
257 db_fantasy = xml_fantasy,
258 db_injured = xml_injured,
259 db_type = xml_type }
260
261 -- | This lets us insert the XML representation
262 -- 'InjuriesDetailListingPlayerListingXml' directly.
263 --
264 instance XmlImportFk InjuriesDetailListingPlayerListingXml
265
266
267 --
268 -- Database stuff
269 --
270
271 instance DbImport Message where
272 dbmigrate _ =
273 run_dbmigrate $ do
274 migrate (undefined :: InjuriesDetail)
275 migrate (undefined :: InjuriesDetailListing)
276 migrate (undefined :: InjuriesDetailListingPlayerListing)
277
278 -- | To import a 'Message', we import all of its
279 -- 'InjuriesDetailListingPlayerListingXml's, which we have to dig
280 -- out of its 'Listing's.
281 --
282 dbimport msg = do
283 msg_id <- insert_xml msg
284
285 forM_ (xml_listings msg) $ \listing -> do
286 l_id <- insert_xml_fk msg_id listing
287 mapM_ (insert_xml_fk_ l_id) (xml_player_listings listing)
288
289 return ImportSucceeded
290
291
292 mkPersist tsn_codegen_config [groundhog|
293 - entity: InjuriesDetail
294 dbName: injuries_detail
295 constructors:
296 - name: InjuriesDetail
297 uniques:
298 - name: unique_injuries_detail
299 type: constraint
300 # Prevent multiple imports of the same message.
301 fields: [db_xml_file_id]
302
303 - entity: InjuriesDetailListing
304 dbName: injuries_detail_listings
305 constructors:
306 - name: InjuriesDetailListing
307 fields:
308 - name: db_injuries_detail_id
309 reference:
310 onDelete: cascade
311
312 - entity: InjuriesDetailListingPlayerListing
313 dbName: injuries_detail_listings_player_listings
314 constructors:
315 - name: InjuriesDetailListingPlayerListing
316 fields:
317 - name: db_injuries_detail_listings_id
318 reference:
319 onDelete: cascade
320 |]
321
322
323
324 --
325 -- Pickling
326 --
327
328 -- | Convert 'InjuriesDetailListingPlayerListingXml's to/from XML.
329 --
330 pickle_player_listing :: PU InjuriesDetailListingPlayerListingXml
331 pickle_player_listing =
332 xpElem "PlayerListing" $
333 xpWrap (from_tuple, to_tuple) $
334 xp10Tuple (xpElem "TeamID" xpText)
335 (xpElem "PlayerID" xpInt)
336 (xpElem "Date" xp_date)
337 (xpElem "Pos" xpText)
338 (xpElem "Name" xpText)
339 (xpElem "Injury" xpText)
340 (xpElem "Status" xpText)
341 (xpElem "Fantasy" $ xpOption xpText)
342 (xpElem "Injured" xpPrim)
343 (xpElem "Type" xpText)
344 where
345 from_tuple = uncurryN InjuriesDetailListingPlayerListingXml
346 to_tuple pl = (xml_player_team_id pl,
347 xml_player_id pl,
348 xml_date pl,
349 xml_pos pl,
350 xml_name pl,
351 xml_injury pl,
352 xml_status pl,
353 xml_fantasy pl,
354 xml_injured pl,
355 xml_type pl)
356
357
358 -- | Convert 'Listing's to/from XML.
359 --
360 pickle_listing :: PU InjuriesDetailListingXml
361 pickle_listing =
362 xpElem "Listing" $
363 xpWrap (from_tuple, to_tuple) $
364 xpTriple (xpElem "TeamID" xpText)
365 (xpElem "FullName" xpText)
366 (xpList pickle_player_listing)
367 where
368 from_tuple = uncurryN InjuriesDetailListingXml
369 to_tuple l = (xml_team_id l,
370 xml_full_name l,
371 xml_player_listings l)
372
373
374 -- | Convert 'Message's to/from XML.
375 --
376 pickle_message :: PU Message
377 pickle_message =
378 xpElem "message" $
379 xpWrap (from_tuple, to_tuple) $
380 xp6Tuple (xpElem "XML_File_ID" xpInt)
381 (xpElem "heading" xpText)
382 (xpElem "category" xpText)
383 (xpElem "sport" xpText)
384 (xpList pickle_listing)
385 (xpElem "time_stamp" xp_time_stamp)
386 where
387 from_tuple = uncurryN Message
388 to_tuple m = (xml_xml_file_id m,
389 xml_heading m,
390 xml_category m,
391 xml_sport m,
392 xml_listings m,
393 xml_time_stamp m)
394
395
396 --
397 -- Tasty Tests
398 --
399
400 -- | A list of all tests for this module.
401 --
402 injuries_detail_tests :: TestTree
403 injuries_detail_tests =
404 testGroup
405 "InjuriesDetail tests"
406 [ test_on_delete_cascade,
407 test_pickle_of_unpickle_is_identity,
408 test_unpickle_succeeds ]
409
410
411 -- | If we unpickle something and then pickle it, we should wind up
412 -- with the same thing we started with. WARNING: success of this
413 -- test does not mean that unpickling succeeded.
414 --
415 test_pickle_of_unpickle_is_identity :: TestTree
416 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
417 [ check "pickle composed with unpickle is the identity"
418 "test/xml/Injuries_Detail_XML.xml",
419
420 check "pickle composed with unpickle is the identity (non-int team_id)"
421 "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
422 where
423 check desc path = testCase desc $ do
424 (expected, actual) <- pickle_unpickle pickle_message path
425 actual @?= expected
426
427
428 -- | Make sure we can actually unpickle these things.
429 --
430 test_unpickle_succeeds :: TestTree
431 test_unpickle_succeeds = testGroup "unpickle tests"
432 [ check "unpickling succeeds"
433 "test/xml/Injuries_Detail_XML.xml",
434
435 check "unpickling succeeds (non-int team_id)"
436 "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
437 where
438 check desc path = testCase desc $ do
439 actual <- unpickleable path pickle_message
440 let expected = True
441 actual @?= expected
442
443
444 -- | Make sure everything gets deleted when we delete the top-level
445 -- record.
446 --
447 test_on_delete_cascade :: TestTree
448 test_on_delete_cascade = testGroup "cascading delete tests"
449 [ check "delete of injuries_detail deletes its children"
450 "test/xml/Injuries_Detail_XML.xml",
451
452 check "delete of injuries_detail deletes its children (non-int team_id)"
453 "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ]
454 where
455 check desc path = testCase desc $ do
456 inj <- unsafe_unpickle path pickle_message
457 let a = undefined :: InjuriesDetail
458 let b = undefined :: InjuriesDetailListing
459 let c = undefined :: InjuriesDetailListingPlayerListing
460 actual <- withSqliteConn ":memory:" $ runDbConn $ do
461 runMigration silentMigrationLogger $ do
462 migrate a
463 migrate b
464 migrate c
465 _ <- dbimport inj
466 deleteAll a
467 count_a <- countAll a
468 count_b <- countAll b
469 count_c <- countAll c
470 return $ count_a + count_b + count_c
471 let expected = 0
472 actual @?= expected