1 {-# LANGUAGE DeriveGeneric #-}
2 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE QuasiQuotes #-}
5 {-# LANGUAGE RecordWildCards #-}
6 {-# LANGUAGE TemplateHaskell #-}
7 {-# LANGUAGE TypeFamilies #-}
9 -- | Parse TSN XML for the DTD \"Schedule_Changes_XML.dtd\". Each
10 -- \<message\> element contains zero or more \<Schedule_Change\>
11 -- which are just a wrapper around zero or more \<SC_Listing\>s.
13 -- The teams appear to use the shared "TSN.Team" representation.
15 module TSN.XML.ScheduleChanges (
19 schedule_changes_tests,
20 -- * WARNING: these are private but exported to silence warnings
21 ScheduleChangesConstructor(..),
22 ScheduleChangesListingConstructor(..) )
26 import Control.Monad ( forM_ )
27 import Data.Time ( UTCTime(..) )
28 import Data.Tuple.Curry ( uncurryN )
29 import qualified Data.Vector.HFixed as H ( HVector, convert )
30 import Database.Groundhog (
35 import Database.Groundhog.Core ( DefaultKey )
36 import Database.Groundhog.Generic ( runDbConn, runMigrationSilent )
37 import Database.Groundhog.Sqlite ( withSqliteConn )
38 import Database.Groundhog.TH (
41 import qualified GHC.Generics as GHC ( Generic )
42 import Test.Tasty ( TestTree, testGroup )
43 import Test.Tasty.HUnit ( (@?=), testCase )
44 import Text.XML.HXT.Core (
58 import TSN.Codegen ( tsn_codegen_config )
59 import TSN.Database ( insert_or_select )
60 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
61 import TSN.Picklers ( xp_date_padded, xp_tba_time, xp_time_stamp )
62 import TSN.Team ( Team(..), HTeam(..), VTeam(..) )
63 import TSN.XmlImport ( XmlImport(..) )
73 -- | The DTD to which this module corresponds. Used to invoke
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] }
108 deriving (Eq, GHC.Generic, Show)
111 -- | For 'H.convert'.
113 instance H.HVector ScheduleChangeXml
116 -- | XML representation of a 'ScheduleChanges'. It has the same
117 -- fields, but in addition contains the 'xml_listings'.
121 xml_xml_file_id :: Int,
122 xml_heading :: String,
123 xml_category :: String,
125 xml_schedule_changes :: [ScheduleChangeXml],
126 xml_time_stamp :: UTCTime }
127 deriving (Eq, GHC.Generic, Show)
130 -- | For 'H.convert'.
132 instance H.HVector Message
135 instance ToDb Message where
136 -- | The database analogue of a 'Message' is a 'ScheduleChanges'.
138 type Db Message = ScheduleChanges
141 -- | The 'FromXml' instance for 'Message' is required for the
142 -- 'XmlImport' instance.
144 instance FromXml Message where
145 -- | To convert a 'Message' to an 'ScheduleChanges', we just drop
146 -- the 'xml_schedule_changes'.
148 from_xml Message{..} =
150 db_xml_file_id = xml_xml_file_id,
151 db_heading = xml_heading,
152 db_category = xml_category,
153 db_sport = xml_sport,
154 db_time_stamp = xml_time_stamp }
157 -- | This allows us to insert the XML representation 'Message'
160 instance XmlImport Message
164 -- * ScheduleChangesListing/ScheduleChangesListingXml
166 -- | An embedded type within 'ScheduleChangesListing'. These look
167 -- like, \<status numeral=\"4\"\>FINAL\</status\> within the XML,
168 -- but they're in one-to-one correspondence with the listings.
170 -- The leading underscores prevent unused field warnings.
172 data ScheduleChangesListingStatus =
173 ScheduleChangesListingStatus {
174 _db_status_numeral :: Int,
175 _db_status :: Maybe String } -- Yes, they can be empty.
176 deriving (Eq, GHC.Generic, Show)
179 -- | For 'H.convert'.
181 instance H.HVector ScheduleChangesListingStatus
184 -- | Database representation of a \<SC_Listing\> contained within a
185 -- \<Schedule_Change\>, within a \<message\>. During the transition
186 -- to the database, we drop the intermediate \<Schedule_Change\>
187 -- leaving the listing keyed to the 'ScheduleChanges' itself.
189 -- The home/away teams reuse the 'Team' representation.
191 -- The sport name (sc_sport) is pulled out of the containing
192 -- \<Schedule_Change\> and embedded into the listings themselves.
194 data ScheduleChangesListing =
195 ScheduleChangesListing {
196 db_schedule_changes_id :: DefaultKey ScheduleChanges,
197 db_away_team_id :: DefaultKey Team,
198 db_home_team_id ::DefaultKey Team,
200 db_sc_sport :: String,
201 db_schedule_id :: Int,
202 db_game_time :: UTCTime,
203 db_location :: Maybe String,
206 db_listing_status :: ScheduleChangesListingStatus,
207 db_notes :: Maybe String }
210 -- | XML representation of a \<SC_Listing\> contained within a
211 -- \<Schedule_Change\>, within a \<message\>.
213 data ScheduleChangesListingXml =
214 ScheduleChangesListingXml {
216 xml_schedule_id :: Int,
217 xml_game_date :: UTCTime,
218 xml_game_time :: Maybe UTCTime,
219 xml_location :: Maybe String,
220 xml_away_team :: VTeam,
221 xml_home_team :: HTeam,
224 xml_listing_status :: ScheduleChangesListingStatus,
225 xml_notes :: Maybe String }
226 deriving (Eq, GHC.Generic, Show)
229 -- | For 'H.convert'.
231 instance H.HVector ScheduleChangesListingXml
234 instance ToDb ScheduleChangesListingXml where
235 -- | The database analogue of an 'ScheduleChangesListingXml' is
236 -- an 'ScheduleChangesListing'.
238 type Db ScheduleChangesListingXml = ScheduleChangesListing
242 -- | We don't make 'ScheduleChangesListingXml' an instance of
243 -- 'FromXmlFkTeams' because it needs some additional information,
244 -- namely the sport name from its containing \<Schedule_Change\>.
245 -- But essentially we'll need to do the same thing as
246 -- 'from_xml_fk_teams'. This function accomplishes the same thing,
247 -- with the addition of the sport that's passed in.
249 -- The parameter order is for convenience later (see dbimport).
251 from_xml_fk_sport :: (DefaultKey ScheduleChanges)
252 -> String -- ^ The sport from our containing schedule change
253 -> (DefaultKey Team) -- ^ Away team FK
254 -> (DefaultKey Team) -- ^ Home team FK
255 -> ScheduleChangesListingXml
256 -> ScheduleChangesListing
257 from_xml_fk_sport fk sport fk_away fk_home ScheduleChangesListingXml{..} =
258 ScheduleChangesListing {
259 db_schedule_changes_id = fk,
260 db_away_team_id = fk_away,
261 db_home_team_id = fk_home,
264 db_schedule_id = xml_schedule_id,
265 db_game_time = make_game_time xml_game_date xml_game_time,
266 db_location = xml_location,
267 db_vscore = xml_vscore,
268 db_hscore = xml_hscore,
269 db_listing_status = xml_listing_status,
270 db_notes = xml_notes }
272 -- | Make the database \"game time\" from the XML
273 -- date/time. Simply take the day part from one and the time
276 make_game_time d Nothing = d
277 make_game_time d (Just t) = UTCTime (utctDay d) (utctDayTime t)
285 instance DbImport Message where
288 migrate (undefined :: Team)
289 migrate (undefined :: ScheduleChanges)
290 migrate (undefined :: ScheduleChangesListing)
293 -- Insert the top-level message
294 msg_id <- insert_xml m
296 -- Now loop through the message's schedule changes
297 forM_ (xml_schedule_changes m) $ \sc -> do
298 -- Construct the function that will turn an XML listing into a DB one.
299 -- This is only partially applied without the away/home team IDs.
300 let listing_xml_to_db = from_xml_fk_sport msg_id (xml_sc_sport sc)
302 -- Now loop through the listings so that we can handle the teams
303 -- one listing at a time.
304 forM_ (xml_sc_listings sc) $ \listing -> do
305 away_team_id <- insert_or_select (vteam $ xml_away_team listing)
306 home_team_id <- insert_or_select (hteam $ xml_home_team listing)
308 -- Finish constructing the xml -> db function.
309 let listing_xml_to_db' = listing_xml_to_db away_team_id home_team_id
310 let db_listing = listing_xml_to_db' listing
314 return ImportSucceeded
317 mkPersist tsn_codegen_config [groundhog|
318 - entity: ScheduleChanges
319 dbName: schedule_changes
321 - name: ScheduleChanges
323 - name: unique_schedule_changes
325 # Prevent multiple imports of the same message.
326 fields: [db_xml_file_id]
328 # Note: we drop the "sc" prefix from the db_sc_sport field.
329 - entity: ScheduleChangesListing
330 dbName: schedule_changes_listings
332 - name: ScheduleChangesListing
334 - name: db_schedule_changes_id
337 - name: db_away_team_id
340 - name: db_home_team_id
345 - name: db_listing_status
347 - {name: status_numeral, dbName: status_numeral}
348 - {name: status, dbName: status}
350 - embedded: ScheduleChangesListingStatus
352 - name: _db_status_numeral
353 dbName: status_numeral
365 -- | An (un)pickler for the \<Away_Team\> elements.
367 pickle_away_team :: PU VTeam
370 xpWrap (from_tuple, to_tuple') $
371 xpPair (xpAttr "AT_ID" xpText)
374 from_tuple (x,y) = VTeam (Team x Nothing y)
375 to_tuple' (VTeam t) = (team_id t, name t)
378 -- | An (un)pickler for the \<Away_Team\> elements.
380 pickle_home_team :: PU HTeam
383 xpWrap (from_tuple, to_tuple') $
384 xpPair (xpAttr "HT_ID" xpText)
387 from_tuple (x,y) = HTeam (Team x Nothing y)
388 to_tuple' (HTeam t) = (team_id t, name t)
391 -- | An (un)pickler for the \<status\> elements.
393 pickle_status :: PU ScheduleChangesListingStatus
396 xpWrap (from_tuple, H.convert) $
397 xpPair (xpAttr "numeral" xpInt)
400 from_tuple = uncurry ScheduleChangesListingStatus
403 -- | An (un)pickler for the \<SC_Listing\> elements.
405 pickle_listing :: PU ScheduleChangesListingXml
407 xpElem "SC_Listing" $
408 xpWrap (from_tuple, H.convert) $
409 xp11Tuple (xpAttr "type" xpText)
410 (xpElem "Schedule_ID" xpInt)
411 (xpElem "Game_Date" xp_date_padded)
412 (xpElem "Game_Time" xp_tba_time)
413 (xpElem "Location" (xpOption xpText))
416 (xpElem "vscore" xpInt)
417 (xpElem "hscore" xpInt)
419 (xpElem "notes" (xpOption xpText))
421 from_tuple = uncurryN ScheduleChangesListingXml
424 -- | An (un)pickler for the \<Schedule_Change\> elements.
426 pickle_schedule_change :: PU ScheduleChangeXml
427 pickle_schedule_change =
428 xpElem "Schedule_Change" $
429 xpWrap (from_tuple, H.convert) $
430 xpPair (xpAttr "Sport" xpText)
431 (xpList pickle_listing)
433 from_tuple = uncurry ScheduleChangeXml
436 -- | Pickler for the top-level 'Message'.
438 pickle_message :: PU Message
441 xpWrap (from_tuple, H.convert) $
442 xp6Tuple (xpElem "XML_File_ID" xpInt)
443 (xpElem "heading" xpText)
444 (xpElem "category" xpText)
445 (xpElem "sport" xpText)
446 (xpList pickle_schedule_change)
447 (xpElem "time_stamp" xp_time_stamp)
449 from_tuple = uncurryN Message
456 -- | A list of all tests for this module.
458 schedule_changes_tests :: TestTree
459 schedule_changes_tests =
461 "ScheduleChanges tests"
462 [ test_on_delete_cascade,
463 test_pickle_of_unpickle_is_identity,
464 test_unpickle_succeeds ]
466 -- | If we unpickle something and then pickle it, we should wind up
467 -- with the same thing we started with. WARNING: success of this
468 -- test does not mean that unpickling succeeded.
470 test_pickle_of_unpickle_is_identity :: TestTree
471 test_pickle_of_unpickle_is_identity =
472 testCase "pickle composed with unpickle is the identity" $ do
473 let path = "test/xml/Schedule_Changes_XML.xml"
474 (expected, actual) <- pickle_unpickle pickle_message path
479 -- | Make sure we can actually unpickle these things.
481 test_unpickle_succeeds :: TestTree
482 test_unpickle_succeeds =
483 testCase "unpickling succeeds" $ do
484 let path = "test/xml/Schedule_Changes_XML.xml"
485 actual <- unpickleable path pickle_message
492 -- | Make sure everything gets deleted when we delete the top-level
495 test_on_delete_cascade :: TestTree
496 test_on_delete_cascade =
497 testCase "deleting auto_racing_results deletes its children" $ do
498 let path = "test/xml/Schedule_Changes_XML.xml"
499 results <- unsafe_unpickle path pickle_message
500 let a = undefined :: Team
501 let b = undefined :: ScheduleChanges
502 let c = undefined :: ScheduleChangesListing
504 actual <- withSqliteConn ":memory:" $ runDbConn $ do
505 runMigrationSilent $ do
509 _ <- dbimport results
511 count_a <- countAll a
512 count_b <- countAll b
513 count_c <- countAll c
514 return $ sum [count_a, count_b, count_c]
515 let expected = 12 -- There are 16 team elements, but 4 are dupes,
516 -- so 12 unique teams should be left over.