src/Main.hs

   1 {-# LANGUAGE NoMonomorphismRestriction #-}
   2 {-# LANGUAGE DoAndIfThenElse #-}
   3 module Main
   4 where
   5
   6 import Control.Arrow ( (&&&), arr, returnA )
   7 import Control.Concurrent ( threadDelay )
   8 import Control.Exception ( SomeException, catch )
   9 import Control.Monad ( when )
  10 import Database.Groundhog.Generic ( runDbConn )
  11 import Database.Groundhog.Sqlite (
  12   withSqliteConn )
  13 import Database.Groundhog.Postgresql (
  14   withPostgresqlConn )
  15 import Data.Monoid ( (<>) )
  16 import Network.Services.TSN.Logging ( init_logging )
  17 import System.Console.CmdArgs ( def )
  18 import System.Directory ( removeFile )
  19 import System.Exit ( exitWith, ExitCode (ExitFailure) )
  20 import System.IO.Error ( catchIOError )
  21 import Text.XML.HXT.Core (
  22   ArrowXml,
  23   IOStateArrow,
  24   XmlTree,
  25   (>>>),
  26   (/>),
  27   getAttrl,
  28   getText,
  29   hasName,
  30   readDocument,
  31   runX )
  32
  33 import Backend ( Backend(..) )
  34 import CommandLine ( get_args )
  35 import Configuration ( Configuration(..), merge_optional )
  36 import ConnectionString ( ConnectionString(..) )
  37 import ExitCodes ( exit_no_xml_files )
  38 import qualified OptionalConfiguration as OC (
  39   OptionalConfiguration ( xml_files ),
  40   from_rc )
  41 import Network.Services.TSN.Report (
  42   report_info,
  43   report_error )
  44 import TSN.DbImport ( DbImport(..), ImportResult(..) )
  45 import qualified TSN.XML.Heartbeat as Heartbeat ( verify )
  46 import qualified TSN.XML.Injuries as Injuries ( Listing )
  47 import qualified TSN.XML.InjuriesDetail as InjuriesDetail ( PlayerListing )
  48 import qualified TSN.XML.News as News ( Message )
  49 import Xml ( parse_opts )
  50
  51
  52
  53 import_file :: Configuration -> FilePath -> IO Bool
  54 import_file cfg path = do
  55   results <- parse_and_import `catch` exception_handler
  56   case results of
  57     -- If results' is empty, one of the arrows return "nothing."
  58     []    -> do
  59       report_error $ "Unable to determine DTD for file " ++ path ++ "."
  60       return False
  61     (Err errmsg:_) -> do
  62       report_error errmsg
  63       return False
  64     (Info infomsg:_) -> do
  65       report_info infomsg
  66       return True
  67     (Succ count:_) -> do
  68       report_info $ "Successfully imported " ++ (show count) ++
  69                     " records from " ++ path ++ "."
  70       return True
  71   where
  72     exception_handler :: SomeException -> IO [ImportResult]
  73     exception_handler e = do
  74       report_error (show e)
  75       let errdesc = "Failed to import file " ++ path ++ "."
  76       -- Return a nonempty list so we don't claim incorrectly that
  77       -- we couldn't parse the DTD.
  78       return [Err errdesc]
  79
  80     -- | An arrow that reads a document into an 'XmlTree'.
  81     readA :: IOStateArrow s a XmlTree
  82     readA = readDocument parse_opts path
  83
  84     -- | An arrow which parses the doctype "SYSTEM" of an 'XmlTree'.
  85     --   We use these to determine the parser to use.
  86     doctypeA :: ArrowXml a => a XmlTree String
  87     doctypeA = getAttrl >>> hasName "doctype-SYSTEM" /> getText
  88
  89     -- | Combine the arrows above as well as the function below
  90     --   (arrowized with 'arr') into an IO action that does everything
  91     --   (parses and then runs the import on what was parsed).
  92     --
  93     --   The result of runX has type IO [IO ImportResult]. We thus use
  94     --   bind (>>=) and sequence to combine all of the IOs into one
  95     --   big one outside of the list.
  96     parse_and_import :: IO [ImportResult]
  97     parse_and_import =
  98       runX (readA >>> (doctypeA &&& returnA) >>> (arr import_with_dtd))
  99       >>=
 100       sequence
 101
 102     -- | Takes a 'Doctype', 'XmlTree' pair and uses the 'Doctype' to
 103     --   determine which function to call on the 'XmlTree'.
 104     import_with_dtd :: (String, XmlTree) -> IO ImportResult
 105     import_with_dtd (dtd,xml)
 106       | dtd == "Heartbeat.dtd" = Heartbeat.verify xml
 107       | otherwise =
 108         -- We need NoMonomorphismRestriction here.
 109         if backend cfg == Postgres
 110         then withPostgresqlConn cs $ runDbConn $ importer xml
 111         else withSqliteConn cs $ runDbConn $ importer xml
 112         where
 113           -- | Pull the real connection String out  of the configuration.
 114           cs :: String
 115           cs = get_connection_string $ connection_string cfg
 116
 117           importer
 118             | dtd == "injuriesxml.dtd" =
 119                 dbimport (undefined :: Injuries.Listing)
 120
 121             | dtd == "Injuries_Detail_XML.dtd" =
 122                 dbimport (undefined :: InjuriesDetail.PlayerListing)
 123
 124             | dtd == "newsxml.dtd" =
 125                 dbimport (undefined :: News.Message)
 126
 127             | otherwise = \_ -> do -- Dummy arg simplifies the other cases.
 128               let infomsg =
 129                     "Unrecognized DTD in " ++ path ++ ": " ++ dtd ++ "."
 130               return $ Info infomsg
 131
 132
 133 main :: IO ()
 134 main = do
 135   rc_cfg <- OC.from_rc
 136   cmd_cfg <- get_args
 137
 138   -- Merge the config file options with the command-line ones,
 139   -- prefering the command-line ones.
 140   let opt_config = rc_cfg <> cmd_cfg
 141
 142   -- Update a default config with any options that have been set in
 143   -- either the config file or on the command-line.  We initialize
 144   -- logging before the missing parameter checks below so that we can
 145   -- log the errors.
 146   let cfg = (def :: Configuration) `merge_optional` opt_config
 147   init_logging (log_file cfg) (log_level cfg) (syslog cfg)
 148
 149   -- Check the optional config for missing required options.
 150   when (null $ OC.xml_files opt_config) $ do
 151     report_error "No XML files given."
 152     exitWith (ExitFailure exit_no_xml_files)
 153
 154   -- We don't do this in parallel (for now?) to keep the error
 155   -- messages nice and linear.
 156   results <- mapM (import_file cfg) (OC.xml_files opt_config)
 157
 158   -- Zip the results with the files list to find out which ones can be
 159   -- deleted.
 160   let result_pairs = zip (OC.xml_files opt_config) results
 161   let victims = filter (\(_,result) -> result) result_pairs
 162   mapM_ ((kill True) . fst) victims
 163
 164   where
 165     kill try_again path = do
 166       removeFile path `catchIOError` exception_handler
 167       report_info $ "Removed imported file " ++ path ++ "."
 168       where
 169         -- | A wrapper around threadDelay which takes seconds instead of
 170         --   microseconds as its argument.
 171         thread_sleep :: Int -> IO ()
 172         thread_sleep seconds = do
 173           let microseconds = seconds * (10 ^ (6 :: Int))
 174           threadDelay microseconds
 175
 176         exception_handler :: IOError -> IO ()
 177         exception_handler e = do
 178           report_error (show e)
 179           report_error $ "Failed to remove imported file " ++ path ++ "."
 180           if try_again then do
 181             report_info $ "Waiting 5 seconds to attempt removal again..."
 182             thread_sleep 5
 183             kill False path
 184           else
 185             report_info $ "Giving up on " ++ path ++ "."