X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FNews.hs;h=8da43296e02d43a4b9cd6f8aad28cafc5e49df02;hb=ce9fabd584f2e8844b8b1ede9b29bb573e2033f7;hp=550801be49d36b1eda74c0127d70be41528866b8;hpb=53c5550fee7f8a39a7906545978f15876a06fbd1;p=dead%2Fhtsn-import.git

diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs
index 550801b..8da4329 100644
--- a/src/TSN/XML/News.hs
+++ b/src/TSN/XML/News.hs
@@ -12,7 +12,7 @@
 --   root element \<message\> that contains an entire news item.
 --
 module TSN.XML.News (
-  News,
+  Message,
   news_tests )
 where
 
@@ -22,8 +22,7 @@ import Data.Tuple.Curry ( uncurryN )
 import Data.Typeable ( Typeable )
 import Database.Groundhog (
   defaultMigrationLogger,
-  insert,
-  insertByAll,
+  insert_,
   migrate,
   runMigration )
 import Database.Groundhog.Core ( DefaultKey )
@@ -31,13 +30,11 @@ import Database.Groundhog.TH (
   defaultCodegenConfig,
   groundhog,
   mkPersist )
-import System.Console.CmdArgs.Default ( Default(..) )
 import Test.Tasty ( TestTree, testGroup )
 import Test.Tasty.HUnit ( (@?=), testCase )
 import Text.XML.HXT.Core (
   PU,
   XmlPickler(..),
-  unpickleDoc,
   xp13Tuple,
   xpAttr,
   xpElem,
@@ -53,7 +50,8 @@ import TSN.Codegen (
   tsn_codegen_config,
   tsn_db_field_namer ) -- Used in a test
 import TSN.DbImport ( DbImport(..), ImportResult(..) )
-import Xml ( ToFromXml(..), pickle_unpickle, unpickleable )
+import TSN.XmlImport ( XmlImport(..) )
+import Xml ( FromXml(..), pickle_unpickle, unpickleable )
 
 
 
@@ -62,6 +60,13 @@ data NewsTeam =
   NewsTeam { team_name :: String }
   deriving (Eq, Show)
 
+instance FromXml NewsTeam where
+  type Db NewsTeam = NewsTeam
+  from_xml = id
+
+instance XmlImport NewsTeam
+
+
 -- | Mapping between News records and NewsTeam records in the
 --   database. We name the fields (even though they're never used) for
 --   Groundhog's benefit.
@@ -78,6 +83,13 @@ data NewsLocation =
     country :: String }
   deriving (Eq, Show)
 
+instance FromXml NewsLocation where
+  type Db NewsLocation = NewsLocation
+  from_xml = id
+
+instance XmlImport NewsLocation
+
+
 -- | Mapping between News records and NewsLocation records in the
 --   database. We name the fields (even though they're never used) for
 --   Groundhog's benefit.
@@ -126,33 +138,51 @@ data News =
     db_continue :: Maybe String }
   deriving (Data, Eq, Show, Typeable)
 
-instance ToFromXml News where
-  type Xml News = Message
-  type Container News = ()
-
-  -- Use a record wildcard here so GHC doesn't complain that we never
-  -- used our named fields.
-  to_xml (News {..}) =
-    Message
-      def
-      def
-      db_mid
-      def
-      db_sport
-      db_url
-      def
-      def
-      db_sms
-      db_editor
-      db_text
-      db_continue
-      def
+instance FromXml Message where
+  type Db Message = News
 
   -- We don't need the key argument (from_xml_fk) since the XML type
   -- contains more information in this case.
   from_xml (Message _ _ c _ e f _ _ i j k l _) =
     News c e f i j k l
 
+instance XmlImport Message
+
+instance DbImport Message where
+  dbmigrate _ =
+    runMigration defaultMigrationLogger $ do
+      migrate (undefined :: NewsTeam)
+      migrate (undefined :: NewsLocation)
+      migrate (undefined :: News)
+      migrate (undefined :: News_NewsTeam)
+      migrate (undefined :: News_NewsLocation)
+
+  dbimport message = do
+    -- Insert the message and acquire its primary key (unique ID)
+    news_id <- insert_xml message
+
+    -- And insert each one into its own table. We use insertByAll_xml
+    -- because we know that most teams will already exist, and we
+    -- want to get back a Left (id) for the existing team when
+    -- there's a collision. In fact, if the insert succeeds, we'll
+    -- get a Right (id) back, so we can disregard the Either
+    -- constructor entirely. That's what the (either id id) does.
+    either_nt_ids <- mapM insertByAll_xml (xml_teams message)
+    let nt_ids = map (either id id) either_nt_ids
+
+    -- 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 NewsLocations.
+    either_loc_ids <- mapM insertByAll_xml (xml_locations message)
+    let loc_ids = map (either id id) either_loc_ids
+    let news_news_locations = map (News_NewsLocation 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
@@ -296,51 +326,6 @@ instance XmlPickler Message where
 
 
 
-instance DbImport News where
-  dbimport _ xml = do
-    runMigration defaultMigrationLogger $ do
-      migrate (undefined :: News)
-      migrate (undefined :: NewsTeam)
-      migrate (undefined :: NewsLocation)
-      migrate (undefined :: News_NewsTeam)
-      migrate (undefined :: News_NewsLocation)
-    let root_element = unpickleDoc xpickle xml :: Maybe Message
-    case root_element of
-      Nothing -> do
-        let errmsg = "Could not unpickle News message in dbimport."
-        return $ ImportFailed errmsg
-      Just message  -> do
-        -- Insert the message and acquire its primary key (unique ID)
-        news_id <- insert (from_xml message :: News)
-
-        -- And insert each one into its own table. We use insertByAll
-        -- because we know that most teams will already exist, and we
-        -- want to get back a Left (id) for the existing team when
-        -- there's a collision. In fact, if the insert succeeds, we'll
-        -- get a Right (id) back, so we can disregard the Either
-        -- constructor entirely. That's what the (either id id) does.
-        either_nt_ids <- mapM insertByAll (xml_teams message)
-        let nt_ids = map (either id id) either_nt_ids
-
-        -- 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
-        nnt_ids <- mapM insert news_news_teams
-
-
-        -- Do all of that over again for the NewsLocations.
-        either_loc_ids <- mapM insertByAll (xml_locations message)
-        let loc_ids = map (either id id) either_loc_ids
-        let news_news_locations = map (News_NewsLocation news_id) loc_ids
-        nnl_ids <- mapM insertByAll news_news_locations
-
-        return $ ImportSucceeded (1 + -- for the News
-                                  (length nt_ids) +
-                                  (length loc_ids) +
-                                  (length nnt_ids) +
-                                  (length nnl_ids))
-
-
 -- * Tasty Tests
 news_tests :: TestTree
 news_tests =