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