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 \"newsxml.dtd\". Each document contains
10 -- a root element \<message\> that contains an entire news item.
17 -- * WARNING: these are private but exported to silence warnings
18 News_NewsLocationConstructor(..),
19 News_NewsTeamConstructor(..),
21 NewsLocationConstructor(..),
22 NewsTeamConstructor(..) )
26 import Data.Data ( Data, constrFields, dataTypeConstrs, dataTypeOf )
27 import Data.Time.Clock ( UTCTime )
28 import Data.List.Utils ( join, split )
29 import Data.Tuple.Curry ( uncurryN )
30 import Data.Typeable ( Typeable )
31 import Database.Groundhog (
37 silentMigrationLogger )
38 import Database.Groundhog.Core ( DefaultKey )
39 import Database.Groundhog.Generic ( runDbConn )
40 import Database.Groundhog.Sqlite ( withSqliteConn )
41 import Database.Groundhog.TH (
45 import Test.Tasty ( TestTree, testGroup )
46 import Test.Tasty.HUnit ( (@?=), testCase )
47 import Text.XML.HXT.Core (
63 tsn_db_field_namer ) -- Used in a test
64 import TSN.Database ( insert_or_select )
65 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
66 import TSN.Picklers ( xp_time_stamp )
67 import TSN.XmlImport ( XmlImport(..) )
76 -- | The DTD to which this module corresponds. Used to invoke dbimport.
88 -- | The msg_id child of \<message\> contains an event_id attribute; we
89 -- embed it into the 'News' type. We (pointlessly) use the \"db_\"
90 -- prefix here so that the two names don't collide on \"id\" when
91 -- Groundhog is creating its fields using our field namer.
96 db_event_id :: Maybe Int }
97 deriving (Data, Eq, Show, Typeable)
100 -- | The XML representation of a news item (\<message\>).
104 xml_xml_file_id :: Int,
105 xml_heading :: String,
107 xml_category :: String,
109 xml_url :: Maybe String,
110 xml_teams :: [NewsTeam],
111 xml_locations :: [NewsLocation],
113 xml_editor :: Maybe String,
114 xml_text :: Maybe String, -- Text and continue seem to show up in pairs,
115 xml_continue :: Maybe String, -- either both present or both missing.
116 xml_time_stamp :: UTCTime }
120 -- | The database representation of a news item. We drop several
121 -- uninteresting fields from 'Message', and omit the list fields which
122 -- will be represented as join tables.
126 db_xml_file_id :: Int,
129 db_url :: Maybe String,
131 db_editor :: Maybe String,
132 db_text :: Maybe String,
133 db_continue :: Maybe String,
134 db_time_stamp :: UTCTime }
135 deriving (Data, Eq, Show, Typeable)
139 instance ToDb Message where
140 -- | The database representation of 'Message' is 'News'.
141 type Db Message = News
143 -- | Convert the XML representation 'Message' to the database
144 -- representation 'News'.
146 instance FromXml Message where
147 -- | We use a record wildcard so GHC doesn't complain that we never
148 -- used the field names.
150 from_xml Message{..} = News { db_xml_file_id = xml_xml_file_id,
152 db_sport = xml_sport,
155 db_editor = xml_editor,
157 db_continue = xml_continue,
158 db_time_stamp = xml_time_stamp }
160 -- | This lets us insert the XML representation 'Message' directly.
162 instance XmlImport Message
167 -- | The database type for teams as they show up in the news.
170 NewsTeam { team_name :: String }
177 -- | Mapping between News records and NewsTeam records in the
178 -- database. We don't name the fields because we don't use the names
179 -- explicitly; that means we have to give them nice database names
182 data News_NewsTeam = News_NewsTeam
184 (DefaultKey NewsTeam)
189 -- | The database type for locations as they show up in the news.
193 city :: Maybe String,
194 state :: Maybe String,
199 -- * News_NewsLocation
201 -- | Mapping between News records and NewsLocation records in the
202 -- database. We don't name the fields because we don't use the names
203 -- explicitly; that means we have to give them nice database names
206 data News_NewsLocation = News_NewsLocation
208 (DefaultKey NewsLocation)
216 -- | Define 'dbmigrate' and 'dbimport' for 'Message's. The import is
217 -- slightly non-generic because of our 'News_NewsTeam' and
218 -- 'News_NewsLocation' join tables.
220 instance DbImport Message where
223 migrate (undefined :: News)
224 migrate (undefined :: NewsTeam)
225 migrate (undefined :: News_NewsTeam)
226 migrate (undefined :: NewsLocation)
227 migrate (undefined :: News_NewsLocation)
229 dbimport message = do
230 -- Insert the message and acquire its primary key (unique ID)
231 news_id <- insert_xml message
233 -- And insert each one into its own table. We use insert_xml_or_select
234 -- because we know that most teams will already exist, and we
235 -- want to get back the id for the existing team when
236 -- there's a collision.
237 nt_ids <- mapM insert_or_select (xml_teams message)
239 -- Now that the teams have been inserted, create
240 -- news__news_team records mapping beween the two.
241 let news_news_teams = map (News_NewsTeam news_id) nt_ids
242 mapM_ insert_ news_news_teams
244 -- Do all of that over again for the NewsLocations.
245 loc_ids <- mapM insert_or_select (xml_locations message)
246 let news_news_locations = map (News_NewsLocation news_id) loc_ids
247 mapM_ insert_ news_news_locations
249 return ImportSucceeded
252 -- These types don't have special XML representations or field name
253 -- collisions so we use the defaultCodegenConfig and give their
254 -- fields nice simple names.
255 mkPersist defaultCodegenConfig [groundhog|
261 - name: unique_news_team
265 - entity: NewsLocation
266 dbName: news_locations
270 - name: unique_news_location
272 fields: [city, state, country]
277 -- These types have fields with e.g. db_ and xml_ prefixes, so we
278 -- use our own codegen to peel those off before naming the columns.
279 mkPersist tsn_codegen_config [groundhog|
286 # Prevent multiple imports of the same message.
287 fields: [db_xml_file_id]
291 - {name: msg_id, dbName: msg_id}
292 - {name: event_id, dbName: event_id}
301 - entity: News_NewsTeam
302 dbName: news__news_teams
304 - name: News_NewsTeam
306 - name: news_NewsTeam0 # Default created by mkNormalFieldName
310 - name: news_NewsTeam1 # Default created by mkNormalFieldName
311 dbName: news_teams_id
315 - entity: News_NewsLocation
316 dbName: news__news_locations
318 - name: News_NewsLocation
320 - name: news_NewsLocation0 # Default created by mkNormalFieldName
324 - name: news_NewsLocation1 # Default created by mkNormalFieldName
325 dbName: news_locations_id
335 -- | Convert a 'NewsTeam' to/from XML.
337 pickle_news_team :: PU NewsTeam
340 xpWrap (from_string, to_string) xpText
342 to_string :: NewsTeam -> String
343 to_string = team_name
345 from_string :: String -> NewsTeam
346 from_string = NewsTeam
349 -- | Convert a 'MsgId' to/from XML.
351 pickle_msg_id :: PU MsgId
354 xpWrap (from_tuple, to_tuple) $
355 xpPair xpInt (xpAttr "EventId" (xpOption xpInt))
357 from_tuple = uncurryN MsgId
358 to_tuple m = (db_msg_id m, db_event_id m)
361 -- | Convert a 'NewsLocation' to/from XML.
363 pickle_location :: PU NewsLocation
366 xpWrap (from_tuple, to_tuple) $
367 xpTriple (xpOption (xpElem "city" xpText))
368 (xpOption (xpElem "state" xpText))
369 (xpElem "country" xpText)
372 uncurryN NewsLocation
373 to_tuple l = (city l, state l, country l)
376 -- | Convert a 'Message' to/from XML.
378 pickle_message :: PU Message
381 xpWrap (from_tuple, to_tuple) $
382 xp13Tuple (xpElem "XML_File_ID" xpInt)
383 (xpElem "heading" xpText)
385 (xpElem "category" xpText)
386 (xpElem "sport" xpText)
387 (xpElem "url" $ xpOption xpText)
388 (xpList pickle_news_team)
389 (xpList pickle_location)
390 (xpElem "SMS" xpText)
391 (xpOption (xpElem "Editor" xpText))
392 (xpOption (xpElem "text" xpText))
394 (xpElem "time_stamp" xp_time_stamp)
396 from_tuple = uncurryN Message
397 to_tuple m = (xml_xml_file_id m, -- Verbose,
398 xml_heading m, -- but
399 xml_mid m, -- eliminates
400 xml_category m, -- GHC
401 xml_sport m, -- warnings
404 xml_locations m, -- .
411 -- | We combine all of the \<continue\> elements into one 'String'
412 -- while unpickling and do the reverse while pickling.
414 pickle_continue :: PU (Maybe String)
417 xpWrap (to_string, from_string) $
419 xpList (xpElem "P" xpText)
421 from_string :: String -> [String]
422 from_string = split "\n"
424 to_string :: [String] -> String
425 to_string = join "\n"
432 -- | A list of all tests for this module.
434 news_tests :: TestTree
438 [ test_news_fields_have_correct_names,
439 test_on_delete_cascade,
440 test_pickle_of_unpickle_is_identity,
441 test_unpickle_succeeds ]
444 -- | Make sure our codegen is producing the correct database names.
446 test_news_fields_have_correct_names :: TestTree
447 test_news_fields_have_correct_names =
448 testCase "news fields get correct database names" $
449 mapM_ check (zip actual expected)
451 -- This is cool, it uses the (derived) Data instance of
452 -- News.News to get its constructor names.
453 field_names :: [String]
455 constrFields . head $ dataTypeConstrs $ dataTypeOf (undefined :: News)
459 map (\x -> tsn_db_field_namer "herp" "derp" 8675309 x 90210) field_names
462 actual = ["xml_file_id",
471 check (x,y) = (x @?= y)
474 -- | If we unpickle something and then pickle it, we should wind up
475 -- with the same thing we started with. WARNING: success of this
476 -- test does not mean that unpickling succeeded.
478 test_pickle_of_unpickle_is_identity :: TestTree
479 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
480 [ check "pickle composed with unpickle is the identity"
481 "test/xml/newsxml.xml",
483 check "pickle composed with unpickle is the identity (with Editor)"
484 "test/xml/newsxml-with-editor.xml" ]
486 check desc path = testCase desc $ do
487 (expected, actual) <- pickle_unpickle pickle_message path
491 -- | Make sure we can actually unpickle these things.
493 test_unpickle_succeeds :: TestTree
494 test_unpickle_succeeds = testGroup "unpickle tests"
495 [ check "unpickling succeeds"
496 "test/xml/newsxml.xml",
498 check "unpickling succeeds (with Editor)"
499 "test/xml/newsxml-with-editor.xml" ]
501 check desc path = testCase desc $ do
502 actual <- unpickleable path pickle_message
507 -- | Make sure everything gets deleted when we delete the top-level
510 test_on_delete_cascade :: TestTree
511 test_on_delete_cascade = testGroup "cascading delete tests"
512 [ check "deleting news deletes its children"
513 "test/xml/newsxml.xml"
514 4 -- 2 news_teams and 2 news_locations that should remain.
517 check desc path expected = testCase desc $ do
518 news <- unsafe_unpickle path pickle_message
519 let a = undefined :: News
520 let b = undefined :: NewsTeam
521 let c = undefined :: News_NewsTeam
522 let d = undefined :: NewsLocation
523 let e = undefined :: News_NewsLocation
524 actual <- withSqliteConn ":memory:" $ runDbConn $ do
525 runMigration silentMigrationLogger $ do
533 count_a <- countAll a
534 count_b <- countAll b
535 count_c <- countAll c
536 count_d <- countAll d
537 count_e <- countAll e
538 return $ count_a + count_b + count_c + count_d + count_e