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 qualified TSN.News as News ( Message )
  58 import Xml ( parse_opts )
  59
  60
  61 -- | We put the 'Configuration' and 'XmlTree' arguments last so that
  62 -- it's easy to eta reduce all of the import_foo functions that call
  63 -- this.
  64 --
  65 import_generic :: (XmlPickler a, PersistEntity b)
  66                => b          -- ^ Dummy Listing instance needed for 'migrate'
  67                -> (a -> [b]) -- ^ listings getter
  68                -> Configuration
  69                -> XmlTree
  70                -> IO (Maybe Int) -- ^ Return the number of records inserted.
  71 import_generic dummy g cfg xml
  72   | backend cfg == Postgres = withPostgresqlConn cs go
  73   | otherwise               = withSqliteConn cs go
  74   where
  75     -- | Pull the real connection String out  of the configuration.
  76     cs :: String
  77     cs = get_connection_string $ connection_string cfg
  78
  79     -- Needs NoMonomorphismRestriction to be allowed to return
  80     -- different types in the two cases above.
  81     go = runDbConn $ do
  82       runMigration defaultMigrationLogger $ migrate dummy
  83       let root_element = unpickleDoc xpickle xml
  84       case root_element of
  85         Nothing -> do
  86           let msg = "Could not unpickle document in import_generic."
  87           liftIO $ report_error msg
  88           return Nothing
  89         Just elt  -> do
  90           ids <- mapM insert (g elt)
  91           return $ Just (length ids)
  92
  93
  94
  95 -- | Import TSN.News from an 'XmlTree'.
  96 import_news :: Configuration -> XmlTree -> IO (Maybe Int)
  97 import_news =
  98   import_generic
  99     (undefined :: News.Message)
 100     id
 101
 102 -- | Import TSN.Injuries from an 'XmlTree'.
 103 import_injuries :: Configuration -> XmlTree -> IO (Maybe Int)
 104 import_injuries =
 105   import_generic
 106     (undefined :: Injuries.Listing)
 107     Injuries.listings
 108
 109 -- | Import TSN.InjuriesDetail from an 'XmlTree'.
 110 import_injuries_detail :: Configuration -> XmlTree -> IO (Maybe Int)
 111 import_injuries_detail =
 112   import_generic
 113     (undefined :: InjuriesDetail.PlayerListing)
 114     ( (concatMap InjuriesDetail.player_listings) . InjuriesDetail.listings)
 115
 116 import_file :: Configuration -> FilePath -> IO ()
 117 import_file cfg path = do
 118   results <- catchIOError
 119                parse_and_import
 120                (\e -> do
 121                   report_error (show e)
 122                   report_error $ "Failed to import file " ++ path ++ "."
 123                   -- Return a nonempty list so we don't claim incorrectly that
 124                   -- we couldn't parse the DTD.
 125                   return [ Nothing ] )
 126
 127   case results of
 128     -- If results' is empty, one of the arrows return "nothing."
 129     []    -> report_error $ "Unable to determine DTD for file " ++ path ++ "."
 130     (r:_) ->
 131       case r of
 132         Nothing -> return ()
 133         Just cnt -> report_info $ "Successfully imported " ++
 134                                   (show cnt) ++
 135                                   " records from " ++ path ++ "."
 136   where
 137     -- | An arrow that reads a document into an 'XmlTree'.
 138     readA :: IOStateArrow s a XmlTree
 139     readA = readDocument parse_opts path
 140
 141     -- | An arrow which parses the doctype "SYSTEM" of an 'XmlTree'.
 142     --   We use these to determine the parser to use.
 143     doctypeA :: ArrowXml a => a XmlTree String
 144     doctypeA = getAttrl >>> hasName "doctype-SYSTEM" /> getText
 145
 146     -- | Combine the arrows above as well as the function below
 147     --   (arrowized with 'arr') into an IO action that does everything
 148     --   (parses and then runs the import on what was parsed).
 149     --
 150     --   The result of runX has type IO [IO (Maybe Int)]. We thus use
 151     --   bind (>>=) and sequence to combine all of the IOs into one
 152     --   big one outside of the list.
 153     parse_and_import :: IO [Maybe Int]
 154     parse_and_import =
 155       runX (readA >>> (doctypeA &&& returnA) >>> (arr import_with_dtd))
 156       >>=
 157       sequence
 158
 159     -- | Takes a 'Doctype', 'XmlTree' pair and uses the 'Doctype' to
 160     --   determine which function to call on the 'XmlTree'.
 161     import_with_dtd :: (String, XmlTree) -> IO (Maybe Int)
 162     import_with_dtd (dtd,xml)
 163       | dtd == "injuriesxml.dtd" = import_injuries cfg xml
 164       | dtd == "Injuries_Detail_XML.dtd" = import_injuries_detail cfg xml
 165       | dtd == "newsxml.dtd" = import_news cfg xml
 166       | otherwise = do
 167           report_info $ "Unrecognized DTD in " ++ path ++ ": " ++ dtd ++ "."
 168           return Nothing
 169
 170 main :: IO ()
 171 main = do
 172   rc_cfg <- OC.from_rc
 173   cmd_cfg <- get_args
 174
 175   -- Merge the config file options with the command-line ones,
 176   -- prefering the command-line ones.
 177   let opt_config = rc_cfg <> cmd_cfg
 178
 179   -- Update a default config with any options that have been set in
 180   -- either the config file or on the command-line.  We initialize
 181   -- logging before the missing parameter checks below so that we can
 182   -- log the errors.
 183   let cfg = (def :: Configuration) `merge_optional` opt_config
 184   init_logging (log_file cfg) (log_level cfg) (syslog cfg)
 185
 186   -- Check the optional config for missing required options.
 187   when (null $ OC.xml_files opt_config) $ do
 188     report_error "No XML files given."
 189     exitWith (ExitFailure exit_no_xml_files)
 190
 191   -- We don't do this in parallel (for now?) to keep the error
 192   -- messages nice and linear.
 193   mapM_ (import_file cfg) (OC.xml_files opt_config)