+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
+
+
+-- * NewsTeamXml
+
+-- | The XML type for teams as they show up in the news. We can't
+-- reuse the representation from "TSN.Team" because our name doesn't
+-- appear optional and we have no abbreviation.
+--
+data NewsTeamXml =
+ NewsTeamXml { xml_team_id :: String,
+ xml_team_name :: String }
+ deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'Generics.to_tuple'.
+--
+instance Generic NewsTeamXml
+
+
+instance ToDb NewsTeamXml where
+ -- | The database representation of 'NewsTeamXml' is 'Team'.
+ type Db NewsTeamXml = Team
+
+-- | Convert the XML representation 'NewsTeamXml' to the database
+-- representation 'Team'.
+--
+instance FromXml NewsTeamXml where
+ from_xml NewsTeamXml{..} =
+ Team { team_id = xml_team_id,
+ abbreviation = Nothing,
+ name = Just xml_team_name }
+
+-- | Allow us to import 'NewsTeamXml' directly.
+--
+instance XmlImport NewsTeamXml
+
+
+-- * News_Team
+
+-- | Mapping between News records and Team 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_Team = News_Team (DefaultKey News) (DefaultKey Team)
+
+
+-- * 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)
+
+
+
+
+-- | Some newsxml documents contain two \<SMS\> elements in a row,
+-- violating the DTD. The second one has always been empty, but it's
+-- irrelevant: we can't parse these, and would like to detect them
+-- in order to report the fact that the busted document is
+-- unsupported.
+--
+-- This function detects whether two \<SMS\> elements appear in a
+-- row, as siblings.
+--
+has_only_single_sms :: XmlTree -> Bool
+has_only_single_sms xmltree =
+ case elements of
+ [] -> True
+ _ -> False
+ where
+ parse :: XmlTree -> [XmlTree]
+ parse = runLA $ hasName "/"
+ /> hasName "message"
+ >>> addNav
+ >>> descendantAxis
+ >>> filterAxis (hasName "SMS")
+ >>> followingSiblingAxis
+ >>> remNav
+ >>> hasName "SMS"
+
+ elements = parse xmltree
+
+
+--
+-- * Database code
+--
+
+-- | Define 'dbmigrate' and 'dbimport' for 'Message's. The import is
+-- slightly non-generic because of our 'News_Team' and
+-- 'News_Location' join tables.
+--
+instance DbImport Message where
+ dbmigrate _ =
+ run_dbmigrate $ do
+ migrate (undefined :: Location)
+ migrate (undefined :: News)
+ migrate (undefined :: Team)
+ migrate (undefined :: News_Team)
+ 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_xml_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.
+ team_ids <- mapM insert_xml_or_select (xml_teams message)
+
+ -- Now that the teams have been inserted, create
+ -- news__team records mapping beween the two.
+ let news_teams = map (News_Team news_id) team_ids
+ mapM_ insert_ news_teams
+
+ -- Do all of that over again for the Locations.
+ loc_ids <- mapM insert_or_select (xml_locations message)
+ let news_news_locations = map (News_Location news_id) loc_ids
+ mapM_ insert_ news_news_locations
+
+ return ImportSucceeded
+