+instance ToDb Message where
+ -- | The database representation of 'Message' is 'News'.
+ type Db Message = News
+
+-- | Convert the XML representation 'Message' to the database
+-- representation 'News'.
+--
+instance FromXml Message where
+ -- | We use a record wildcard so GHC doesn't complain that we never
+ -- used the field names.
+ --
+ from_xml Message{..} = News { db_xml_file_id = xml_xml_file_id,
+ db_mid = xml_mid,
+ db_sport = xml_sport,
+ db_url = xml_url,
+ db_sms = xml_sms,
+ db_editor = xml_editor,
+ db_text = xml_text,
+ db_continue = xml_continue,
+ db_time_stamp = xml_time_stamp }
+
+-- | This lets us insert the XML representation 'Message' directly.
+--
+instance XmlImport Message
+
+
+-- * NewsTeam
+
+-- | The database/XML type for teams as they show up in the news. We
+-- can't reuse the representation from "TSN.Team" because they
+-- require a team id. We wouldn't want to make the team ID optional
+-- and then insert a team with no id, only to find the same team
+-- later with an id and be unable to update the record. (We could
+-- add the update logic, but it would be more trouble than it's
+-- worth.)
+--
+data NewsTeam =
+ NewsTeam { team_name :: String }
+ deriving (Eq, Show)
+
+
+
+-- * News_NewsTeam
+
+-- | Mapping between News records and NewsTeam records in the
+-- database. We don't name the fields because we don't use the names
+-- explicitly; that means we have to give them nice database names
+-- via groundhog.
+--
+data News_NewsTeam = News_NewsTeam
+ (DefaultKey News)
+ (DefaultKey NewsTeam)
+
+
+-- * NewsLocationXml
+
+-- | The XML type for locations as they show up in the news. The
+-- associated database type comes from "TSN.Location".
+--
+data NewsLocationXml =
+ NewsLocationXml {
+ xml_city :: Maybe String,
+ xml_state :: Maybe String,
+ xml_country :: String }
+ deriving (Eq, Show)
+
+
+instance ToDb NewsLocationXml where
+ -- | The database analogue of a NewsLocationXml is a Location.
+ type Db NewsLocationXml = Location
+
+
+instance FromXml NewsLocationXml where
+ -- | To convert from the XML representation to the database one, we
+ -- don't have to do anything. Just copy the fields.
+ --
+ from_xml NewsLocationXml{..} =
+ Location xml_city xml_state xml_country
+
+
+-- | Allow us to import the XML representation directly into the
+-- database, without having to perform the conversion manually first.
+--
+instance XmlImport NewsLocationXml
+
+
+-- * News_Location
+
+-- | Mapping between 'News' records and 'Location' records in the
+-- database. We don't name the fields because we don't use the names
+-- explicitly; that means we have to give them nice database names
+-- via groundhog.
+--
+data News_Location = News_Location
+ (DefaultKey News)
+ (DefaultKey Location)
+
+
+
+--
+-- Database code
+--
+
+-- | Define 'dbmigrate' and 'dbimport' for 'Message's. The import is
+-- slightly non-generic because of our 'News_NewsTeam' and
+-- 'News_Location' join tables.
+--
+instance DbImport Message where
+ dbmigrate _ =
+ run_dbmigrate $ do
+ migrate (undefined :: Location)
+ migrate (undefined :: News)
+ migrate (undefined :: NewsTeam)
+ migrate (undefined :: News_NewsTeam)
+ migrate (undefined :: News_Location)
+
+ dbimport message = do
+ -- Insert the message and acquire its primary key (unique ID)
+ news_id <- insert_xml message
+
+ -- Now insert the teams. We use insert_or_select because we know
+ -- that most teams will already exist, and we want to get back the
+ -- id for the existing team when there's a collision.
+ nt_ids <- mapM insert_or_select (xml_teams message)
+
+ -- Now that the teams have been inserted, create
+ -- news__news_team records mapping beween the two.
+ let news_news_teams = map (News_NewsTeam news_id) nt_ids
+ mapM_ insert_ news_news_teams
+
+ -- Do all of that over again for the Locations.
+ loc_ids <- mapM insert_xml_or_select (xml_locations message)
+ let news_news_locations = map (News_Location news_id) loc_ids
+ mapM_ insert_ news_news_locations
+
+ return ImportSucceeded
+
+
+-- These types don't have special XML representations or field name
+-- collisions so we use the defaultCodegenConfig and give their
+-- fields nice simple names.
+mkPersist defaultCodegenConfig [groundhog|