src/Main.hs

   1 {-# LANGUAGE NoMonomorphismRestriction #-}
   2 module Main
   3 where
   4
   5 import Control.Arrow ( (&&&), arr, returnA )
   6 import Control.Monad ( when )
   7 import Control.Monad.IO.Class ( liftIO )
   8 import Database.Groundhog (
   9   defaultMigrationLogger,
  10   insert,
  11   migrate,
  12   runMigration )
  13 import Database.Groundhog.Core ( PersistEntity )
  14 import Database.Groundhog.Generic ( runDbConn )
  15 import Database.Groundhog.Sqlite (
  16   withSqliteConn )
  17 import Database.Groundhog.Postgresql (
  18   withPostgresqlConn )
  19 import Data.Monoid ( (<>) )
  20 import System.Console.CmdArgs ( def )
  21 import System.Exit ( exitWith, ExitCode (ExitFailure) )
  22 import System.IO.Error ( catchIOError )
  23 import Text.XML.HXT.Core (
  24   ArrowXml,
  25   IOStateArrow,
  26   XmlPickler,
  27   XmlTree,
  28   (>>>),
  29   (/>),
  30   getAttrl,
  31   getText,
  32   hasName,
  33   readDocument,
  34   runX,
  35   unpickleDoc,
  36   xpickle )
  37
  38 import Backend ( Backend(..) )
  39 import CommandLine ( get_args )
  40 import Configuration ( Configuration(..), merge_optional )
  41 import ConnectionString ( ConnectionString(..) )
  42 import ExitCodes ( exit_no_xml_files )
  43 import Network.Services.TSN.Logging ( init_logging )
  44 import qualified OptionalConfiguration as OC (
  45   OptionalConfiguration ( xml_files ),
  46   from_rc )
  47 import Network.Services.TSN.Report (
  48   report_info,
  49   report_error )
  50 import qualified TSN.Injuries as Injuries (
  51   Listing,
  52   Message ( listings ) )
  53 import qualified TSN.InjuriesDetail as InjuriesDetail (
  54   Listing ( player_listings ),
  55   Message ( listings ),
  56   PlayerListing )
  57 import Xml ( parse_opts )
  58
  59
  60 -- | We put the 'Configuration' and 'XmlTree' arguments last so that
  61 -- it's easy to eta reduce all of the import_foo functions that call
  62 -- this.
  63 --
  64 import_generic :: (XmlPickler a, PersistEntity b)
  65                => b          -- ^ Dummy Listing instance needed for 'migrate'
  66                -> (a -> [b]) -- ^ listings getter
  67                -> Configuration
  68                -> XmlTree
  69                -> IO (Maybe Int) -- ^ Return the number of records inserted.
  70 import_generic dummy g cfg xml
  71   | backend cfg == Postgres = withPostgresqlConn cs go
  72   | otherwise               = withSqliteConn cs go
  73   where
  74     -- | Pull the real connection String out  of the configuration.
  75     cs :: String
  76     cs = get_connection_string $ connection_string cfg
  77
  78     -- Needs NoMonomorphismRestriction to be allowed to return
  79     -- different types in the two cases above.
  80     go = runDbConn $ do
  81       runMigration defaultMigrationLogger $ migrate dummy
  82       let root_element = unpickleDoc xpickle xml
  83       case root_element of
  84         Nothing -> do
  85           let msg = "Could not unpickle document in import_generic."
  86           liftIO $ report_error msg
  87           return Nothing
  88         Just elt  -> do
  89           ids <- mapM insert (g elt)
  90           return $ Just (length ids)
  91
  92
  93
  94 -- | Import TSN.Injuries from an 'XmlTree'.
  95 import_injuries :: Configuration -> XmlTree -> IO (Maybe Int)
  96 import_injuries =
  97   import_generic
  98     (undefined :: Injuries.Listing)
  99     Injuries.listings
 100
 101 -- | Import TSN.InjuriesDetail from an 'XmlTree'.
 102 import_injuries_detail :: Configuration -> XmlTree -> IO (Maybe Int)
 103 import_injuries_detail =
 104   import_generic
 105     (undefined :: InjuriesDetail.PlayerListing)
 106     ( (concatMap InjuriesDetail.player_listings) . InjuriesDetail.listings)
 107
 108 import_file :: Configuration -> FilePath -> IO ()
 109 import_file cfg path = do
 110   results <- catchIOError
 111                parse_and_import
 112                (\e -> do
 113                   report_error (show e)
 114                   report_error $ "Failed to import file " ++ path ++ "."
 115                   -- Return a nonempty list so we don't claim incorrectly that
 116                   -- we couldn't parse the DTD.
 117                   return [ Nothing ] )
 118
 119   case results of
 120     -- If results' is empty, one of the arrows return "nothing."
 121     []    -> report_error $ "Unable to determine DTD for file " ++ path ++ "."
 122     (r:_) ->
 123       case r of
 124         Nothing -> return ()
 125         Just cnt -> report_info $ "Successfully imported " ++
 126                                   (show cnt) ++
 127                                   " records from " ++ path ++ "."
 128   where
 129     -- | An arrow that reads a document into an 'XmlTree'.
 130     readA :: IOStateArrow s a XmlTree
 131     readA = readDocument parse_opts path
 132
 133     -- | An arrow which parses the doctype "SYSTEM" of an 'XmlTree'.
 134     --   We use these to determine the parser to use.
 135     doctypeA :: ArrowXml a => a XmlTree String
 136     doctypeA = getAttrl >>> hasName "doctype-SYSTEM" /> getText
 137
 138     -- | Combine the arrows above as well as the function below
 139     --   (arrowized with 'arr') into an IO action that does everything
 140     --   (parses and then runs the import on what was parsed).
 141     --
 142     --   The result of runX has type IO [IO (Maybe Int)]. We thus use
 143     --   bind (>>=) and sequence to combine all of the IOs into one
 144     --   big one outside of the list.
 145     parse_and_import :: IO [Maybe Int]
 146     parse_and_import =
 147       runX (readA >>> (doctypeA &&& returnA) >>> (arr import_with_dtd))
 148       >>=
 149       sequence
 150
 151     -- | Takes a 'Doctype', 'XmlTree' pair and uses the 'Doctype' to
 152     --   determine which function to call on the 'XmlTree'.
 153     import_with_dtd :: (String, XmlTree) -> IO (Maybe Int)
 154     import_with_dtd (dtd,xml)
 155       | dtd == "injuriesxml.dtd" = import_injuries cfg xml
 156       | dtd == "Injuries_Detail_XML.dtd" = import_injuries_detail cfg xml
 157       | otherwise = do
 158           report_info $ "Unrecognized DTD in " ++ path ++ ": " ++ dtd ++ "."
 159           return Nothing
 160
 161 main :: IO ()
 162 main = do
 163   rc_cfg <- OC.from_rc
 164   cmd_cfg <- get_args
 165
 166   -- Merge the config file options with the command-line ones,
 167   -- prefering the command-line ones.
 168   let opt_config = rc_cfg <> cmd_cfg
 169
 170   -- Update a default config with any options that have been set in
 171   -- either the config file or on the command-line.  We initialize
 172   -- logging before the missing parameter checks below so that we can
 173   -- log the errors.
 174   let cfg = (def :: Configuration) `merge_optional` opt_config
 175   init_logging (log_file cfg) (log_level cfg) (syslog cfg)
 176
 177   -- Check the optional config for missing required options.
 178   when (null $ OC.xml_files opt_config) $ do
 179     report_error "No XML files given."
 180     exitWith (ExitFailure exit_no_xml_files)
 181
 182   -- We don't do this in parallel (for now?) to keep the error
 183   -- messages nice and linear.
 184   mapM_ (import_file cfg) (OC.xml_files opt_config)