schedule_changes_tests,
-- * WARNING: these are private but exported to silence warnings
ScheduleChangesConstructor(..),
- ScheduleChangesListingConstructor(..),
- ScheduleChangesListing_TeamConstructor(..) )
+ ScheduleChangesListingConstructor(..) )
where
-- System imports.
import Database.Groundhog (
countAll,
deleteAll,
- insert,
insert_,
migrate,
runMigration,
import TSN.Codegen (
tsn_codegen_config )
import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
-import TSN.Picklers ( xp_date_padded, xp_time, xp_time_stamp )
+import TSN.Picklers ( xp_date_padded, xp_tba_time, xp_time_stamp )
import TSN.Team ( Team(..) )
import TSN.XmlImport ( XmlImport(..) )
import Xml (
--- | The DTD to which this module corresponds. Used to invoke dbimport.
+-- | The DTD to which this module corresponds. Used to invoke
+-- 'dbimport'.
--
dtd :: String
dtd = "Schedule_Changes_XML.dtd"
data ScheduleChangesListingStatus =
ScheduleChangesListingStatus {
db_status_numeral :: Int,
- db_status :: Maybe String }
+ db_status :: Maybe String } -- Yes, they can be empty.
deriving (Eq, Show)
-- to the database, we drop the intermediate \<Schedule_Change\>
-- leaving the listing keyed to the 'ScheduleChanges' itself.
--
--- The home/away teams reuse the 'Team' representation and are
--- connected via 'ScheduleChangesListing_Team'.
+-- The home/away teams reuse the 'Team' representation.
--
-- The sport name (sc_sport) is pulled out of the containing
-- \<Schedule_Change\> and embedded into the listings themselves.
data ScheduleChangesListing =
ScheduleChangesListing {
db_schedule_changes_id :: DefaultKey ScheduleChanges,
+ db_away_team_id :: DefaultKey Team,
+ db_home_team_id ::DefaultKey Team,
db_type :: String,
db_sc_sport :: String,
db_schedule_id :: Int,
db_game_time :: UTCTime,
- db_location :: String,
+ db_location :: Maybe String,
db_vscore :: Int,
db_hscore :: Int,
db_listing_status :: ScheduleChangesListingStatus,
xml_type :: String,
xml_schedule_id :: Int,
xml_game_date :: UTCTime,
- xml_game_time :: UTCTime,
- xml_location :: String,
+ xml_game_time :: Maybe UTCTime,
+ xml_location :: Maybe String,
xml_away_team :: ScheduleChangesListingAwayTeamXml,
xml_home_team :: ScheduleChangesListingHomeTeamXml,
xml_vscore :: Int,
-- | We don't make 'ScheduleChangesListingXml' an instance of
--- 'FromXmlFk' or 'XmlImportFk' because it needs some additional
--- information, namely the sport name from its containing
--- \<Schedule_Change\>.
+-- 'FromXmlFkTeams' because it needs some additional information,
+-- namely the sport name from its containing \<Schedule_Change\>.
+-- But essentially we'll need to do the same thing as
+-- 'from_xml_fk_teams'. This function accomplishes the same thing,
+-- with the addition of the sport that's passed in.
+--
+-- The parameter order is for convenience later (see dbimport).
--
from_xml_fk_sport :: (DefaultKey ScheduleChanges)
- -> String
+ -> String -- ^ The sport from our containing schedule change
+ -> (DefaultKey Team) -- ^ Away team FK
+ -> (DefaultKey Team) -- ^ Home team FK
-> ScheduleChangesListingXml
-> ScheduleChangesListing
-from_xml_fk_sport fk sport ScheduleChangesListingXml{..} =
+from_xml_fk_sport fk sport fk_away fk_home ScheduleChangesListingXml{..} =
ScheduleChangesListing {
db_schedule_changes_id = fk,
+ db_away_team_id = fk_away,
+ db_home_team_id = fk_home,
db_type = xml_type,
db_sc_sport = sport,
db_schedule_id = xml_schedule_id,
db_hscore = xml_hscore,
db_listing_status = xml_listing_status,
db_notes = xml_notes }
-
where
-- | Make the database \"game time\" from the XML
-- date/time. Simply take the day part from one and the time
-- from the other.
--
- make_game_time d t = UTCTime (utctDay d) (utctDayTime t)
-
-
-
--- * ScheduleChangesListing_Team
+ make_game_time d Nothing = d
+ make_game_time d (Just t) = UTCTime (utctDay d) (utctDayTime t)
--- | Database mapping between listings and their home/away teams.
---
-data ScheduleChangesListing_Team =
- ScheduleChangesListing_Team {
- sclt_schedule_changes_listings_id :: DefaultKey ScheduleChangesListing,
- sclt_away_team_id :: DefaultKey Team,
- sclt_home_team_id :: DefaultKey Team }
-- * ScheduleChangesListingAwayTeamXml / ScheduleChangesListingHomeTeamXml
-- team. Its corresponding database representation (along with that
-- of the home team) is a "TSN.Team", but their XML representations
-- are different.
+--
data ScheduleChangesListingAwayTeamXml =
ScheduleChangesListingAwayTeamXml {
away_team_id :: String,
- away_team_name :: String }
+ away_team_name :: Maybe String }
deriving (Eq, Show)
+
instance ToDb ScheduleChangesListingAwayTeamXml where
-- | The database analogue of an 'ScheduleChangesListingAwayTeamXml' is
-- a 'Team'.
--
type Db ScheduleChangesListingAwayTeamXml = Team
+
instance FromXml ScheduleChangesListingAwayTeamXml where
-- | To convert a 'ScheduleChangesListingAwayTeamXml' to a 'Team',
- -- we set the non-existent abbreviation to \"Nothing\" and wrap
- -- the always-present name field in \"Just\".
+ -- we set the non-existent abbreviation to \"Nothing\".
--
from_xml ScheduleChangesListingAwayTeamXml{..} =
Team {
team_id = away_team_id,
- team_abbreviation = Nothing,
- team_name = Just away_team_name }
+ abbreviation = Nothing,
+ name = away_team_name }
-- | Allow us to import ScheduleChangesListingAwayTeamXml directly.
+--
instance XmlImport ScheduleChangesListingAwayTeamXml
data ScheduleChangesListingHomeTeamXml =
ScheduleChangesListingHomeTeamXml {
home_team_id :: String,
- home_team_name :: String }
+ home_team_name :: Maybe String }
deriving (Eq, Show)
+
instance ToDb ScheduleChangesListingHomeTeamXml where
-- | The database analogue of an 'ScheduleChangesListingHomeTeamXml'
-- is a 'Team'.
--
type Db ScheduleChangesListingHomeTeamXml = Team
+
instance FromXml ScheduleChangesListingHomeTeamXml where
-- | To convert a 'ScheduleChangesListingHomeTeamXml' to a 'Team',
- -- we set the non-existent abbreviation to \"Nothing\" and wrap
- -- the always-present name field in \"Just\".
+ -- we set the non-existent abbreviation to \"Nothing\".
--
from_xml ScheduleChangesListingHomeTeamXml{..} =
Team {
team_id = home_team_id,
- team_abbreviation = Nothing,
- team_name = Just home_team_name }
+ abbreviation = Nothing,
+ name = home_team_name }
+
-- | Allow us to import ScheduleChangesListingHomeTeamXml directly.
+--
instance XmlImport ScheduleChangesListingHomeTeamXml
migrate (undefined :: Team)
migrate (undefined :: ScheduleChanges)
migrate (undefined :: ScheduleChangesListing)
- migrate (undefined :: ScheduleChangesListing_Team)
dbimport m = do
-- Insert the top-level message
-- Now loop through the message's schedule changes
forM_ (xml_schedule_changes m) $ \sc -> do
-- Construct the function that will turn an XML listing into a DB one.
+ -- This is only partially applied without the away/home team IDs.
let listing_xml_to_db = from_xml_fk_sport msg_id (xml_sc_sport sc)
-- Now loop through the listings so that we can handle the teams
-- one listing at a time.
forM_ (xml_sc_listings sc) $ \listing -> do
- let db_listing = listing_xml_to_db listing
- listing_id <- insert db_listing
-
away_team_id <- insert_xml_or_select (xml_away_team listing)
home_team_id <- insert_xml_or_select (xml_home_team listing)
- -- Insert a record into schedule_changes_listings__teams
- -- mapping the home/away teams to this game. Use the full
- -- record syntax because the types would let us mix up the
- -- home/away teams.
- insert_ ScheduleChangesListing_Team {
- sclt_schedule_changes_listings_id = listing_id,
- sclt_away_team_id = away_team_id,
- sclt_home_team_id = home_team_id }
+ -- Finish constructing the xml -> db function.
+ let listing_xml_to_db' = listing_xml_to_db away_team_id home_team_id
+ let db_listing = listing_xml_to_db' listing
+
+ insert_ db_listing
return ImportSucceeded
# Prevent multiple imports of the same message.
fields: [db_xml_file_id]
-
+# Note: we drop the "sc" prefix from the db_sc_sport field.
- entity: ScheduleChangesListing
dbName: schedule_changes_listings
constructors:
- name: db_schedule_changes_id
reference:
onDelete: cascade
+ - name: db_away_team_id
+ reference:
+ onDelete: cascade
+ - name: db_home_team_id
+ reference:
+ onDelete: cascade
+ - name: db_sc_sport
+ dbName: sport
+ - name: db_listing_status
+ embeddedType:
+ - {name: status_numeral, dbName: status_numeral}
+ - {name: status, dbName: status}
- embedded: ScheduleChangesListingStatus
fields:
- name: db_status
dbName: status
-
-- entity: ScheduleChangesListing_Team
- dbName: schedule_changes_listings__teams
- constructors:
- - name: ScheduleChangesListing_Team
- fields:
- - name: sclt_schedule_changes_listings_id
- reference:
- onDelete: cascade
- - name: sclt_away_team_id
- reference:
- onDelete: cascade
- - name: sclt_home_team_id
- reference:
- onDelete: cascade
|]
-- * Pickling
--
+-- | An (un)pickler for the \<Away_Team\> elements.
+--
pickle_away_team :: PU ScheduleChangesListingAwayTeamXml
pickle_away_team =
xpElem "Away_Team" $
xpWrap (from_tuple, to_tuple) $
xpPair (xpAttr "AT_ID" xpText)
- xpText
+ (xpOption xpText)
where
from_tuple = uncurry ScheduleChangesListingAwayTeamXml
to_tuple t = (away_team_id t,
away_team_name t)
+
+-- | An (un)pickler for the \<Home_Team\> elements.
+--
pickle_home_team :: PU ScheduleChangesListingHomeTeamXml
pickle_home_team =
xpElem "Home_Team" $
xpWrap (from_tuple, to_tuple) $
xpPair (xpAttr "HT_ID" xpText)
- xpText
+ (xpOption xpText)
where
from_tuple = uncurry ScheduleChangesListingHomeTeamXml
to_tuple t = (home_team_id t,
home_team_name t)
+-- | An (un)pickler for the \<status\> elements.
+--
pickle_status :: PU ScheduleChangesListingStatus
pickle_status =
xpElem "status" $
db_status s)
+-- | An (un)pickler for the \<SC_Listing\> elements.
+--
pickle_listing :: PU ScheduleChangesListingXml
pickle_listing =
xpElem "SC_Listing" $
xp11Tuple (xpAttr "type" xpText)
(xpElem "Schedule_ID" xpInt)
(xpElem "Game_Date" xp_date_padded)
- (xpElem "Game_Time" xp_time)
- (xpElem "Location" xpText)
+ (xpElem "Game_Time" xp_tba_time)
+ (xpElem "Location" (xpOption xpText))
pickle_away_team
pickle_home_team
(xpElem "vscore" xpInt)
xml_listing_status l,
xml_notes l)
+
+-- | An (un)pickler for the \<Schedule_Change\> elements.
+--
pickle_schedule_change :: PU ScheduleChangeXml
pickle_schedule_change =
xpElem "Schedule_Change" $
let a = undefined :: Team
let b = undefined :: ScheduleChanges
let c = undefined :: ScheduleChangesListing
- let d = undefined :: ScheduleChangesListing_Team
actual <- withSqliteConn ":memory:" $ runDbConn $ do
runMigration silentMigrationLogger $ do
migrate a
migrate b
migrate c
- migrate d
_ <- dbimport results
deleteAll b
count_a <- countAll a
count_b <- countAll b
count_c <- countAll c
- count_d <- countAll d
- return $ sum [count_a, count_b, count_c, count_d]
+ return $ sum [count_a, count_b, count_c]
let expected = 12 -- There are 16 team elements, but 4 are dupes,
-- so 12 unique teams should be left over.
actual @?= expected
projects / dead / htsn-import.git / commitdiff
