]> gitweb.michael.orlitzky.com - dead/htsn-import.git/blob - Main.hs
e94d21b4fa7e264d39469daec8ad730a8838895f
[dead/htsn-import.git] / 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)