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

diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs
index 550801b..a2421e9 100644
--- a/src/TSN/XML/News.hs
+++ b/src/TSN/XML/News.hs
@@ -3,7 +3,6 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -12,8 +11,8 @@
 --   root element \<message\> that contains an entire news item.
 --
 module TSN.XML.News (
-  News,
-  news_tests )
+  news_tests,
+  pickle_message )
 where
 
 import Data.Data ( Data, constrFields, dataTypeConstrs, dataTypeOf )
@@ -21,23 +20,17 @@ 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,
@@ -52,8 +45,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 )
 
 
 
@@ -62,6 +56,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 +79,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 +134,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
@@ -214,8 +236,6 @@ pickle_news_team =
     from_string :: String -> NewsTeam
     from_string = NewsTeam
 
-instance XmlPickler NewsTeam where
-  xpickle = pickle_news_team
 
 pickle_msg_id :: PU MsgId
 pickle_msg_id =
@@ -226,8 +246,6 @@ pickle_msg_id =
     from_tuple = uncurryN MsgId
     to_tuple m = (db_msg_id m, db_event_id m)
 
-instance XmlPickler MsgId where
-  xpickle = pickle_msg_id
 
 pickle_location :: PU NewsLocation
 pickle_location =
@@ -241,8 +259,6 @@ pickle_location =
       uncurryN NewsLocation
     to_tuple l = (city l, state l, country l)
 
-instance XmlPickler NewsLocation where
-  xpickle = pickle_location
 
 
 pickle_message :: PU Message
@@ -291,54 +307,6 @@ pickle_message =
         to_string :: [String] -> String
         to_string = join "\n"
 
-instance XmlPickler Message where
-  xpickle = pickle_message
-
-
-
-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
@@ -383,7 +351,7 @@ test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
           "test/xml/newsxml-with-editor.xml" ]
   where
     check desc path = testCase desc $ do
-      (expected :: [Message], actual) <- pickle_unpickle "message" path
+      (expected, actual) <- pickle_unpickle pickle_message path
       actual @?= expected