]> gitweb.michael.orlitzky.com - dead/htsn-import.git/blob - TSN/XML/ScheduleChanges.hs
Allow "TBA" laps in TSN.XML.AutoRacingSchedule.
[dead/htsn-import.git] / TSN / XML / ScheduleChanges.hs
1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE GADTs #-}
3 {-# LANGUAGE QuasiQuotes #-}
4 {-# LANGUAGE RecordWildCards #-}
5 {-# LANGUAGE TemplateHaskell #-}
6 {-# LANGUAGE TypeFamilies #-}
7
8 -- | Parse TSN XML for the DTD \"Schedule_Changes_XML.dtd\". Each
9 -- \<message\> element contains zero or more \<Schedule_Change\>
10 -- which are just a wrapper around zero or more \<SC_Listing\>s.
11 --
12 -- The teams appear to use the shared "TSN.Team" representation.
13 --
14 module TSN.XML.ScheduleChanges (
15 dtd,
16 pickle_message,
17 -- * Tests
18 schedule_changes_tests,
19 -- * WARNING: these are private but exported to silence warnings
20 ScheduleChangesConstructor(..),
21 ScheduleChangesListingConstructor(..) )
22 where
23
24 -- System imports.
25 import Control.Monad ( forM_ )
26 import Data.Time ( UTCTime(..) )
27 import Data.Tuple.Curry ( uncurryN )
28 import Database.Groundhog (
29 countAll,
30 deleteAll,
31 insert_,
32 migrate,
33 runMigration,
34 silentMigrationLogger )
35 import Database.Groundhog.Core ( DefaultKey )
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 xp6Tuple,
46 xp11Tuple,
47 xpAttr,
48 xpElem,
49 xpInt,
50 xpList,
51 xpOption,
52 xpPair,
53 xpText,
54 xpWrap )
55
56 -- Local imports.
57 import TSN.Codegen (
58 tsn_codegen_config )
59 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
60 import TSN.Picklers ( xp_date_padded, xp_tba_time, xp_time_stamp )
61 import TSN.Team ( Team(..) )
62 import TSN.XmlImport ( XmlImport(..) )
63 import Xml (
64 FromXml(..),
65 ToDb(..),
66 pickle_unpickle,
67 unpickleable,
68 unsafe_unpickle )
69
70
71
72 -- | The DTD to which this module corresponds. Used to invoke
73 -- 'dbimport'.
74 --
75 dtd :: String
76 dtd = "Schedule_Changes_XML.dtd"
77
78
79 --
80 -- DB/XML data types
81 --
82
83 -- * ScheduleChanges/Message
84
85 -- | Database representation of a 'Message'. Comparatively, it lacks
86 -- the listings since they are linked via a foreign key.
87 --
88 data ScheduleChanges =
89 ScheduleChanges {
90 db_xml_file_id :: Int,
91 db_heading :: String,
92 db_category :: String,
93 db_sport :: String,
94 db_time_stamp :: UTCTime }
95 deriving (Eq, Show)
96
97
98 -- | XML representation of a \<Schedule_Change\> within a
99 -- \<message\>. These are wrappers around a bunch of
100 -- \<SC_Listing\>s, but they also contain the sport name for all of
101 -- the contained listings.
102 --
103 data ScheduleChangeXml =
104 ScheduleChangeXml {
105 xml_sc_sport :: String,
106 xml_sc_listings :: [ScheduleChangesListingXml] }
107 deriving (Eq, Show)
108
109
110 -- | XML representation of a 'ScheduleChanges'. It has the same
111 -- fields, but in addition contains the 'xml_listings'.
112 --
113 data Message =
114 Message {
115 xml_xml_file_id :: Int,
116 xml_heading :: String,
117 xml_category :: String,
118 xml_sport :: String,
119 xml_schedule_changes :: [ScheduleChangeXml],
120 xml_time_stamp :: UTCTime }
121 deriving (Eq, Show)
122
123
124
125 instance ToDb Message where
126 -- | The database analogue of a 'Message' is a 'ScheduleChanges'.
127 --
128 type Db Message = ScheduleChanges
129
130
131 -- | The 'FromXml' instance for 'Message' is required for the
132 -- 'XmlImport' instance.
133 --
134 instance FromXml Message where
135 -- | To convert a 'Message' to an 'ScheduleChanges', we just drop
136 -- the 'xml_schedule_changes'.
137 --
138 from_xml Message{..} =
139 ScheduleChanges {
140 db_xml_file_id = xml_xml_file_id,
141 db_heading = xml_heading,
142 db_category = xml_category,
143 db_sport = xml_sport,
144 db_time_stamp = xml_time_stamp }
145
146
147 -- | This allows us to insert the XML representation 'Message'
148 -- directly.
149 --
150 instance XmlImport Message
151
152
153
154 -- * ScheduleChangesListing/ScheduleChangesListingXml
155
156 -- | An embedded type within 'ScheduleChangesListing'. These look
157 -- like, \<status numeral=\"4\"\>FINAL\</status\> within the XML,
158 -- but they're in one-to-one correspondence with the listings.
159 --
160 data ScheduleChangesListingStatus =
161 ScheduleChangesListingStatus {
162 db_status_numeral :: Int,
163 db_status :: Maybe String } -- Yes, they can be empty.
164 deriving (Eq, Show)
165
166
167 -- | Database representation of a \<SC_Listing\> contained within a
168 -- \<Schedule_Change\>, within a \<message\>. During the transition
169 -- to the database, we drop the intermediate \<Schedule_Change\>
170 -- leaving the listing keyed to the 'ScheduleChanges' itself.
171 --
172 -- The home/away teams reuse the 'Team' representation.
173 --
174 -- The sport name (sc_sport) is pulled out of the containing
175 -- \<Schedule_Change\> and embedded into the listings themselves.
176 --
177 data ScheduleChangesListing =
178 ScheduleChangesListing {
179 db_schedule_changes_id :: DefaultKey ScheduleChanges,
180 db_away_team_id :: DefaultKey Team,
181 db_home_team_id ::DefaultKey Team,
182 db_type :: String,
183 db_sc_sport :: String,
184 db_schedule_id :: Int,
185 db_game_time :: UTCTime,
186 db_location :: Maybe String,
187 db_vscore :: Int,
188 db_hscore :: Int,
189 db_listing_status :: ScheduleChangesListingStatus,
190 db_notes :: Maybe String }
191
192
193 -- | XML representation of a \<SC_Listing\> contained within a
194 -- \<Schedule_Change\>, within a \<message\>.
195 --
196 data ScheduleChangesListingXml =
197 ScheduleChangesListingXml {
198 xml_type :: String,
199 xml_schedule_id :: Int,
200 xml_game_date :: UTCTime,
201 xml_game_time :: Maybe UTCTime,
202 xml_location :: Maybe String,
203 xml_away_team :: ScheduleChangesListingTeamXml,
204 xml_home_team :: ScheduleChangesListingTeamXml,
205 xml_vscore :: Int,
206 xml_hscore :: Int,
207 xml_listing_status :: ScheduleChangesListingStatus,
208 xml_notes :: Maybe String }
209 deriving (Eq, Show)
210
211
212 instance ToDb ScheduleChangesListingXml where
213 -- | The database analogue of an 'ScheduleChangesListingXml' is
214 -- an 'ScheduleChangesListing'.
215 --
216 type Db ScheduleChangesListingXml = ScheduleChangesListing
217
218
219
220 -- | We don't make 'ScheduleChangesListingXml' an instance of
221 -- 'FromXmlFkTeams' because it needs some additional information,
222 -- namely the sport name from its containing \<Schedule_Change\>.
223 -- But essentially we'll need to do the same thing as
224 -- 'from_xml_fk_teams'. This function accomplishes the same thing,
225 -- with the addition of the sport that's passed in.
226 --
227 -- The parameter order is for convenience later (see dbimport).
228 --
229 from_xml_fk_sport :: (DefaultKey ScheduleChanges)
230 -> String -- ^ The sport from our containing schedule change
231 -> (DefaultKey Team) -- ^ Away team FK
232 -> (DefaultKey Team) -- ^ Home team FK
233 -> ScheduleChangesListingXml
234 -> ScheduleChangesListing
235 from_xml_fk_sport fk sport fk_away fk_home ScheduleChangesListingXml{..} =
236 ScheduleChangesListing {
237 db_schedule_changes_id = fk,
238 db_away_team_id = fk_away,
239 db_home_team_id = fk_home,
240 db_type = xml_type,
241 db_sc_sport = sport,
242 db_schedule_id = xml_schedule_id,
243 db_game_time = make_game_time xml_game_date xml_game_time,
244 db_location = xml_location,
245 db_vscore = xml_vscore,
246 db_hscore = xml_hscore,
247 db_listing_status = xml_listing_status,
248 db_notes = xml_notes }
249 where
250 -- | Make the database \"game time\" from the XML
251 -- date/time. Simply take the day part from one and the time
252 -- from the other.
253 --
254 make_game_time d Nothing = d
255 make_game_time d (Just t) = UTCTime (utctDay d) (utctDayTime t)
256
257
258
259 -- * ScheduleChangesListingTeamXml
260
261 -- | The XML representation of a 'ScheduleChangesListing'
262 -- team. Its corresponding database representation (along with that
263 -- of the home team) is a "TSN.Team", but their XML representations
264 -- are slightly different.
265 --
266 data ScheduleChangesListingTeamXml =
267 ScheduleChangesListingTeamXml {
268 xml_team_id :: String,
269 xml_team_name :: Maybe String }
270 deriving (Eq, Show)
271
272
273 instance ToDb ScheduleChangesListingTeamXml where
274 -- | The database analogue of an 'ScheduleChangesListingTeamXml' is
275 -- a 'Team'.
276 --
277 type Db ScheduleChangesListingTeamXml = Team
278
279
280 instance FromXml ScheduleChangesListingTeamXml where
281 -- | To convert a 'ScheduleChangesListingTeamXml' to a 'Team',
282 -- we set the non-existent abbreviation to \"Nothing\".
283 --
284 from_xml ScheduleChangesListingTeamXml{..} =
285 Team {
286 team_id = xml_team_id,
287 abbreviation = Nothing,
288 name = xml_team_name }
289
290 -- | Allow us to import ScheduleChangesListingTeamXml directly.
291 --
292 instance XmlImport ScheduleChangesListingTeamXml
293
294
295
296 --
297 -- * Database stuff.
298 --
299
300 instance DbImport Message where
301 dbmigrate _ =
302 run_dbmigrate $ do
303 migrate (undefined :: Team)
304 migrate (undefined :: ScheduleChanges)
305 migrate (undefined :: ScheduleChangesListing)
306
307 dbimport m = do
308 -- Insert the top-level message
309 msg_id <- insert_xml m
310
311 -- Now loop through the message's schedule changes
312 forM_ (xml_schedule_changes m) $ \sc -> do
313 -- Construct the function that will turn an XML listing into a DB one.
314 -- This is only partially applied without the away/home team IDs.
315 let listing_xml_to_db = from_xml_fk_sport msg_id (xml_sc_sport sc)
316
317 -- Now loop through the listings so that we can handle the teams
318 -- one listing at a time.
319 forM_ (xml_sc_listings sc) $ \listing -> do
320 away_team_id <- insert_xml_or_select (xml_away_team listing)
321 home_team_id <- insert_xml_or_select (xml_home_team listing)
322
323 -- Finish constructing the xml -> db function.
324 let listing_xml_to_db' = listing_xml_to_db away_team_id home_team_id
325 let db_listing = listing_xml_to_db' listing
326
327 insert_ db_listing
328
329 return ImportSucceeded
330
331
332 mkPersist tsn_codegen_config [groundhog|
333 - entity: ScheduleChanges
334 dbName: schedule_changes
335 constructors:
336 - name: ScheduleChanges
337 uniques:
338 - name: unique_schedule_changes
339 type: constraint
340 # Prevent multiple imports of the same message.
341 fields: [db_xml_file_id]
342
343 # Note: we drop the "sc" prefix from the db_sc_sport field.
344 - entity: ScheduleChangesListing
345 dbName: schedule_changes_listings
346 constructors:
347 - name: ScheduleChangesListing
348 fields:
349 - name: db_schedule_changes_id
350 reference:
351 onDelete: cascade
352 - name: db_away_team_id
353 reference:
354 onDelete: cascade
355 - name: db_home_team_id
356 reference:
357 onDelete: cascade
358 - name: db_sc_sport
359 dbName: sport
360 - name: db_listing_status
361 embeddedType:
362 - {name: status_numeral, dbName: status_numeral}
363 - {name: status, dbName: status}
364
365 - embedded: ScheduleChangesListingStatus
366 fields:
367 - name: db_status_numeral
368 dbName: status_numeral
369 - name: db_status
370 dbName: status
371
372 |]
373
374
375
376 --
377 -- * Pickling
378 --
379
380 -- | An (un)pickler for the \<Away_Team\> elements.
381 --
382 pickle_away_team :: PU ScheduleChangesListingTeamXml
383 pickle_away_team =
384 xpElem "Away_Team" $
385 xpWrap (from_tuple, to_tuple) $
386 xpPair (xpAttr "AT_ID" xpText)
387 (xpOption xpText)
388 where
389 from_tuple = uncurry ScheduleChangesListingTeamXml
390 to_tuple t = (xml_team_id t,
391 xml_team_name t)
392
393
394 -- | An (un)pickler for the \<Away_Team\> elements.
395 --
396 pickle_home_team :: PU ScheduleChangesListingTeamXml
397 pickle_home_team =
398 xpElem "Home_Team" $
399 xpWrap (from_tuple, to_tuple) $
400 xpPair (xpAttr "HT_ID" xpText)
401 (xpOption xpText)
402 where
403 from_tuple = uncurry ScheduleChangesListingTeamXml
404 to_tuple t = (xml_team_id t,
405 xml_team_name t)
406
407
408 -- | An (un)pickler for the \<status\> elements.
409 --
410 pickle_status :: PU ScheduleChangesListingStatus
411 pickle_status =
412 xpElem "status" $
413 xpWrap (from_tuple, to_tuple) $
414 xpPair (xpAttr "numeral" xpInt)
415 (xpOption xpText)
416 where
417 from_tuple = uncurry ScheduleChangesListingStatus
418 to_tuple s = (db_status_numeral s,
419 db_status s)
420
421
422 -- | An (un)pickler for the \<SC_Listing\> elements.
423 --
424 pickle_listing :: PU ScheduleChangesListingXml
425 pickle_listing =
426 xpElem "SC_Listing" $
427 xpWrap (from_tuple, to_tuple) $
428 xp11Tuple (xpAttr "type" xpText)
429 (xpElem "Schedule_ID" xpInt)
430 (xpElem "Game_Date" xp_date_padded)
431 (xpElem "Game_Time" xp_tba_time)
432 (xpElem "Location" (xpOption xpText))
433 pickle_away_team
434 pickle_home_team
435 (xpElem "vscore" xpInt)
436 (xpElem "hscore" xpInt)
437 pickle_status
438 (xpElem "notes" (xpOption xpText))
439 where
440 from_tuple = uncurryN ScheduleChangesListingXml
441 to_tuple l = (xml_type l,
442 xml_schedule_id l,
443 xml_game_date l,
444 xml_game_time l,
445 xml_location l,
446 xml_away_team l,
447 xml_home_team l,
448 xml_vscore l,
449 xml_hscore l,
450 xml_listing_status l,
451 xml_notes l)
452
453
454 -- | An (un)pickler for the \<Schedule_Change\> elements.
455 --
456 pickle_schedule_change :: PU ScheduleChangeXml
457 pickle_schedule_change =
458 xpElem "Schedule_Change" $
459 xpWrap (from_tuple, to_tuple) $
460 xpPair (xpAttr "Sport" xpText)
461 (xpList pickle_listing)
462 where
463 from_tuple = uncurry ScheduleChangeXml
464 to_tuple sc = (xml_sc_sport sc,
465 xml_sc_listings sc)
466
467
468 -- | Pickler for the top-level 'Message'.
469 --
470 pickle_message :: PU Message
471 pickle_message =
472 xpElem "message" $
473 xpWrap (from_tuple, to_tuple) $
474 xp6Tuple (xpElem "XML_File_ID" xpInt)
475 (xpElem "heading" xpText)
476 (xpElem "category" xpText)
477 (xpElem "sport" xpText)
478 (xpList pickle_schedule_change)
479 (xpElem "time_stamp" xp_time_stamp)
480 where
481 from_tuple = uncurryN Message
482 to_tuple m = (xml_xml_file_id m,
483 xml_heading m,
484 xml_category m,
485 xml_sport m,
486 xml_schedule_changes m,
487 xml_time_stamp m)
488
489
490
491 --
492 -- * Tests
493 --
494 -- | A list of all tests for this module.
495 --
496 schedule_changes_tests :: TestTree
497 schedule_changes_tests =
498 testGroup
499 "ScheduleChanges tests"
500 [ test_on_delete_cascade,
501 test_pickle_of_unpickle_is_identity,
502 test_unpickle_succeeds ]
503
504 -- | If we unpickle something and then pickle it, we should wind up
505 -- with the same thing we started with. WARNING: success of this
506 -- test does not mean that unpickling succeeded.
507 --
508 test_pickle_of_unpickle_is_identity :: TestTree
509 test_pickle_of_unpickle_is_identity =
510 testCase "pickle composed with unpickle is the identity" $ do
511 let path = "test/xml/Schedule_Changes_XML.xml"
512 (expected, actual) <- pickle_unpickle pickle_message path
513 actual @?= expected
514
515
516
517 -- | Make sure we can actually unpickle these things.
518 --
519 test_unpickle_succeeds :: TestTree
520 test_unpickle_succeeds =
521 testCase "unpickling succeeds" $ do
522 let path = "test/xml/Schedule_Changes_XML.xml"
523 actual <- unpickleable path pickle_message
524
525 let expected = True
526 actual @?= expected
527
528
529
530 -- | Make sure everything gets deleted when we delete the top-level
531 -- record.
532 --
533 test_on_delete_cascade :: TestTree
534 test_on_delete_cascade =
535 testCase "deleting auto_racing_results deletes its children" $ do
536 let path = "test/xml/Schedule_Changes_XML.xml"
537 results <- unsafe_unpickle path pickle_message
538 let a = undefined :: Team
539 let b = undefined :: ScheduleChanges
540 let c = undefined :: ScheduleChangesListing
541
542 actual <- withSqliteConn ":memory:" $ runDbConn $ do
543 runMigration silentMigrationLogger $ do
544 migrate a
545 migrate b
546 migrate c
547 _ <- dbimport results
548 deleteAll b
549 count_a <- countAll a
550 count_b <- countAll b
551 count_c <- countAll c
552 return $ sum [count_a, count_b, count_c]
553 let expected = 12 -- There are 16 team elements, but 4 are dupes,
554 -- so 12 unique teams should be left over.
555 actual @?= expected