X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FMain.hs;h=e1f40267889c9e4a8a4609cb0a7e7bf9c3b47b95;hb=cdd0f36ab4aa8aadc416f6b9cbe6117c26d2ddf2;hp=e94d21b4fa7e264d39469daec8ad730a8838895f;hpb=ce611b60b9c42e176b215453f0d0f862d2d5d0fd;p=dead%2Fhtsn-import.git

diff --git a/src/Main.hs b/src/Main.hs
index e94d21b..e1f4026 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,18 +1,21 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
 module Main
 where
 
 import Control.Arrow ( (&&&), arr, returnA )
 import Control.Monad ( when )
 import Control.Monad.IO.Class ( liftIO )
-import Database.Groundhog.Core ( PersistEntity )
-import Database.Groundhog.Sqlite (
+import Database.Groundhog (
   defaultMigrationLogger,
   insert,
   migrate,
-  runDbConn,
-  runMigration,
+  runMigration )
+import Database.Groundhog.Core ( PersistEntity )
+import Database.Groundhog.Generic ( runDbConn )
+import Database.Groundhog.Sqlite (
   withSqliteConn )
-import Data.Maybe ( isNothing )
+import Database.Groundhog.Postgresql (
+  withPostgresqlConn )
 import Data.Monoid ( (<>) )
 import System.Console.CmdArgs ( def )
 import System.Exit ( exitWith, ExitCode (ExitFailure) )
@@ -39,14 +42,14 @@ import Text.XML.HXT.Core (
   xpickle,
   yes )
 
+import Backend ( Backend(..) )
 import CommandLine ( get_args )
 import Configuration ( Configuration(..), merge_optional )
-import ExitCodes (
-  exit_no_connection_string,
-  exit_no_xml_files )
+import ConnectionString ( ConnectionString(..) )
+import ExitCodes ( exit_no_xml_files )
 import Network.Services.TSN.Logging ( init_logging )
 import qualified OptionalConfiguration as OC (
-  OptionalConfiguration ( connection_string, xml_files ),
+  OptionalConfiguration ( xml_files ),
   from_rc )
 import Network.Services.TSN.Report (
   report_info,
@@ -76,44 +79,56 @@ parse_opts =
     withValidate no ]
 
 
--- | We put the 'XmlTree' argument last so that it's easy to eta
---   reduce all of the import_foo functions that call this.
+-- | 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, PersistEntity b)
                => b          -- ^ Dummy Listing instance needed for 'migrate'
                -> (a -> [b]) -- ^ listings getter
+               -> Configuration
                -> XmlTree
                -> IO (Maybe Int) -- ^ Return the number of records inserted.
-import_generic dummy g xml =
-  withSqliteConn "foo.sqlite3" $ runDbConn $ do
-    runMigration defaultMigrationLogger $ do
-      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 (\l -> insert l) (g elt)
-        return $ Just (length ids)
+import_generic dummy g cfg xml
+  | backend cfg == Postgres = withPostgresqlConn cs go
+  | otherwise               = withSqliteConn cs go
+  where
+    -- | Pull the real connection String out  of the configuration.
+    cs :: String
+    cs = get_connection_string $ connection_string cfg
+
+    -- Needs NoMonomorphismRestriction to be allowed to return
+    -- different types in the two cases above.
+    go = runDbConn $ 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)
+
+
 
 -- | Import TSN.Injuries from an 'XmlTree'.
-import_injuries :: XmlTree -> IO (Maybe Int)
+import_injuries :: Configuration -> XmlTree -> IO (Maybe Int)
 import_injuries =
   import_generic
     (undefined :: Injuries.Listing)
     Injuries.listings
 
 -- | Import TSN.InjuriesDetail from an 'XmlTree'.
-import_injuries_detail :: XmlTree -> IO (Maybe Int)
+import_injuries_detail :: Configuration -> XmlTree -> IO (Maybe Int)
 import_injuries_detail =
   import_generic
     (undefined :: InjuriesDetail.PlayerListing)
     ( (concatMap InjuriesDetail.player_listings) . InjuriesDetail.listings)
 
-import_file :: FilePath -> IO ()
-import_file path = do
+import_file :: Configuration -> FilePath -> IO ()
+import_file cfg path = do
   results <- catchIOError
                parse_and_import
                (\e -> do
@@ -151,7 +166,7 @@ import_file path = do
     --   big one outside of the list.
     parse_and_import :: IO [Maybe Int]
     parse_and_import =
-      (runX $ readA >>> (doctypeA &&& returnA) >>> (arr import_with_dtd))
+      runX (readA >>> (doctypeA &&& returnA) >>> (arr import_with_dtd))
       >>=
       sequence
 
@@ -159,8 +174,8 @@ import_file path = do
     --   determine which function to call on the 'XmlTree'.
     import_with_dtd :: (String, XmlTree) -> IO (Maybe Int)
     import_with_dtd (dtd,xml)
-      | dtd == "injuriesxml.dtd" = import_injuries xml
-      | dtd == "Injuries_Detail_XML.dtd" = import_injuries_detail xml
+      | dtd == "injuriesxml.dtd" = import_injuries cfg xml
+      | dtd == "Injuries_Detail_XML.dtd" = import_injuries_detail cfg xml
       | otherwise = do
           report_info $ "Unrecognized DTD in " ++ path ++ ": " ++ dtd ++ "."
           return Nothing
@@ -186,13 +201,6 @@ main = do
     report_error "No XML files given."
     exitWith (ExitFailure exit_no_xml_files)
 
-  -- There's a default connection string, namely the empty string, but
-  -- it's not much use to us. So we make sure that we were given
-  -- something explicitly.
-  when (isNothing (OC.connection_string opt_config)) $ do
-    report_error "No connection string supplied."
-    exitWith (ExitFailure exit_no_connection_string)
-
   -- We don't do this in parallel (for now?) to keep the error
   -- messages nice and linear.
-  mapM_ import_file (OC.xml_files opt_config)
+  mapM_ (import_file cfg) (OC.xml_files opt_config)