1 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE QuasiQuotes #-}
4 {-# LANGUAGE RecordWildCards #-}
5 {-# LANGUAGE TemplateHaskell #-}
6 {-# LANGUAGE TypeFamilies #-}
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.
12 -- The teams appear to use the shared "TSN.Team" representation.
14 module TSN.XML.ScheduleChanges (
18 schedule_changes_tests,
19 -- * WARNING: these are private but exported to silence warnings
20 ScheduleChangesConstructor(..),
21 ScheduleChangesListingConstructor(..) )
25 import Control.Monad ( forM_ )
26 import Data.Time ( UTCTime(..) )
27 import Data.Tuple.Curry ( uncurryN )
28 import Database.Groundhog (
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 (
41 import Test.Tasty ( TestTree, testGroup )
42 import Test.Tasty.HUnit ( (@?=), testCase )
43 import Text.XML.HXT.Core (
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(..) )
72 -- | The DTD to which this module corresponds. Used to invoke
76 dtd = "Schedule_Changes_XML.dtd"
83 -- * ScheduleChanges/Message
85 -- | Database representation of a 'Message'. Comparatively, it lacks
86 -- the listings since they are linked via a foreign key.
88 data ScheduleChanges =
90 db_xml_file_id :: Int,
92 db_category :: String,
94 db_time_stamp :: UTCTime }
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.
103 data ScheduleChangeXml =
105 xml_sc_sport :: String,
106 xml_sc_listings :: [ScheduleChangesListingXml] }
110 -- | XML representation of a 'ScheduleChanges'. It has the same
111 -- fields, but in addition contains the 'xml_listings'.
115 xml_xml_file_id :: Int,
116 xml_heading :: String,
117 xml_category :: String,
119 xml_schedule_changes :: [ScheduleChangeXml],
120 xml_time_stamp :: UTCTime }
125 instance ToDb Message where
126 -- | The database analogue of a 'Message' is a 'ScheduleChanges'.
128 type Db Message = ScheduleChanges
131 -- | The 'FromXml' instance for 'Message' is required for the
132 -- 'XmlImport' instance.
134 instance FromXml Message where
135 -- | To convert a 'Message' to an 'ScheduleChanges', we just drop
136 -- the 'xml_schedule_changes'.
138 from_xml Message{..} =
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 }
147 -- | This allows us to insert the XML representation 'Message'
150 instance XmlImport Message
154 -- * ScheduleChangesListing/ScheduleChangesListingXml
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.
160 data ScheduleChangesListingStatus =
161 ScheduleChangesListingStatus {
162 db_status_numeral :: Int,
163 db_status :: Maybe String } -- Yes, they can be empty.
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.
172 -- The home/away teams reuse the 'Team' representation.
174 -- The sport name (sc_sport) is pulled out of the containing
175 -- \<Schedule_Change\> and embedded into the listings themselves.
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,
183 db_sc_sport :: String,
184 db_schedule_id :: Int,
185 db_game_time :: UTCTime,
186 db_location :: Maybe String,
189 db_listing_status :: ScheduleChangesListingStatus,
190 db_notes :: Maybe String }
193 -- | XML representation of a \<SC_Listing\> contained within a
194 -- \<Schedule_Change\>, within a \<message\>.
196 data ScheduleChangesListingXml =
197 ScheduleChangesListingXml {
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 :: ScheduleChangesListingAwayTeamXml,
204 xml_home_team :: ScheduleChangesListingHomeTeamXml,
207 xml_listing_status :: ScheduleChangesListingStatus,
208 xml_notes :: Maybe String }
212 instance ToDb ScheduleChangesListingXml where
213 -- | The database analogue of an 'ScheduleChangesListingXml' is
214 -- an 'ScheduleChangesListing'.
216 type Db ScheduleChangesListingXml = ScheduleChangesListing
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.
227 -- The parameter order is for convenience later (see dbimport).
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,
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 }
250 -- | Make the database \"game time\" from the XML
251 -- date/time. Simply take the day part from one and the time
254 make_game_time d Nothing = d
255 make_game_time d (Just t) = UTCTime (utctDay d) (utctDayTime t)
259 -- * ScheduleChangesListingAwayTeamXml / ScheduleChangesListingHomeTeamXml
261 -- | The XML representation of a 'ScheduleChangesListing' away
262 -- team. Its corresponding database representation (along with that
263 -- of the home team) is a "TSN.Team", but their XML representations
266 data ScheduleChangesListingAwayTeamXml =
267 ScheduleChangesListingAwayTeamXml {
268 away_team_id :: String,
269 away_team_name :: Maybe String }
273 instance ToDb ScheduleChangesListingAwayTeamXml where
274 -- | The database analogue of an 'ScheduleChangesListingAwayTeamXml' is
277 type Db ScheduleChangesListingAwayTeamXml = Team
280 instance FromXml ScheduleChangesListingAwayTeamXml where
281 -- | To convert a 'ScheduleChangesListingAwayTeamXml' to a 'Team',
282 -- we set the non-existent abbreviation to \"Nothing\".
284 from_xml ScheduleChangesListingAwayTeamXml{..} =
286 team_id = away_team_id,
287 abbreviation = Nothing,
288 name = away_team_name }
290 -- | Allow us to import ScheduleChangesListingAwayTeamXml directly.
292 instance XmlImport ScheduleChangesListingAwayTeamXml
295 -- | The XML representation of a 'ScheduleChangesListing' home
296 -- team. Its corresponding database representation (along with that
297 -- of the away team) is a "TSN.Team", but their XML representations
300 data ScheduleChangesListingHomeTeamXml =
301 ScheduleChangesListingHomeTeamXml {
302 home_team_id :: String,
303 home_team_name :: Maybe String }
307 instance ToDb ScheduleChangesListingHomeTeamXml where
308 -- | The database analogue of an 'ScheduleChangesListingHomeTeamXml'
311 type Db ScheduleChangesListingHomeTeamXml = Team
314 instance FromXml ScheduleChangesListingHomeTeamXml where
315 -- | To convert a 'ScheduleChangesListingHomeTeamXml' to a 'Team',
316 -- we set the non-existent abbreviation to \"Nothing\".
318 from_xml ScheduleChangesListingHomeTeamXml{..} =
320 team_id = home_team_id,
321 abbreviation = Nothing,
322 name = home_team_name }
325 -- | Allow us to import ScheduleChangesListingHomeTeamXml directly.
327 instance XmlImport ScheduleChangesListingHomeTeamXml
334 instance DbImport Message where
337 migrate (undefined :: Team)
338 migrate (undefined :: ScheduleChanges)
339 migrate (undefined :: ScheduleChangesListing)
342 -- Insert the top-level message
343 msg_id <- insert_xml m
345 -- Now loop through the message's schedule changes
346 forM_ (xml_schedule_changes m) $ \sc -> do
347 -- Construct the function that will turn an XML listing into a DB one.
348 -- This is only partially applied without the away/home team IDs.
349 let listing_xml_to_db = from_xml_fk_sport msg_id (xml_sc_sport sc)
351 -- Now loop through the listings so that we can handle the teams
352 -- one listing at a time.
353 forM_ (xml_sc_listings sc) $ \listing -> do
354 away_team_id <- insert_xml_or_select (xml_away_team listing)
355 home_team_id <- insert_xml_or_select (xml_home_team listing)
357 -- Finish constructing the xml -> db function.
358 let listing_xml_to_db' = listing_xml_to_db away_team_id home_team_id
359 let db_listing = listing_xml_to_db' listing
363 return ImportSucceeded
366 mkPersist tsn_codegen_config [groundhog|
367 - entity: ScheduleChanges
368 dbName: schedule_changes
370 - name: ScheduleChanges
372 - name: unique_schedule_changes
374 # Prevent multiple imports of the same message.
375 fields: [db_xml_file_id]
377 # Note: we drop the "sc" prefix from the db_sc_sport field.
378 - entity: ScheduleChangesListing
379 dbName: schedule_changes_listings
381 - name: ScheduleChangesListing
383 - name: db_schedule_changes_id
386 - name: db_away_team_id
389 - name: db_home_team_id
394 - name: db_listing_status
396 - {name: status_numeral, dbName: status_numeral}
397 - {name: status, dbName: status}
399 - embedded: ScheduleChangesListingStatus
401 - name: db_status_numeral
402 dbName: status_numeral
414 -- | An (un)pickler for the \<Away_Team\> elements.
416 pickle_away_team :: PU ScheduleChangesListingAwayTeamXml
419 xpWrap (from_tuple, to_tuple) $
420 xpPair (xpAttr "AT_ID" xpText)
423 from_tuple = uncurry ScheduleChangesListingAwayTeamXml
424 to_tuple t = (away_team_id t,
428 -- | An (un)pickler for the \<Home_Team\> elements.
430 pickle_home_team :: PU ScheduleChangesListingHomeTeamXml
433 xpWrap (from_tuple, to_tuple) $
434 xpPair (xpAttr "HT_ID" xpText)
437 from_tuple = uncurry ScheduleChangesListingHomeTeamXml
438 to_tuple t = (home_team_id t,
442 -- | An (un)pickler for the \<status\> elements.
444 pickle_status :: PU ScheduleChangesListingStatus
447 xpWrap (from_tuple, to_tuple) $
448 xpPair (xpAttr "numeral" xpInt)
451 from_tuple = uncurry ScheduleChangesListingStatus
452 to_tuple s = (db_status_numeral s,
456 -- | An (un)pickler for the \<SC_Listing\> elements.
458 pickle_listing :: PU ScheduleChangesListingXml
460 xpElem "SC_Listing" $
461 xpWrap (from_tuple, to_tuple) $
462 xp11Tuple (xpAttr "type" xpText)
463 (xpElem "Schedule_ID" xpInt)
464 (xpElem "Game_Date" xp_date_padded)
465 (xpElem "Game_Time" xp_tba_time)
466 (xpElem "Location" (xpOption xpText))
469 (xpElem "vscore" xpInt)
470 (xpElem "hscore" xpInt)
472 (xpElem "notes" (xpOption xpText))
474 from_tuple = uncurryN ScheduleChangesListingXml
475 to_tuple l = (xml_type l,
484 xml_listing_status l,
488 -- | An (un)pickler for the \<Schedule_Change\> elements.
490 pickle_schedule_change :: PU ScheduleChangeXml
491 pickle_schedule_change =
492 xpElem "Schedule_Change" $
493 xpWrap (from_tuple, to_tuple) $
494 xpPair (xpAttr "Sport" xpText)
495 (xpList pickle_listing)
497 from_tuple = uncurry ScheduleChangeXml
498 to_tuple sc = (xml_sc_sport sc,
502 -- | Pickler for the top-level 'Message'.
504 pickle_message :: PU Message
507 xpWrap (from_tuple, to_tuple) $
508 xp6Tuple (xpElem "XML_File_ID" xpInt)
509 (xpElem "heading" xpText)
510 (xpElem "category" xpText)
511 (xpElem "sport" xpText)
512 (xpList pickle_schedule_change)
513 (xpElem "time_stamp" xp_time_stamp)
515 from_tuple = uncurryN Message
516 to_tuple m = (xml_xml_file_id m,
520 xml_schedule_changes m,
528 -- | A list of all tests for this module.
530 schedule_changes_tests :: TestTree
531 schedule_changes_tests =
533 "ScheduleChanges tests"
534 [ test_on_delete_cascade,
535 test_pickle_of_unpickle_is_identity,
536 test_unpickle_succeeds ]
538 -- | If we unpickle something and then pickle it, we should wind up
539 -- with the same thing we started with. WARNING: success of this
540 -- test does not mean that unpickling succeeded.
542 test_pickle_of_unpickle_is_identity :: TestTree
543 test_pickle_of_unpickle_is_identity =
544 testCase "pickle composed with unpickle is the identity" $ do
545 let path = "test/xml/Schedule_Changes_XML.xml"
546 (expected, actual) <- pickle_unpickle pickle_message path
551 -- | Make sure we can actually unpickle these things.
553 test_unpickle_succeeds :: TestTree
554 test_unpickle_succeeds =
555 testCase "unpickling succeeds" $ do
556 let path = "test/xml/Schedule_Changes_XML.xml"
557 actual <- unpickleable path pickle_message
564 -- | Make sure everything gets deleted when we delete the top-level
567 test_on_delete_cascade :: TestTree
568 test_on_delete_cascade =
569 testCase "deleting auto_racing_results deletes its children" $ do
570 let path = "test/xml/Schedule_Changes_XML.xml"
571 results <- unsafe_unpickle path pickle_message
572 let a = undefined :: Team
573 let b = undefined :: ScheduleChanges
574 let c = undefined :: ScheduleChangesListing
576 actual <- withSqliteConn ":memory:" $ runDbConn $ do
577 runMigration silentMigrationLogger $ do
581 _ <- dbimport results
583 count_a <- countAll a
584 count_b <- countAll b
585 count_c <- countAll c
586 return $ sum [count_a, count_b, count_c]
587 let expected = 12 -- There are 16 team elements, but 4 are dupes,
588 -- so 12 unique teams should be left over.