From: Michael Orlitzky <michael@orlitzky.com>
Date: Tue, 31 Dec 2013 14:19:23 +0000 (-0500)
Subject: Add a DbImport class implementing the import interface.
X-Git-Tag: 0.0.1~140
X-Git-Url: http://gitweb.michael.orlitzky.com/?p=dead%2Fhtsn-import.git;a=commitdiff_plain;h=e46de7e95112d4e35219b74c0b3efffe99c69c6a

Add a DbImport class implementing the import interface.
Write import_injuries, import_injuries_detail, and import_news for the new type class.
Move DbImport instances into the module where the type is defined.
Get the News import working (temporarily) via unsafeCoerce.
---

diff --git a/src/Main.hs b/src/Main.hs
index 9ca0df6..568f0fe 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -5,25 +5,19 @@ where
 import Control.Arrow ( (&&&), arr, returnA )
 import Control.Monad ( when )
 import Control.Monad.IO.Class ( MonadIO, liftIO )
-import Database.Groundhog (
-  defaultMigrationLogger,
-  insert,
-  migrate,
-  runMigration )
-import Database.Groundhog.Core ( PersistBackend, PersistEntity )
 import Database.Groundhog.Generic ( runDbConn )
 import Database.Groundhog.Sqlite (
   withSqliteConn )
 import Database.Groundhog.Postgresql (
   withPostgresqlConn )
 import Data.Monoid ( (<>) )
+import Network.Services.TSN.Logging ( init_logging )
 import System.Console.CmdArgs ( def )
 import System.Exit ( exitWith, ExitCode (ExitFailure) )
 import System.IO.Error ( catchIOError )
 import Text.XML.HXT.Core (
   ArrowXml,
   IOStateArrow,
-  XmlPickler,
   XmlTree,
   (>>>),
   (/>),
@@ -31,84 +25,26 @@ import Text.XML.HXT.Core (
   getText,
   hasName,
   readDocument,
-  runX,
-  unpickleDoc,
-  xpickle )
+  runX )
 
 import Backend ( Backend(..) )
 import CommandLine ( get_args )
 import Configuration ( Configuration(..), merge_optional )
 import ConnectionString ( ConnectionString(..) )
 import ExitCodes ( exit_no_xml_files )
-import Network.Services.TSN.Logging ( init_logging )
 import qualified OptionalConfiguration as OC (
   OptionalConfiguration ( xml_files ),
   from_rc )
 import Network.Services.TSN.Report (
   report_info,
   report_error )
-import qualified TSN.Injuries as Injuries (
-  Listing,
-  Message ( listings ) )
-import qualified TSN.InjuriesDetail as InjuriesDetail (
-  Listing ( player_listings ),
-  Message ( listings ),
-  PlayerListing )
+import TSN.DbImport
+import qualified TSN.Injuries as Injuries ( Listing )
+import qualified TSN.InjuriesDetail as InjuriesDetail ( PlayerListing )
 import qualified TSN.News as News ( Message )
 import Xml ( parse_opts )
 
 
