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