]> gitweb.michael.orlitzky.com - dead/htsn-import.git/blob - src/TSN/XML/Injuries.hs
Migrate TSN.XML.InjuriesDetail to fixed-vector-hetero.
[dead/htsn-import.git] / src / TSN / XML / Injuries.hs
1 {-# LANGUAGE DeriveGeneric #-}
2 {-# LANGUAGE DeriveDataTypeable #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE GADTs #-}
5 {-# LANGUAGE QuasiQuotes #-}
6 {-# LANGUAGE RecordWildCards #-}
7 {-# LANGUAGE TemplateHaskell #-}
8 {-# LANGUAGE TypeFamilies #-}
9
10 -- | Parse TSN XML for the DTD "injuriesxml.dtd". Each document
11 -- contains a root element \<message\> that in turn contains zero or
12 -- more \<listing\>s.
13 --
14 -- The listings will be mapped to a database table called
15 -- \"injuries_listings\" automatically. The root message is retained
16 -- so that we can easily delete its associated listings based on its
17 -- time_stamp.
18 --
19 module TSN.XML.Injuries (
20 dtd,
21 pickle_message,
22 -- * Tests
23 injuries_tests,
24 -- * WARNING: these are private but exported to silence warnings
25 InjuriesConstructor(..),
26 InjuriesListingConstructor(..) )
27 where
28
29 -- System imports.
30 import Data.Data ( Data )
31 import Data.Time ( UTCTime )
32 import Data.Typeable ( Typeable )
33 import qualified Data.Vector.HFixed as H ( HVector, cons, convert )
34 import Database.Groundhog (
35 countAll,
36 deleteAll,
37 migrate,
38 runMigration,
39 silentMigrationLogger )
40 import Database.Groundhog.Core ( DefaultKey )
41 import Database.Groundhog.Generic ( runDbConn )
42 import Database.Groundhog.TH (
43 groundhog,
44 mkPersist )
45 import qualified GHC.Generics as GHC ( Generic )
46 import Database.Groundhog.Sqlite ( withSqliteConn )
47 import Data.Tuple.Curry ( uncurryN )
48 import Test.Tasty ( TestTree, testGroup )
49 import Test.Tasty.HUnit ( (@?=), testCase )
50 import Text.XML.HXT.Core (
51 PU,
52 xp4Tuple,
53 xp6Tuple,
54 xpAttrImplied,
55 xpElem,
56 xpInt,
57 xpList,
58 xpOption,
59 xpPair,
60 xpPrim,
61 xpText,
62 xpWrap )
63
64 -- Local imports.
65 import TSN.Codegen ( tsn_codegen_config )
66 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
67 import TSN.Picklers ( xp_time_stamp )
68 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
69 import Xml (
70 Child(..),
71 FromXml(..),
72 FromXmlFk(..),
73 ToDb(..),
74 pickle_unpickle,
75 unpickleable,
76 unsafe_unpickle )
77
78
79
80 -- | The DTD to which this module corresponds. Used to invoke dbimport.
81 --
82 dtd :: String
83 dtd = "injuriesxml.dtd"
84
85 --
86 -- DB/XML Data types
87 --
88
89 -- * InjuriesTeam
90
91 -- | XML/Database representation of a team as they appear in the
92 -- injuries documents.
93 --
94 data InjuriesTeam =
95 InjuriesTeam {
96 db_team_name :: String,
97 db_team_league :: Maybe String }
98 deriving (Data, Eq, Show, Typeable)
99
100
101 -- * InjuriesListing/InjuriesListingXml
102
103 -- | XML representation of the injury listings. The leading
104 -- underscores prevent unused field warnings.
105 --
106 data InjuriesListingXml =
107 InjuriesListingXml {
108 _xml_team :: InjuriesTeam,
109 _xml_teamno :: Maybe String, -- ^ Can contain non-numerics, e.g. \"ZR2\"
110 _xml_injuries :: String,
111 _xml_updated :: Maybe Bool }
112 deriving (Eq, GHC.Generic, Show)
113
114
115 -- | For 'H.convert'.
116 --
117 instance H.HVector InjuriesListingXml
118
119
120 -- | Database representation of a 'InjuriesListing'. It possesses a
121 -- foreign key to an 'Injuries' object so that we can easily delete
122 -- 'InjuriesListing's based on the parent message's time_stamp.
123 -- The leading underscores prevent unused field warnings.
124 --
125 data InjuriesListing =
126 InjuriesListing {
127 _db_injuries_id :: DefaultKey Injuries,
128 _db_team :: InjuriesTeam,
129 _db_teamno :: Maybe String, -- ^ Can contain non-numerics, e.g. \"ZR2\"
130 _db_injuries :: String,
131 _db_updated :: Maybe Bool }
132 deriving ( GHC.Generic )
133
134 -- | For 'H.cons'.
135 --
136 instance H.HVector InjuriesListing
137
138 instance ToDb InjuriesListingXml where
139 -- | The DB analogue of a 'InjuriesListingXml' is a 'InjuriesListing'
140 type Db InjuriesListingXml = InjuriesListing
141
142 instance Child InjuriesListingXml where
143 -- | Our foreign key points to an 'Injuries'.
144 type Parent InjuriesListingXml = Injuries
145
146 instance FromXmlFk InjuriesListingXml where
147 -- | To convert between a 'InjuriesListingXml' and a
148 -- 'InjuriesListing', we simply append the foreign key.
149 from_xml_fk = H.cons
150
151 -- | This allows us to insert the XML representation
152 -- 'InjuriesListingXml' directly.
153 --
154 instance XmlImportFk InjuriesListingXml
155
156
157 -- * Injuries/Message
158
159 -- | XML representation of an injuriesxml \<message\>.
160 --
161 data Message =
162 Message {
163 xml_xml_file_id :: Int,
164 xml_heading :: String,
165 xml_category :: String,
166 xml_sport :: String,
167 xml_listings :: [InjuriesListingXml],
168 xml_time_stamp :: UTCTime }
169 deriving (Eq, GHC.Generic, Show)
170
171
172 -- | For 'H.HVector'.
173 --
174 instance H.HVector Message
175
176
177 -- | Database representation of a 'Message'.
178 --
179 data Injuries =
180 Injuries {
181 db_xml_file_id :: Int,
182 db_sport :: String,
183 db_time_stamp :: UTCTime }
184
185 instance ToDb Message where
186 -- | The database analogue of a 'Message' is an 'Injuries'.
187 type Db Message = Injuries
188
189 instance FromXml Message where
190 -- | To convert from XML to DB, we simply drop the fields we don't
191 -- care about.
192 --
193 from_xml Message{..} =
194 Injuries {
195 db_xml_file_id = xml_xml_file_id,
196 db_sport = xml_sport,
197 db_time_stamp = xml_time_stamp }
198
199 -- | This allows us to insert the XML representation 'Message'
200 -- directly.
201 --
202 instance XmlImport Message
203
204
205 --
206 -- Database code
207 --
208
209 instance DbImport Message where
210 dbmigrate _ =
211 run_dbmigrate $ do
212 migrate (undefined :: Injuries)
213 migrate (undefined :: InjuriesListing)
214
215 -- | We import a 'Message' by inserting all of its 'listings', but
216 -- the listings require a foreign key to the parent 'Message'.
217 --
218 dbimport msg = do
219 msg_id <- insert_xml msg
220
221 -- Convert each XML listing to a DB one using the message id and
222 -- insert it (disregarding the result).
223 mapM_ (insert_xml_fk_ msg_id) (xml_listings msg)
224
225 return ImportSucceeded
226
227
228 mkPersist tsn_codegen_config [groundhog|
229 - entity: Injuries
230 constructors:
231 - name: Injuries
232 uniques:
233 - name: unique_injuries
234 type: constraint
235 # Prevent multiple imports of the same message.
236 fields: [db_xml_file_id]
237
238 - entity: InjuriesListing
239 dbName: injuries_listings
240 constructors:
241 - name: InjuriesListing
242 fields:
243 - name: _db_team
244 embeddedType:
245 - {name: team_name, dbName: team_name}
246 - {name: team_league, dbName: team_league}
247 - name: _db_injuries_id
248 reference:
249 onDelete: cascade
250
251 - embedded: InjuriesTeam
252 fields:
253 - name: db_team_name
254 - name: db_team_league
255 |]
256
257
258 --
259 -- XML Picklers
260 --
261
262
263 -- | A pickler for 'InjuriesTeam's that can convert them to/from XML.
264 --
265 pickle_injuries_team :: PU InjuriesTeam
266 pickle_injuries_team =
267 xpElem "team" $
268 xpWrap (from_tuple, to_tuple') $
269 xpPair xpText (xpAttrImplied "league" xpText)
270 where
271 from_tuple = uncurryN InjuriesTeam
272
273 -- Pointless, but silences two unused field warnings.
274 to_tuple' InjuriesTeam{..} = (db_team_name, db_team_league)
275
276 -- | A pickler for 'InjuriesListingXml's that can convert them to/from
277 -- XML.
278 --
279 pickle_listing :: PU InjuriesListingXml
280 pickle_listing =
281 xpElem "listing" $
282 xpWrap (from_tuple, H.convert) $
283 xp4Tuple pickle_injuries_team
284 (xpOption $ xpElem "teamno" xpText)
285 (xpElem "injuries" xpText)
286 (xpOption $ xpElem "updated" xpPrim)
287 where
288 from_tuple = uncurryN InjuriesListingXml
289
290
291
292 -- | A pickler for 'Message's that can convert them to/from XML.
293 --
294 pickle_message :: PU Message
295 pickle_message =
296 xpElem "message" $
297 xpWrap (from_tuple, H.convert) $
298 xp6Tuple (xpElem "XML_File_ID" xpInt)
299 (xpElem "heading" xpText)
300 (xpElem "category" xpText)
301 (xpElem "sport" xpText)
302 (xpList pickle_listing)
303 (xpElem "time_stamp" xp_time_stamp)
304 where
305 from_tuple = uncurryN Message
306
307
308 --
309 -- Tasty Tests
310 --
311
312 -- | A list of all tests for this module.
313 --
314 injuries_tests :: TestTree
315 injuries_tests =
316 testGroup
317 "Injuries tests"
318 [ test_on_delete_cascade,
319 test_pickle_of_unpickle_is_identity,
320 test_unpickle_succeeds ]
321
322
323 -- | If we unpickle something and then pickle it, we should wind up
324 -- with the same thing we started with. WARNING: success of this
325 -- test does not mean that unpickling succeeded.
326 --
327 test_pickle_of_unpickle_is_identity :: TestTree
328 test_pickle_of_unpickle_is_identity =
329 testCase "pickle composed with unpickle is the identity" $ do
330 let path = "test/xml/injuriesxml.xml"
331 (expected, actual) <- pickle_unpickle pickle_message path
332 actual @?= expected
333
334
335 -- | Make sure we can actually unpickle these things.
336 --
337 test_unpickle_succeeds :: TestTree
338 test_unpickle_succeeds =
339 testCase "unpickling succeeds" $ do
340 let path = "test/xml/injuriesxml.xml"
341 actual <- unpickleable path pickle_message
342 let expected = True
343 actual @?= expected
344
345
346 -- | Make sure everything gets deleted when we delete the top-level
347 -- record.
348 --
349 test_on_delete_cascade :: TestTree
350 test_on_delete_cascade =
351 testCase "deleting an injuries deletes its children" $ do
352 let path = "test/xml/injuriesxml.xml"
353 inj <- unsafe_unpickle path pickle_message
354 let a = undefined :: Injuries
355 let b = undefined :: InjuriesListing
356 actual <- withSqliteConn ":memory:" $ runDbConn $ do
357 runMigration silentMigrationLogger $ do
358 migrate a
359 migrate b
360 _ <- dbimport inj
361 deleteAll a
362 count_a <- countAll a
363 count_b <- countAll b
364 return $ count_a + count_b
365 let expected = 0
366 actual @?= expected