--- | We put the 'Configuration' and 'XmlTree' arguments last so that
--- it's easy to eta reduce all of the import_foo functions that call
--- this.
---
-import_generic :: (XmlPickler a, MonadIO m, PersistEntity b, PersistBackend m)
-               => b          -- ^ Dummy Listing instance needed for 'migrate'
-               -> (a -> [b]) -- ^ listings getter
-               -> XmlTree
-               -> m (Maybe Int) -- ^ Return the number of records inserted.
-import_generic dummy g xml = do
-  -- Needs NoMonomorphismRestriction to be allowed to return
-  -- different types in the two cases above.
-  runMigration defaultMigrationLogger $ migrate dummy
-  let root_element = unpickleDoc xpickle xml
-  case root_element of
-    Nothing -> do
-      let msg = "Could not unpickle document in import_generic."
-      liftIO $ report_error msg
-      return Nothing
-    Just elt  -> do
-      ids <- mapM insert (g elt)
-      return $ Just (length ids)
-
-
-
--- | Import TSN.News from an 'XmlTree'.
-import_news :: (MonadIO m, PersistBackend m)
-            => XmlTree
-            -> m (Maybe Int)
-import_news = -- This implementation is wrroooonnnnngggg.
-  import_generic
-    (undefined :: News.Message)
-    (\m -> [m] :: [News.Message]) -- Turn a Message into a [Message]
-
--- | Import TSN.Injuries from an 'XmlTree'.
-import_injuries :: (MonadIO m, PersistBackend m)
-                => XmlTree
-                -> m (Maybe Int)
-import_injuries =
-  import_generic
-    (undefined :: Injuries.Listing)
-    Injuries.listings
-
--- | Import TSN.InjuriesDetail from an 'XmlTree'.
-import_injuries_detail :: (MonadIO m, PersistBackend m)
-                       => XmlTree
-                       -> m (Maybe Int)
-import_injuries_detail =
-  import_generic
-    (undefined :: InjuriesDetail.PlayerListing)
-    ( (concatMap InjuriesDetail.player_listings) . InjuriesDetail.listings)
 
 import_file :: Configuration -> FilePath -> IO ()
 import_file cfg path = do
@@ -157,6 +93,7 @@ import_file cfg path = do
     --   determine which function to call on the 'XmlTree'.
     import_with_dtd :: (String, XmlTree) -> IO (Maybe Int)
     import_with_dtd (dtd,xml) =
+      -- We need NoMonomorphismRestriction here.
       if backend cfg == Postgres
       then withPostgresqlConn cs $ runDbConn $ importer xml
       else withSqliteConn cs $ runDbConn $ importer xml
@@ -166,9 +103,15 @@ import_file cfg path = do
         cs = get_connection_string $ connection_string cfg
 
         importer
-          | dtd == "injuriesxml.dtd" = import_injuries
-          | dtd == "Injuries_Detail_XML.dtd" = import_injuries_detail
-          | dtd == "newsxml.dtd" = import_news
+          | dtd == "injuriesxml.dtd" =
+              dbimport (undefined :: Injuries.Listing)
+
+          | dtd == "Injuries_Detail_XML.dtd" =
+              dbimport (undefined :: InjuriesDetail.PlayerListing)
+
+          | dtd == "newsxml.dtd" =
+              dbimport (undefined :: News.Message)
+
           | otherwise = \_ -> do -- Dummy arg simplifies the other cases.
               let errmsg = "Unrecognized DTD in " ++ path ++ ": " ++ dtd ++ "."
               liftIO $ report_info errmsg
diff --git a/src/TSN/DbImport.hs b/src/TSN/DbImport.hs
new file mode 100644
index 0000000..8309255
--- /dev/null
+++ b/src/TSN/DbImport.hs
@@ -0,0 +1,47 @@
+-- | Definition of the DbImport typeclass.
+module TSN.DbImport
+where
+
+import Control.Monad.IO.Class ( MonadIO, liftIO )
+import Database.Groundhog (
+  defaultMigrationLogger,
+  insert,
+  migrate,
+  runMigration )
+import Database.Groundhog.Core ( PersistBackend, PersistEntity )
+import Network.Services.TSN.Report ( report_error )
+import Text.XML.HXT.Core (
+  XmlPickler,
+  XmlTree,
+  unpickleDoc,
+  xpickle )
+
+-- | Instances of this type know how to insert themselves into a
+--   Groundhog database.
+class DbImport a where
+  dbimport :: (MonadIO m, PersistBackend m)
+           => a
+           -> XmlTree
+           -> m (Maybe Int)
+
+
+-- | We put the 'Configuration' and 'XmlTree' arguments last so that
+-- it's easy to eta reduce all of the import_foo functions that call
+-- this.
+--
+import_generic :: (XmlPickler a, MonadIO m, PersistEntity b, PersistBackend m)
+               => (a -> [b]) -- ^ listings getter
+               -> b          -- ^ Dummy Listing instance needed for 'migrate'
+               -> XmlTree
+               -> m (Maybe Int) -- ^ Return the number of records inserted.
+import_generic g dummy xml = do
+  runMigration defaultMigrationLogger $ migrate dummy
+  let root_element = unpickleDoc xpickle xml
+  case root_element of
+    Nothing -> do
+      let msg = "Could not unpickle document in import_generic."
+      liftIO $ report_error msg
+      return Nothing
+    Just elt  -> do
+      ids <- mapM insert (g elt)
+      return $ Just (length ids)
diff --git a/src/TSN/Injuries.hs b/src/TSN/Injuries.hs
index 0b19c79..8c2de14 100644
--- a/src/TSN/Injuries.hs
+++ b/src/TSN/Injuries.hs
@@ -21,7 +21,10 @@ where
 
 import Data.Tuple.Curry ( uncurryN )
 import Database.Groundhog()
