src/Main.hs

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