1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE QuasiQuotes #-}
5 {-# LANGUAGE RecordWildCards #-}
6 {-# LANGUAGE TemplateHaskell #-}
7 {-# LANGUAGE TypeFamilies #-}
9 -- | Parse TSN XML for the DTD "injuriesxml.dtd". Each document
10 -- contains a root element \<message\> that in turn contains zero or
13 -- The listings will be mapped to a database table called
14 -- \"injuries_listings\" automatically. The root message is retained
15 -- so that we can easily delete its associated listings based on its
18 module TSN.XML.Injuries (
23 -- * WARNING: these are private but exported to silence warnings
24 InjuriesConstructor(..),
25 InjuriesListingConstructor(..) )
29 import Data.Data ( Data )
30 import Data.Time ( UTCTime )
31 import Data.Typeable ( Typeable )
32 import Database.Groundhog (
37 silentMigrationLogger )
38 import Database.Groundhog.Core ( DefaultKey )
39 import Database.Groundhog.Generic ( runDbConn )
40 import Database.Groundhog.TH (
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 (
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(..) )
76 -- | The DTD to which this module corresponds. Used to invoke dbimport.
79 dtd = "injuriesxml.dtd"
87 -- | XML/Database representation of a team as they appear in the
88 -- injuries documents.
92 db_team_name :: String,
93 db_team_league :: Maybe String }
94 deriving (Data, Eq, Show, Typeable)
97 -- * InjuriesListing/InjuriesListingXml
99 -- | XML representation of the injury listings.
101 data InjuriesListingXml =
103 xml_team :: InjuriesTeam,
104 xml_teamno :: Maybe Int,
105 xml_injuries :: String,
106 xml_updated :: Maybe Bool }
109 -- | Database representation of a 'InjuriesListing'. It possesses a
110 -- foreign key to an 'Injuries' object so that we can easily delete
111 -- 'InjuriesListing's based on the parent message's time_stamp.
113 data InjuriesListing =
115 db_injuries_id :: DefaultKey Injuries,
116 db_team :: InjuriesTeam,
117 db_teamno :: Maybe Int,
118 db_injuries :: String,
119 db_updated :: Maybe Bool }
121 instance ToDb InjuriesListingXml where
122 -- | The DB analogue of a 'InjuriesListingXml' is a 'InjuriesListing'
123 type Db InjuriesListingXml = InjuriesListing
125 instance FromXmlFk InjuriesListingXml where
126 -- | Our foreign key points to an 'Injuries'.
127 type Parent InjuriesListingXml = Injuries
129 -- | To convert between a 'InjuriesListingXml' and a
130 -- 'InjuriesListing', we simply append the foreign key.
131 from_xml_fk fk InjuriesListingXml{..} =
135 db_teamno = xml_teamno,
136 db_injuries = xml_injuries,
137 db_updated = xml_updated }
139 -- | This allows us to insert the XML representation
140 -- 'InjuriesListingXml' directly.
142 instance XmlImportFk InjuriesListingXml
145 -- * Injuries/Message
147 -- | XML representation of an injuriesxml \<message\>.
151 xml_xml_file_id :: Int,
152 xml_heading :: String,
153 xml_category :: String,
155 xml_listings :: [InjuriesListingXml],
156 xml_time_stamp :: UTCTime }
159 -- | Database representation of a 'Message'.
163 db_xml_file_id :: Int,
165 db_time_stamp :: UTCTime }
167 instance ToDb Message where
168 -- | The database analogue of a 'Message' is an 'Injuries'.
169 type Db Message = Injuries
171 instance FromXml Message where
172 -- | To convert from XML to DB, we simply drop the fields we don't
175 from_xml Message{..} =
177 db_xml_file_id = xml_xml_file_id,
178 db_sport = xml_sport,
179 db_time_stamp = xml_time_stamp }
181 -- | This allows us to insert the XML representation 'Message'
184 instance XmlImport Message
191 instance DbImport Message where
194 migrate (undefined :: Injuries)
195 migrate (undefined :: InjuriesListing)
197 -- | We import a 'Message' by inserting all of its 'listings', but
198 -- the listings require a foreign key to the parent 'Message'.
201 msg_id <- insert_xml msg
203 -- Convert each XML listing to a DB one using the message id and
204 -- insert it (disregarding the result).
205 mapM_ (insert_xml_fk_ msg_id) (xml_listings msg)
207 return ImportSucceeded
210 mkPersist tsn_codegen_config [groundhog|
215 - name: unique_injuries
217 # Prevent multiple imports of the same message.
218 fields: [db_xml_file_id]
220 - entity: InjuriesListing
221 dbName: injuries_listings
223 - name: InjuriesListing
227 - {name: team_name, dbName: team_name}
228 - {name: team_league, dbName: team_league}
229 - name: db_injuries_id
233 - embedded: InjuriesTeam
236 - name: db_team_league
245 -- | A pickler for 'InjuriesTeam's that can convert them to/from XML.
247 pickle_injuries_team :: PU InjuriesTeam
248 pickle_injuries_team =
250 xpWrap (from_tuple, to_tuple) $
251 xpPair xpText (xpAttrImplied "league" xpText)
253 from_tuple = uncurryN InjuriesTeam
254 to_tuple m = (db_team_name m, db_team_league m)
257 -- | A pickler for 'InjuriesListingXml's that can convert them to/from
260 pickle_listing :: PU InjuriesListingXml
263 xpWrap (from_tuple, to_tuple) $
264 xp4Tuple pickle_injuries_team
265 (xpOption $ xpElem "teamno" xpInt)
266 (xpElem "injuries" xpText)
267 (xpOption $ xpElem "updated" xpPrim)
269 from_tuple = uncurryN InjuriesListingXml
270 to_tuple l = (xml_team l, xml_teamno l, xml_injuries l, xml_updated l)
273 -- | A pickler for 'Message's that can convert them to/from XML.
275 pickle_message :: PU Message
278 xpWrap (from_tuple, to_tuple) $
279 xp6Tuple (xpElem "XML_File_ID" xpInt)
280 (xpElem "heading" xpText)
281 (xpElem "category" xpText)
282 (xpElem "sport" xpText)
283 (xpList pickle_listing)
284 (xpElem "time_stamp" xp_time_stamp)
286 from_tuple = uncurryN Message
287 to_tuple m = (xml_xml_file_id m,
299 -- | A list of all tests for this module.
301 injuries_tests :: TestTree
305 [ test_on_delete_cascade,
306 test_pickle_of_unpickle_is_identity,
307 test_unpickle_succeeds ]
310 -- | If we unpickle something and then pickle it, we should wind up
311 -- with the same thing we started with. WARNING: success of this
312 -- test does not mean that unpickling succeeded.
314 test_pickle_of_unpickle_is_identity :: TestTree
315 test_pickle_of_unpickle_is_identity =
316 testCase "pickle composed with unpickle is the identity" $ do
317 let path = "test/xml/injuriesxml.xml"
318 (expected, actual) <- pickle_unpickle pickle_message path
322 -- | Make sure we can actually unpickle these things.
324 test_unpickle_succeeds :: TestTree
325 test_unpickle_succeeds =
326 testCase "unpickling succeeds" $ do
327 let path = "test/xml/injuriesxml.xml"
328 actual <- unpickleable path pickle_message
333 -- | Make sure everything gets deleted when we delete the top-level
336 test_on_delete_cascade :: TestTree
337 test_on_delete_cascade =
338 testCase "deleting an injuries deletes its children" $ do
339 let path = "test/xml/injuriesxml.xml"
340 inj <- unsafe_unpickle path pickle_message
341 let a = undefined :: Injuries
342 let b = undefined :: InjuriesListing
343 actual <- withSqliteConn ":memory:" $ runDbConn $ do
344 runMigration silentMigrationLogger $ do
349 count_a <- countAll a
350 count_b <- countAll b
351 return $ count_a + count_b