1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE QuasiQuotes #-}
5 {-# LANGUAGE RecordWildCards #-}
6 {-# LANGUAGE StandaloneDeriving #-}
7 {-# LANGUAGE TemplateHaskell #-}
8 {-# LANGUAGE TypeFamilies #-}
10 -- | Parse TSN XML for the DTD "newsxml.dtd". Each document contains a
11 -- 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 (
34 import Database.Groundhog.Core ( DefaultKey )
35 import Database.Groundhog.TH (
39 import Test.Tasty ( TestTree, testGroup )
40 import Test.Tasty.HUnit ( (@?=), testCase )
41 import Text.XML.HXT.Core (
57 tsn_db_field_namer ) -- Used in a test
58 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
59 import TSN.Picklers ( xp_time_stamp )
60 import TSN.XmlImport ( XmlImport(..) )
61 import Xml ( FromXml(..), ToDb(..), pickle_unpickle, unpickleable )
70 -- | The msg_id child of <message> contains an event_id attribute; we
71 -- embed it into the 'News' type. We (pointlessly) use the "db_"
72 -- prefix here so that the two names don't collide on "id" when
73 -- Groundhog is creating its fields using our field namer.
77 db_event_id :: Maybe Int }
78 deriving (Data, Eq, Show, Typeable)
81 -- | The XML representation of a news item (message).
85 xml_xml_file_id :: Int,
86 xml_heading :: String,
88 xml_category :: String,
90 xml_url :: Maybe String,
91 xml_teams :: [NewsTeam],
92 xml_locations :: [NewsLocation],
94 xml_editor :: Maybe String,
95 xml_text :: Maybe String, -- Text and continue seem to show up in pairs,
96 xml_continue :: Maybe String, -- either both present or both missing.
97 xml_time_stamp :: UTCTime }
101 -- | The database representation of a news item. We drop several
102 -- uninteresting fields from 'Message', and omit the list fields which
103 -- will be represented as join tables.
107 db_xml_file_id :: Int,
110 db_url :: Maybe String,
112 db_editor :: Maybe String,
113 db_text :: Maybe String,
114 db_continue :: Maybe String,
115 db_time_stamp :: UTCTime }
116 deriving (Data, Eq, Show, Typeable)
120 instance ToDb Message where
121 type Db Message = News
123 -- | Convert the XML representation 'Message' to the database
124 -- representation 'News'.
126 instance FromXml Message where
127 -- | We use a record wildcard so GHC doesn't complain that we never
128 -- used the field names.
130 from_xml Message{..} = News { db_xml_file_id = xml_xml_file_id,
132 db_sport = xml_sport,
135 db_editor = xml_editor,
137 db_continue = xml_continue,
138 db_time_stamp = xml_time_stamp }
140 -- | This lets us call 'insert_xml' on a 'Message'.
142 instance XmlImport Message
147 -- | The database type for teams as they show up in the news.
150 NewsTeam { team_name :: String }
154 instance ToDb NewsTeam where
155 -- | The database representaion of a 'NewsTeam' is itself.
156 type Db NewsTeam = NewsTeam
158 -- | This is needed to define the XmlImport instance for NewsTeam.
160 instance FromXml NewsTeam where
161 -- | How to we get a 'NewsTeam' from itself?
164 -- | Allow us to call 'insert_xml' on the XML representation of
167 instance XmlImport NewsTeam
173 -- | Mapping between News records and NewsTeam records in the
174 -- database. We don't name the fields because we don't use the names
175 -- explicitly; that means we have to give them nice database names
178 data News_NewsTeam = News_NewsTeam
180 (DefaultKey NewsTeam)
185 -- | The database type for locations as they show up in the news.
189 city :: Maybe String,
190 state :: Maybe String,
194 instance ToDb NewsLocation where
195 -- | The database representation of a 'NewsLocation' is itself.
196 type Db NewsLocation = NewsLocation
198 -- | This is needed to define the XmlImport instance for NewsLocation.
200 instance FromXml NewsLocation where
201 -- | How to we get a 'NewsLocation' from itself?
204 -- | Allow us to call 'insert_xml' on the XML representation of
207 instance XmlImport NewsLocation
210 -- * News_NewsLocation
212 -- | Mapping between News records and NewsLocation records in the
213 -- database. We don't name the fields because we don't use the names
214 -- explicitly; that means we have to give them nice database names
217 data News_NewsLocation = News_NewsLocation
219 (DefaultKey NewsLocation)
227 -- | Define 'dbmigrate' and 'dbimport' for 'Message's. The import is
228 -- slightly non-generic because of our 'News_NewsTeam' and
229 -- 'News_NewsLocation' join tables.
231 instance DbImport Message where
234 migrate (undefined :: NewsTeam)
235 migrate (undefined :: NewsLocation)
236 migrate (undefined :: News)
237 migrate (undefined :: News_NewsTeam)
238 migrate (undefined :: News_NewsLocation)
240 dbimport message = do
241 -- Insert the message and acquire its primary key (unique ID)
242 news_id <- insert_xml message
244 -- And insert each one into its own table. We use insert_xml_or_select
245 -- because we know that most teams will already exist, and we
246 -- want to get back the id for the existing team when
247 -- there's a collision.
248 nt_ids <- mapM insert_xml_or_select (xml_teams message)
250 -- Now that the teams have been inserted, create
251 -- news__news_team records mapping beween the two.
252 let news_news_teams = map (News_NewsTeam news_id) nt_ids
253 mapM_ insert_ news_news_teams
255 -- Do all of that over again for the NewsLocations.
256 loc_ids <- mapM insert_xml_or_select (xml_locations message)
257 let news_news_locations = map (News_NewsLocation news_id) loc_ids
258 mapM_ insert_ news_news_locations
260 return ImportSucceeded
263 -- These types don't have special XML representations or field name
264 -- collisions so we use the defaultCodegenConfig and give their
265 -- fields nice simple names.
266 mkPersist defaultCodegenConfig [groundhog|
272 - name: unique_news_team
276 - entity: NewsLocation
277 dbName: news_locations
281 - name: unique_news_location
283 fields: [city, state, country]
288 -- These types have fields with e.g. db_ and xml_ prefixes, so we
289 -- use our own codegen to peel those off before naming the columns.
290 mkPersist tsn_codegen_config [groundhog|
298 # Prevent multiple imports of the same message.
299 fields: [db_xml_file_id]
303 - {name: msg_id, dbName: msg_id}
304 - {name: event_id, dbName: event_id}
313 - entity: News_NewsTeam
314 dbName: news__news_teams
316 - name: News_NewsTeam
318 - name: news_NewsTeam0 # Default created by mkNormalFieldName
322 - name: news_NewsTeam1 # Default created by mkNormalFieldName
323 dbName: news_teams_id
327 - entity: News_NewsLocation
328 dbName: news__news_locations
330 - name: News_NewsLocation
332 - name: news_NewsLocation0 # Default created by mkNormalFieldName
336 - name: news_NewsLocation1 # Default created by mkNormalFieldName
337 dbName: news_locations_id
346 -- | Convert a 'NewsTeam' to/from XML.
348 pickle_news_team :: PU NewsTeam
351 xpWrap (from_string, to_string) xpText
353 to_string :: NewsTeam -> String
354 to_string = team_name
356 from_string :: String -> NewsTeam
357 from_string = NewsTeam
360 -- | Convert a 'MsgId' to/from XML.
362 pickle_msg_id :: PU MsgId
365 xpWrap (from_tuple, to_tuple) $
366 xpPair xpInt (xpAttr "EventId" (xpOption xpInt))
368 from_tuple = uncurryN MsgId
369 to_tuple m = (db_msg_id m, db_event_id m)
372 -- | Convert a 'NewsLocation' to/from XML.
374 pickle_location :: PU NewsLocation
377 xpWrap (from_tuple, to_tuple) $
378 xpTriple (xpOption (xpElem "city" xpText))
379 (xpOption (xpElem "state" xpText))
380 (xpElem "country" xpText)
383 uncurryN NewsLocation
384 to_tuple l = (city l, state l, country l)
387 -- | Convert a 'Message' to/from XML.
389 pickle_message :: PU Message
392 xpWrap (from_tuple, to_tuple) $
393 xp13Tuple (xpElem "XML_File_ID" xpInt)
394 (xpElem "heading" xpText)
396 (xpElem "category" xpText)
397 (xpElem "sport" xpText)
398 (xpElem "url" $ xpOption xpText)
399 (xpList pickle_news_team)
400 (xpList pickle_location)
401 (xpElem "SMS" xpText)
402 (xpOption (xpElem "Editor" xpText))
403 (xpOption (xpElem "text" xpText))
405 (xpElem "time_stamp" xp_time_stamp)
407 from_tuple = uncurryN Message
408 to_tuple m = (xml_xml_file_id m, -- Verbose,
409 xml_heading m, -- but
410 xml_mid m, -- eliminates
411 xml_category m, -- GHC
412 xml_sport m, -- warnings
415 xml_locations m, -- .
422 -- | We combine all of the \<continue\> elements into one 'String'
423 -- while unpickling and do the reverse while pickling.
425 pickle_continue :: PU (Maybe String)
428 xpWrap (to_string, from_string) $
430 xpList (xpElem "P" xpText)
432 from_string :: String -> [String]
433 from_string = split "\n"
435 to_string :: [String] -> String
436 to_string = join "\n"
443 -- | A list of all tests for this module.
445 news_tests :: TestTree
449 [ test_news_fields_have_correct_names,
450 test_pickle_of_unpickle_is_identity,
451 test_unpickle_succeeds ]
454 -- | Make sure our codegen is producing the correct database names.
456 test_news_fields_have_correct_names :: TestTree
457 test_news_fields_have_correct_names =
458 testCase "news fields get correct database names" $
459 mapM_ check (zip actual expected)
461 -- This is cool, it uses the (derived) Data instance of
462 -- News.News to get its constructor names.
463 field_names :: [String]
465 constrFields . head $ dataTypeConstrs $ dataTypeOf (undefined :: News)
469 map (\x -> tsn_db_field_namer "herp" "derp" 8675309 x 90210) field_names
472 actual = ["mid", "sport", "url", "sms", "editor", "text", "continue"]
474 check (x,y) = (x @?= y)
477 -- | If we unpickle something and then pickle it, we should wind up
478 -- with the same thing we started with. WARNING: success of this
479 -- test does not mean that unpickling succeeded.
481 test_pickle_of_unpickle_is_identity :: TestTree
482 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
483 [ check "pickle composed with unpickle is the identity"
484 "test/xml/newsxml.xml",
486 check "pickle composed with unpickle is the identity (with Editor)"
487 "test/xml/newsxml-with-editor.xml" ]
489 check desc path = testCase desc $ do
490 (expected, actual) <- pickle_unpickle pickle_message path
494 -- | Make sure we can actually unpickle these things.
496 test_unpickle_succeeds :: TestTree
497 test_unpickle_succeeds = testGroup "unpickle tests"
498 [ check "unpickling succeeds"
499 "test/xml/newsxml.xml",
501 check "unpickling succeeds (with Editor)"
502 "test/xml/newsxml-with-editor.xml" ]
504 check desc path = testCase desc $ do
505 actual <- unpickleable path pickle_message