X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FNews.hs;h=f799a5238b1fe3013b764153d3571149881f0cb4;hb=c792c3bb79e83b5bb8d65984de51f2416b7a2d8e;hp=2d081aac7cc935e0833b2552347768779746434c;hpb=44e32bf7b5aa2d0b98b40f25ec650d9b3e0f01ca;p=dead%2Fhtsn-import.git

diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs
index 2d081aa..f799a52 100644
--- a/src/TSN/XML/News.hs
+++ b/src/TSN/XML/News.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
@@ -13,7 +12,7 @@
 --   root element \<message\> that contains an entire news item.
 --
 module TSN.XML.News (
-  News,
+  Message,
   news_tests )
 where
 
@@ -22,23 +21,18 @@ import Data.List.Utils ( join, split )
 import Data.Tuple.Curry ( uncurryN )
 import Data.Typeable ( Typeable )
 import Database.Groundhog (
-  defaultMigrationLogger,
-  insert,
-  insertByAll,
-  migrate,
-  runMigration )
+  insert_,
+  migrate )
 import Database.Groundhog.Core ( DefaultKey )
 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,8 +47,9 @@ import Text.XML.HXT.Core (
 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.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
+import TSN.XmlImport ( XmlImport(..) )
+import Xml ( FromXml(..), pickle_unpickle, unpickleable )
 
 
 
@@ -63,6 +58,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.
@@ -79,6 +81,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.
@@ -127,33 +136,47 @@ 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 _ =
+    run_dbmigrate $ 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 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.
+    nt_ids <- mapM insert_xml_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 NewsLocations.
+    loc_ids <- mapM insert_xml_or_select (xml_locations message)
+    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
@@ -297,51 +320,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 =