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
11 -- 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 (
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.Database ( insert_or_select )
59 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
60 import TSN.Picklers ( xp_time_stamp )
61 import TSN.XmlImport ( XmlImport(..) )
62 import Xml ( FromXml(..), ToDb(..), pickle_unpickle, unpickleable )
71 -- | The msg_id child of <message> contains an event_id attribute; we
72 -- embed it into the 'News' type. We (pointlessly) use the "db_"
73 -- prefix here so that the two names don't collide on "id" when
74 -- Groundhog is creating its fields using our field namer.
79 db_event_id :: Maybe Int }
80 deriving (Data, Eq, Show, Typeable)
83 -- | The XML representation of a news item (\<message\>).
87 xml_xml_file_id :: Int,
88 xml_heading :: String,
90 xml_category :: String,
92 xml_url :: Maybe String,
93 xml_teams :: [NewsTeam],
94 xml_locations :: [NewsLocation],
96 xml_editor :: Maybe String,
97 xml_text :: Maybe String, -- Text and continue seem to show up in pairs,
98 xml_continue :: Maybe String, -- either both present or both missing.
99 xml_time_stamp :: UTCTime }
103 -- | The database representation of a news item. We drop several
104 -- uninteresting fields from 'Message', and omit the list fields which
105 -- will be represented as join tables.
109 db_xml_file_id :: Int,
112 db_url :: Maybe String,
114 db_editor :: Maybe String,
115 db_text :: Maybe String,
116 db_continue :: Maybe String,
117 db_time_stamp :: UTCTime }
118 deriving (Data, Eq, Show, Typeable)
122 instance ToDb Message where
123 -- | The database representation of 'Message' is 'News'.
124 type Db Message = News
126 -- | Convert the XML representation 'Message' to the database
127 -- representation 'News'.
129 instance FromXml Message where
130 -- | We use a record wildcard so GHC doesn't complain that we never
131 -- used the field names.
133 from_xml Message{..} = News { db_xml_file_id = xml_xml_file_id,
135 db_sport = xml_sport,
138 db_editor = xml_editor,
140 db_continue = xml_continue,
141 db_time_stamp = xml_time_stamp }
143 -- | This lets us insert the XML representation 'Message' directly.
145 instance XmlImport Message
150 -- | The database type for teams as they show up in the news.
153 NewsTeam { team_name :: String }
160 -- | Mapping between News records and NewsTeam records in the
161 -- database. We don't name the fields because we don't use the names
162 -- explicitly; that means we have to give them nice database names
165 data News_NewsTeam = News_NewsTeam
167 (DefaultKey NewsTeam)
172 -- | The database type for locations as they show up in the news.
176 city :: Maybe String,
177 state :: Maybe String,
182 -- * News_NewsLocation
184 -- | Mapping between News records and NewsLocation records in the
185 -- database. We don't name the fields because we don't use the names
186 -- explicitly; that means we have to give them nice database names
189 data News_NewsLocation = News_NewsLocation
191 (DefaultKey NewsLocation)
199 -- | Define 'dbmigrate' and 'dbimport' for 'Message's. The import is
200 -- slightly non-generic because of our 'News_NewsTeam' and
201 -- 'News_NewsLocation' join tables.
203 instance DbImport Message where
206 migrate (undefined :: News)
207 migrate (undefined :: NewsTeam)
208 migrate (undefined :: News_NewsTeam)
209 migrate (undefined :: NewsLocation)
210 migrate (undefined :: News_NewsLocation)
212 dbimport message = do
213 -- Insert the message and acquire its primary key (unique ID)
214 news_id <- insert_xml message
216 -- And insert each one into its own table. We use insert_xml_or_select
217 -- because we know that most teams will already exist, and we
218 -- want to get back the id for the existing team when
219 -- there's a collision.
220 nt_ids <- mapM insert_or_select (xml_teams message)
222 -- Now that the teams have been inserted, create
223 -- news__news_team records mapping beween the two.
224 let news_news_teams = map (News_NewsTeam news_id) nt_ids
225 mapM_ insert_ news_news_teams
227 -- Do all of that over again for the NewsLocations.
228 loc_ids <- mapM insert_or_select (xml_locations message)
229 let news_news_locations = map (News_NewsLocation news_id) loc_ids
230 mapM_ insert_ news_news_locations
232 return ImportSucceeded
235 -- These types don't have special XML representations or field name
236 -- collisions so we use the defaultCodegenConfig and give their
237 -- fields nice simple names.
238 mkPersist defaultCodegenConfig [groundhog|
244 - name: unique_news_team
248 - entity: NewsLocation
249 dbName: news_locations
253 - name: unique_news_location
255 fields: [city, state, country]
260 -- These types have fields with e.g. db_ and xml_ prefixes, so we
261 -- use our own codegen to peel those off before naming the columns.
262 mkPersist tsn_codegen_config [groundhog|
270 # Prevent multiple imports of the same message.
271 fields: [db_xml_file_id]
275 - {name: msg_id, dbName: msg_id}
276 - {name: event_id, dbName: event_id}
285 - entity: News_NewsTeam
286 dbName: news__news_teams
288 - name: News_NewsTeam
290 - name: news_NewsTeam0 # Default created by mkNormalFieldName
294 - name: news_NewsTeam1 # Default created by mkNormalFieldName
295 dbName: news_teams_id
299 - entity: News_NewsLocation
300 dbName: news__news_locations
302 - name: News_NewsLocation
304 - name: news_NewsLocation0 # Default created by mkNormalFieldName
308 - name: news_NewsLocation1 # Default created by mkNormalFieldName
309 dbName: news_locations_id
319 -- | Convert a 'NewsTeam' to/from XML.
321 pickle_news_team :: PU NewsTeam
324 xpWrap (from_string, to_string) xpText
326 to_string :: NewsTeam -> String
327 to_string = team_name
329 from_string :: String -> NewsTeam
330 from_string = NewsTeam
333 -- | Convert a 'MsgId' to/from XML.
335 pickle_msg_id :: PU MsgId
338 xpWrap (from_tuple, to_tuple) $
339 xpPair xpInt (xpAttr "EventId" (xpOption xpInt))
341 from_tuple = uncurryN MsgId
342 to_tuple m = (db_msg_id m, db_event_id m)
345 -- | Convert a 'NewsLocation' to/from XML.
347 pickle_location :: PU NewsLocation
350 xpWrap (from_tuple, to_tuple) $
351 xpTriple (xpOption (xpElem "city" xpText))
352 (xpOption (xpElem "state" xpText))
353 (xpElem "country" xpText)
356 uncurryN NewsLocation
357 to_tuple l = (city l, state l, country l)
360 -- | Convert a 'Message' to/from XML.
362 pickle_message :: PU Message
365 xpWrap (from_tuple, to_tuple) $
366 xp13Tuple (xpElem "XML_File_ID" xpInt)
367 (xpElem "heading" xpText)
369 (xpElem "category" xpText)
370 (xpElem "sport" xpText)
371 (xpElem "url" $ xpOption xpText)
372 (xpList pickle_news_team)
373 (xpList pickle_location)
374 (xpElem "SMS" xpText)
375 (xpOption (xpElem "Editor" xpText))
376 (xpOption (xpElem "text" xpText))
378 (xpElem "time_stamp" xp_time_stamp)
380 from_tuple = uncurryN Message
381 to_tuple m = (xml_xml_file_id m, -- Verbose,
382 xml_heading m, -- but
383 xml_mid m, -- eliminates
384 xml_category m, -- GHC
385 xml_sport m, -- warnings
388 xml_locations m, -- .
395 -- | We combine all of the \<continue\> elements into one 'String'
396 -- while unpickling and do the reverse while pickling.
398 pickle_continue :: PU (Maybe String)
401 xpWrap (to_string, from_string) $
403 xpList (xpElem "P" xpText)
405 from_string :: String -> [String]
406 from_string = split "\n"
408 to_string :: [String] -> String
409 to_string = join "\n"
416 -- | A list of all tests for this module.
418 news_tests :: TestTree
422 [ test_news_fields_have_correct_names,
423 test_pickle_of_unpickle_is_identity,
424 test_unpickle_succeeds ]
427 -- | Make sure our codegen is producing the correct database names.
429 test_news_fields_have_correct_names :: TestTree
430 test_news_fields_have_correct_names =
431 testCase "news fields get correct database names" $
432 mapM_ check (zip actual expected)
434 -- This is cool, it uses the (derived) Data instance of
435 -- News.News to get its constructor names.
436 field_names :: [String]
438 constrFields . head $ dataTypeConstrs $ dataTypeOf (undefined :: News)
442 map (\x -> tsn_db_field_namer "herp" "derp" 8675309 x 90210) field_names
445 actual = ["xml_file_id",
454 check (x,y) = (x @?= y)
457 -- | If we unpickle something and then pickle it, we should wind up
458 -- with the same thing we started with. WARNING: success of this
459 -- test does not mean that unpickling succeeded.
461 test_pickle_of_unpickle_is_identity :: TestTree
462 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
463 [ check "pickle composed with unpickle is the identity"
464 "test/xml/newsxml.xml",
466 check "pickle composed with unpickle is the identity (with Editor)"
467 "test/xml/newsxml-with-editor.xml" ]
469 check desc path = testCase desc $ do
470 (expected, actual) <- pickle_unpickle pickle_message path
474 -- | Make sure we can actually unpickle these things.
476 test_unpickle_succeeds :: TestTree
477 test_unpickle_succeeds = testGroup "unpickle tests"
478 [ check "unpickling succeeds"
479 "test/xml/newsxml.xml",
481 check "unpickling succeeds (with Editor)"
482 "test/xml/newsxml-with-editor.xml" ]
484 check desc path = testCase desc $ do
485 actual <- unpickleable path pickle_message