-import Database.Groundhog.TH
+import Database.Groundhog.TH (
+  defaultCodegenConfig,
+  groundhog,
+  mkPersist )
 import Test.Tasty ( TestTree, testGroup )
 import Test.Tasty.HUnit ( (@?=), testCase )
 import Text.XML.HXT.Core (
@@ -36,6 +39,7 @@ import Text.XML.HXT.Core (
   xpWrap )
 
 
+import TSN.DbImport ( DbImport(..), import_generic )
 import Xml ( pickle_unpickle )
 
 
@@ -104,6 +108,9 @@ instance XmlPickler Message where
 
 
 
+instance DbImport Listing where
+  dbimport = import_generic listings
+
 -- * Tasty Tests
 injuries_tests :: TestTree
 injuries_tests =
diff --git a/src/TSN/InjuriesDetail.hs b/src/TSN/InjuriesDetail.hs
index fda6cc8..a787ad5 100644
--- a/src/TSN/InjuriesDetail.hs
+++ b/src/TSN/InjuriesDetail.hs
@@ -27,7 +27,10 @@ where
 import Data.Time ( UTCTime )
 import Data.Tuple.Curry ( uncurryN )
 import Database.Groundhog()
-import Database.Groundhog.TH
+import Database.Groundhog.TH (
+  defaultCodegenConfig,
+  groundhog,
+  mkPersist )
 import Test.Tasty ( TestTree, testGroup )
 import Test.Tasty.HUnit ( (@?=), testCase )
 import Text.XML.HXT.Core (
@@ -43,6 +46,7 @@ import Text.XML.HXT.Core (
   xpText0,
   xpWrap )
 
+import TSN.DbImport ( DbImport(..), import_generic )
 import TSN.Picklers( xp_date, xp_team_id )
 import Xml ( pickle_unpickle )
 
@@ -153,6 +157,9 @@ pickle_message =
 instance XmlPickler Message where
   xpickle = pickle_message
 
+instance DbImport PlayerListing where
+  dbimport = import_generic ( (concatMap player_listings) . listings)
+
 
 -- * Tasty Tests
 injuries_detail_tests :: TestTree
diff --git a/src/TSN/News.hs b/src/TSN/News.hs
index 74b4846..1796963 100644
--- a/src/TSN/News.hs
+++ b/src/TSN/News.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE QuasiQuotes #-}
@@ -14,15 +15,27 @@ module TSN.News (
   news_tests )
 where
 
+import Control.Monad.IO.Class ( MonadIO, liftIO )
+import Data.Int ( Int64 )
 import Data.List.Utils ( join, split )
 import Data.Tuple.Curry ( uncurryN )
-import Database.Groundhog()
-import Database.Groundhog.TH
+import Database.Groundhog (
+  defaultMigrationLogger,
+  insert,
+  migrate,
+  runMigration )
+import Database.Groundhog.Core ( DefaultKey, PersistBackend )
+import Database.Groundhog.TH (
+  defaultCodegenConfig,
+  groundhog,
+  mkPersist )
 import Test.Tasty ( TestTree, testGroup )
 import Test.Tasty.HUnit ( (@?=), testCase )
 import Text.XML.HXT.Core (
   PU,
   XmlPickler(..),
+  XmlTree,
+  unpickleDoc,
   xp12Tuple,
   xpAttr,
   xpElem,
@@ -33,28 +46,35 @@ import Text.XML.HXT.Core (
   xpText0,
   xpTriple,
   xpWrap )
+import Unsafe.Coerce ( unsafeCoerce )
 
-
+import Network.Services.TSN.Report ( report_error )
+import TSN.DbImport ( DbImport(..) )
 import Xml ( pickle_unpickle )
 
 
--- Can't use a newtype with groundhog.
+-- Can't use a newtype with Groundhog.
 data NewsTeam =
-  NewsTeam { team_name :: String }
-  deriving (Eq, Show)
+  NewsTeam {
+    nt_news_id :: Int64, -- Foreign key.
+    team_name  :: String }
+deriving instance Eq NewsTeam
+deriving instance Show NewsTeam
 
 data MsgId =
   MsgId {
-    msg_id   :: Int,
-    event_id :: String }
+    msg_id       :: Int,
+    event_id     :: String } -- TODO: make optional
   deriving (Eq, Show)
 
 data NewsLocation =
   NewsLocation {
+    loc_news_id  :: Int64, -- Foreign key.
     city :: String,
     state :: String,
     country :: String }
-  deriving (Eq, Show)
+deriving instance Eq NewsLocation
+deriving instance Show NewsLocation
 
 data Message =
   Message {
@@ -76,6 +96,13 @@ data Message =
 mkPersist defaultCodegenConfig [groundhog|
 - entity: NewsTeam
   dbName: news_teams
+  constructors:
+    - name: NewsTeam
+      fields:
+        - name: nt_news_id
+          reference:
+            - table: news
+            - columns: [id]
 
 - entity: NewsLocation
   dbName: news_locations
@@ -106,7 +133,7 @@ pickle_news_team =
     to_string = team_name
 
     from_string :: String -> NewsTeam
-    from_string = NewsTeam
+    from_string = NewsTeam 0
 
 instance XmlPickler NewsTeam where
   xpickle = pickle_news_team
@@ -131,8 +158,9 @@ pickle_location =
              (xpElem "state" xpText)
              (xpElem "country" xpText)
   where
-    from_tuple = uncurryN NewsLocation
-    to_tuple l = (city l, state l, country l)
+    from_tuple =
+      uncurryN (NewsLocation 0)
+    to_tuple l = (city l, state l, country l) -- Don't pickle the PK
 
 instance XmlPickler NewsLocation where
   xpickle = pickle_location
@@ -186,6 +214,30 @@ instance XmlPickler Message where
 
 
 
+instance DbImport Message where
+  dbimport _ xml = do
+    runMigration defaultMigrationLogger $ do
+      migrate (undefined :: Message)
+      migrate (undefined :: NewsTeam)
+      migrate (undefined :: NewsLocation)
+    let root_element = unpickleDoc xpickle xml
+    case root_element of
+      Nothing -> do
+        let errmsg = "Could not unpickle document in import_news."
+        liftIO $ report_error errmsg
+        return Nothing
+      Just message  -> do
+        news_id <- insert message
+
+        let insert_news_team nt = insert (nt { nt_news_id = unsafeCoerce news_id })
+        nt_ids <- mapM insert_news_team (teams message)
+
+        let insert_news_location loc = insert (loc { loc_news_id = unsafeCoerce news_id })
+        loc_ids <- mapM insert_news_location (locations message)
+
+        return $ Just (1 + (length nt_ids) + (length loc_ids))
+
+
 -- * Tasty Tests
 news_tests :: TestTree
 news_tests =