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(..),
22 ScheduleChangesListing_TeamConstructor(..) )
26 import Control.Monad ( forM_ )
27 import Data.Time ( UTCTime(..) )
28 import Data.Tuple.Curry ( uncurryN )
29 import Database.Groundhog (
36 silentMigrationLogger )
37 import Database.Groundhog.Core ( DefaultKey )
38 import Database.Groundhog.Generic ( runDbConn )
39 import Database.Groundhog.Sqlite ( withSqliteConn )
40 import Database.Groundhog.TH (
43 import Test.Tasty ( TestTree, testGroup )
44 import Test.Tasty.HUnit ( (@?=), testCase )
45 import Text.XML.HXT.Core (
61 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
62 import TSN.Picklers ( xp_date_padded, xp_time, xp_time_stamp )
63 import TSN.Team ( Team(..) )
64 import TSN.XmlImport ( XmlImport(..) )
74 -- | The DTD to which this module corresponds. Used to invoke dbimport.
77 dtd = "Schedule_Changes_XML.dtd"
84 -- * ScheduleChanges/Message
86 -- | Database representation of a 'Message'. Comparatively, it lacks
87 -- the listings since they are linked via a foreign key.
89 data ScheduleChanges =
91 db_xml_file_id :: Int,
93 db_category :: String,
95 db_time_stamp :: UTCTime }
99 -- | XML representation of a \<Schedule_Change\> within a
100 -- \<message\>. These are wrappers around a bunch of
101 -- \<SC_Listing\>s, but they also contain the sport name for all of
102 -- the contained listings.
104 data ScheduleChangeXml =
106 xml_sc_sport :: String,
107 xml_sc_listings :: [ScheduleChangesListingXml] }
111 -- | XML representation of a 'ScheduleChanges'. It has the same
112 -- fields, but in addition contains the 'xml_listings'.
116 xml_xml_file_id :: Int,
117 xml_heading :: String,
118 xml_category :: String,
120 xml_schedule_changes :: [ScheduleChangeXml],
121 xml_time_stamp :: UTCTime }
126 instance ToDb Message where
127 -- | The database analogue of a 'Message' is a 'ScheduleChanges'.
129 type Db Message = ScheduleChanges
132 -- | The 'FromXml' instance for 'Message' is required for the
133 -- 'XmlImport' instance.
135 instance FromXml Message where
136 -- | To convert a 'Message' to an 'ScheduleChanges', we just drop
137 -- the 'xml_schedule_changes'.
139 from_xml Message{..} =
141 db_xml_file_id = xml_xml_file_id,
142 db_heading = xml_heading,
143 db_category = xml_category,
144 db_sport = xml_sport,
145 db_time_stamp = xml_time_stamp }
148 -- | This allows us to insert the XML representation 'Message'
151 instance XmlImport Message
155 -- * ScheduleChangesListing/ScheduleChangesListingXml
157 -- | An embedded type within 'ScheduleChangesListing'. These look
158 -- like, \<status numeral=\"4\"\>FINAL\</status\> within the XML,
159 -- but they're in one-to-one correspondence with the listings.
161 data ScheduleChangesListingStatus =
162 ScheduleChangesListingStatus {
163 db_status_numeral :: Int,
164 db_status :: Maybe String }
168 -- | Database representation of a \<SC_Listing\> contained within a
169 -- \<Schedule_Change\>, within a \<message\>. During the transition
170 -- to the database, we drop the intermediate \<Schedule_Change\>
171 -- leaving the listing keyed to the 'ScheduleChanges' itself.
173 -- The home/away teams reuse the 'Team' representation and are
174 -- connected via 'ScheduleChangesListing_Team'.
176 -- The sport name (sc_sport) is pulled out of the containing
177 -- \<Schedule_Change\> and embedded into the listings themselves.
179 data ScheduleChangesListing =
180 ScheduleChangesListing {
181 db_schedule_changes_id :: DefaultKey ScheduleChanges,
183 db_sc_sport :: String,
184 db_schedule_id :: Int,
185 db_game_time :: UTCTime,
186 db_location :: 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 :: UTCTime,
202 xml_location :: 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 -- 'FromXmlFk' or 'XmlImportFk' because it needs some additional
222 -- information, namely the sport name from its containing
223 -- \<Schedule_Change\>.
225 from_xml_fk_sport :: (DefaultKey ScheduleChanges)
227 -> ScheduleChangesListingXml
228 -> ScheduleChangesListing
229 from_xml_fk_sport fk sport ScheduleChangesListingXml{..} =
230 ScheduleChangesListing {
231 db_schedule_changes_id = fk,
234 db_schedule_id = xml_schedule_id,
235 db_game_time = make_game_time xml_game_date xml_game_time,
236 db_location = xml_location,
237 db_vscore = xml_vscore,
238 db_hscore = xml_hscore,
239 db_listing_status = xml_listing_status,
240 db_notes = xml_notes }
243 -- | Make the database \"game time\" from the XML
244 -- date/time. Simply take the day part from one and the time
247 make_game_time d t = UTCTime (utctDay d) (utctDayTime t)
251 -- * ScheduleChangesListing_Team
253 -- | Database mapping between listings and their home/away teams.
255 data ScheduleChangesListing_Team =
256 ScheduleChangesListing_Team {
257 sclt_schedule_changes_listings_id :: DefaultKey ScheduleChangesListing,
258 sclt_away_team_id :: DefaultKey Team,
259 sclt_home_team_id :: DefaultKey Team }
262 -- * ScheduleChangesListingAwayTeamXml / ScheduleChangesListingHomeTeamXml
264 -- | The XML representation of a 'ScheduleChangesListing' away
265 -- team. Its corresponding database representation (along with that
266 -- of the home team) is a "TSN.Team", but their XML representations
268 data ScheduleChangesListingAwayTeamXml =
269 ScheduleChangesListingAwayTeamXml {
270 away_team_id :: String,
271 away_team_name :: String }
274 instance ToDb ScheduleChangesListingAwayTeamXml where
275 -- | The database analogue of an 'ScheduleChangesListingAwayTeamXml' is
278 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\" and wrap
283 -- the always-present name field in \"Just\".
285 from_xml ScheduleChangesListingAwayTeamXml{..} =
287 team_id = away_team_id,
288 team_abbreviation = Nothing,
289 team_name = Just away_team_name }
291 -- | 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 :: String }
306 instance ToDb ScheduleChangesListingHomeTeamXml where
307 -- | The database analogue of an 'ScheduleChangesListingHomeTeamXml'
310 type Db ScheduleChangesListingHomeTeamXml = Team
312 instance FromXml ScheduleChangesListingHomeTeamXml where
313 -- | To convert a 'ScheduleChangesListingHomeTeamXml' to a 'Team',
314 -- we set the non-existent abbreviation to \"Nothing\" and wrap
315 -- the always-present name field in \"Just\".
317 from_xml ScheduleChangesListingHomeTeamXml{..} =
319 team_id = home_team_id,
320 team_abbreviation = Nothing,
321 team_name = Just home_team_name }
323 -- | Allow us to import ScheduleChangesListingHomeTeamXml directly.
324 instance XmlImport ScheduleChangesListingHomeTeamXml
331 instance DbImport Message where
334 migrate (undefined :: Team)
335 migrate (undefined :: ScheduleChanges)
336 migrate (undefined :: ScheduleChangesListing)
337 migrate (undefined :: ScheduleChangesListing_Team)
340 -- Insert the top-level message
341 msg_id <- insert_xml m
343 -- Now loop through the message's schedule changes
344 forM_ (xml_schedule_changes m) $ \sc -> do
345 -- Construct the function that will turn an XML listing into a DB one.
346 let listing_xml_to_db = from_xml_fk_sport msg_id (xml_sc_sport sc)
348 -- Now loop through the listings so that we can handle the teams
349 -- one listing at a time.
350 forM_ (xml_sc_listings sc) $ \listing -> do
351 let db_listing = listing_xml_to_db listing
352 listing_id <- insert db_listing
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 -- Insert a record into schedule_changes_listings__teams
358 -- mapping the home/away teams to this game. Use the full
359 -- record syntax because the types would let us mix up the
361 insert_ ScheduleChangesListing_Team {
362 sclt_schedule_changes_listings_id = listing_id,
363 sclt_away_team_id = away_team_id,
364 sclt_home_team_id = home_team_id }
366 return ImportSucceeded
369 mkPersist tsn_codegen_config [groundhog|
370 - entity: ScheduleChanges
371 dbName: schedule_changes
373 - name: ScheduleChanges
375 - name: unique_schedule_changes
377 # Prevent multiple imports of the same message.
378 fields: [db_xml_file_id]
381 - entity: ScheduleChangesListing
382 dbName: schedule_changes_listings
384 - name: ScheduleChangesListing
386 - name: db_schedule_changes_id
390 - embedded: ScheduleChangesListingStatus
392 - name: db_status_numeral
393 dbName: status_numeral
398 - entity: ScheduleChangesListing_Team
399 dbName: schedule_changes_listings__teams
401 - name: ScheduleChangesListing_Team
403 - name: sclt_schedule_changes_listings_id
406 - name: sclt_away_team_id
409 - name: sclt_home_team_id
420 pickle_away_team :: PU ScheduleChangesListingAwayTeamXml
423 xpWrap (from_tuple, to_tuple) $
424 xpPair (xpAttr "AT_ID" xpText)
427 from_tuple = uncurry ScheduleChangesListingAwayTeamXml
428 to_tuple t = (away_team_id t,
431 pickle_home_team :: PU ScheduleChangesListingHomeTeamXml
434 xpWrap (from_tuple, to_tuple) $
435 xpPair (xpAttr "HT_ID" xpText)
438 from_tuple = uncurry ScheduleChangesListingHomeTeamXml
439 to_tuple t = (home_team_id t,
443 pickle_status :: PU ScheduleChangesListingStatus
446 xpWrap (from_tuple, to_tuple) $
447 xpPair (xpAttr "numeral" xpInt)
450 from_tuple = uncurry ScheduleChangesListingStatus
451 to_tuple s = (db_status_numeral s,
455 pickle_listing :: PU ScheduleChangesListingXml
457 xpElem "SC_Listing" $
458 xpWrap (from_tuple, to_tuple) $
459 xp11Tuple (xpAttr "type" xpText)
460 (xpElem "Schedule_ID" xpInt)
461 (xpElem "Game_Date" xp_date_padded)
462 (xpElem "Game_Time" xp_time)
463 (xpElem "Location" xpText)
466 (xpElem "vscore" xpInt)
467 (xpElem "hscore" xpInt)
469 (xpElem "notes" (xpOption xpText))
471 from_tuple = uncurryN ScheduleChangesListingXml
472 to_tuple l = (xml_type l,
481 xml_listing_status l,
484 pickle_schedule_change :: PU ScheduleChangeXml
485 pickle_schedule_change =
486 xpElem "Schedule_Change" $
487 xpWrap (from_tuple, to_tuple) $
488 xpPair (xpAttr "Sport" xpText)
489 (xpList pickle_listing)
491 from_tuple = uncurry ScheduleChangeXml
492 to_tuple sc = (xml_sc_sport sc,
496 -- | Pickler for the top-level 'Message'.
498 pickle_message :: PU Message
501 xpWrap (from_tuple, to_tuple) $
502 xp6Tuple (xpElem "XML_File_ID" xpInt)
503 (xpElem "heading" xpText)
504 (xpElem "category" xpText)
505 (xpElem "sport" xpText)
506 (xpList pickle_schedule_change)
507 (xpElem "time_stamp" xp_time_stamp)
509 from_tuple = uncurryN Message
510 to_tuple m = (xml_xml_file_id m,
514 xml_schedule_changes m,
522 -- | A list of all tests for this module.
524 schedule_changes_tests :: TestTree
525 schedule_changes_tests =
527 "ScheduleChanges tests"
528 [ test_on_delete_cascade,
529 test_pickle_of_unpickle_is_identity,
530 test_unpickle_succeeds ]
532 -- | If we unpickle something and then pickle it, we should wind up
533 -- with the same thing we started with. WARNING: success of this
534 -- test does not mean that unpickling succeeded.
536 test_pickle_of_unpickle_is_identity :: TestTree
537 test_pickle_of_unpickle_is_identity =
538 testCase "pickle composed with unpickle is the identity" $ do
539 let path = "test/xml/Schedule_Changes_XML.xml"
540 (expected, actual) <- pickle_unpickle pickle_message path
545 -- | Make sure we can actually unpickle these things.
547 test_unpickle_succeeds :: TestTree
548 test_unpickle_succeeds =
549 testCase "unpickling succeeds" $ do
550 let path = "test/xml/Schedule_Changes_XML.xml"
551 actual <- unpickleable path pickle_message
558 -- | Make sure everything gets deleted when we delete the top-level
561 test_on_delete_cascade :: TestTree
562 test_on_delete_cascade =
563 testCase "deleting auto_racing_results deletes its children" $ do
564 let path = "test/xml/Schedule_Changes_XML.xml"
565 results <- unsafe_unpickle path pickle_message
566 let a = undefined :: Team
567 let b = undefined :: ScheduleChanges
568 let c = undefined :: ScheduleChangesListing
569 let d = undefined :: ScheduleChangesListing_Team
571 actual <- withSqliteConn ":memory:" $ runDbConn $ do
572 runMigration silentMigrationLogger $ do
577 _ <- dbimport results
579 count_a <- countAll a
580 count_b <- countAll b
581 count_c <- countAll c
582 count_d <- countAll d
583 return $ sum [count_a, count_b, count_c, count_d]
584 let expected = 12 -- There are 16 team elements, but 4 are dupes,
585 -- so 12 unique teams should be left over.