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.
16 -- * WARNING: these are private but exported to silence warnings
17 News_NewsLocationConstructor(..),
18 News_NewsTeamConstructor(..),
20 NewsLocationConstructor(..),
21 NewsTeamConstructor(..) )
25 import Data.Data ( Data, constrFields, dataTypeConstrs, dataTypeOf )
26 import Data.List.Utils ( join, split )
27 import Data.Tuple.Curry ( uncurryN )
28 import Data.Typeable ( Typeable )
29 import Database.Groundhog (
32 import Database.Groundhog.Core ( DefaultKey )
33 import Database.Groundhog.TH (
37 import Test.Tasty ( TestTree, testGroup )
38 import Test.Tasty.HUnit ( (@?=), testCase )
39 import Text.XML.HXT.Core (
55 tsn_db_field_namer ) -- Used in a test
56 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
57 import TSN.XmlImport ( XmlImport(..) )
58 import Xml ( FromXml(..), pickle_unpickle, unpickleable )
62 -- | The database type for teams as they show up in the news.
65 NewsTeam { team_name :: String }
68 -- | This is needed to define the XmlImport instance for NewsTeam; it
69 -- basically says that the DB representation is the same as the XML
72 instance FromXml NewsTeam where
73 type Db NewsTeam = NewsTeam
76 -- | Allow us to call 'insert_xml' on the XML representation of
79 instance XmlImport NewsTeam
82 -- | Mapping between News records and NewsTeam records in the
83 -- database. We don't name the fields because we don't use the names
84 -- explicitly; that means we have to give them nice database names
87 data News_NewsTeam = News_NewsTeam
92 -- | The database type for locations as they show up in the news.
97 state :: Maybe String,
101 -- | This is needed to define the XmlImport instance for NewsLocation; it
102 -- basically says that the DB representation is the same as the XML
105 instance FromXml NewsLocation where
106 type Db NewsLocation = NewsLocation
109 -- | Allow us to call 'insert_xml' on the XML representation of
112 instance XmlImport NewsLocation
115 -- | Mapping between News records and NewsLocation records in the
116 -- database. We don't name the fields because we don't use the names
117 -- explicitly; that means we have to give them nice database names
120 data News_NewsLocation = News_NewsLocation
122 (DefaultKey NewsLocation)
125 -- | The msg_id child of <message> contains an event_id attribute; we
126 -- embed it into the 'News' type. We (pointlessly) use the "db_"
127 -- prefix here so that the two names don't collide on "id" when
128 -- Groundhog is creating its fields using our field namer.
132 db_event_id :: Maybe Int }
133 deriving (Data, Eq, Show, Typeable)
136 -- | The XML representation of a news item (message).
140 xml_xml_file_id :: Int,
141 xml_heading :: String,
143 xml_category :: String,
145 xml_url :: Maybe String,
146 xml_teams :: [NewsTeam],
147 xml_locations :: [NewsLocation],
149 xml_editor :: Maybe String,
150 xml_text :: Maybe String, -- Text and continue seem to show up in pairs,
151 xml_continue :: Maybe String, -- either both present or both missing.
152 xml_time_stamp :: String }
156 -- | The database representation of a news item. We drop several
157 -- uninteresting fields from 'Message', and omit the list fields which
158 -- will be represented as join tables.
164 db_url :: Maybe String,
166 db_editor :: Maybe String,
167 db_text :: Maybe String,
168 db_continue :: Maybe String }
169 deriving (Data, Eq, Show, Typeable)
172 -- | Convert the XML representation 'Message' to the database
173 -- representation 'News'.
175 instance FromXml Message where
176 type Db Message = News
178 -- | We use a record wildcard so GHC doesn't complain that we never
179 -- used the field names.
181 from_xml Message{..} = News { db_mid = xml_mid,
182 db_sport = xml_sport,
185 db_editor = xml_editor,
187 db_continue = xml_continue }
189 -- | This lets us call 'insert_xml' on a 'Message'.
191 instance XmlImport Message
193 -- | Define 'dbmigrate' and 'dbimport' for 'Message's. The import is
194 -- slightly non-generic because of our 'News_NewsTeam' and
195 -- 'News_NewsLocation' join tables.
197 instance DbImport Message where
200 migrate (undefined :: NewsTeam)
201 migrate (undefined :: NewsLocation)
202 migrate (undefined :: News)
203 migrate (undefined :: News_NewsTeam)
204 migrate (undefined :: News_NewsLocation)
206 dbimport message = do
207 -- Insert the message and acquire its primary key (unique ID)
208 news_id <- insert_xml message
210 -- And insert each one into its own table. We use insert_xml_or_select
211 -- because we know that most teams will already exist, and we
212 -- want to get back the id for the existing team when
213 -- there's a collision.
214 nt_ids <- mapM insert_xml_or_select (xml_teams message)
216 -- Now that the teams have been inserted, create
217 -- news__news_team records mapping beween the two.
218 let news_news_teams = map (News_NewsTeam news_id) nt_ids
219 mapM_ insert_ news_news_teams
221 -- Do all of that over again for the NewsLocations.
222 loc_ids <- mapM insert_xml_or_select (xml_locations message)
223 let news_news_locations = map (News_NewsLocation news_id) loc_ids
224 mapM_ insert_ news_news_locations
226 return ImportSucceeded
229 -- | These types don't have special XML representations or field name
230 -- collisions so we use the defaultCodegenConfig and give their
231 -- fields nice simple names.
232 mkPersist defaultCodegenConfig [groundhog|
238 - name: unique_news_team
242 - entity: NewsLocation
243 dbName: news_locations
247 - name: unique_news_location
249 fields: [city, state, country]
254 -- | These types have fields with e.g. db_ and xml_ prefixes, so we
255 -- use our own codegen to peel those off before naming the columns.
257 mkPersist tsn_codegen_config [groundhog|
265 - {name: msg_id, dbName: msg_id}
266 - {name: event_id, dbName: event_id}
275 - entity: News_NewsTeam
276 dbName: news__news_teams
278 - name: News_NewsTeam
280 - name: news_NewsTeam0 # Default created by mkNormalFieldName
282 - name: news_NewsTeam1 # Default created by mkNormalFieldName
283 dbName: news_teams_id
285 - entity: News_NewsLocation
286 dbName: news__news_locations
288 - name: News_NewsLocation
290 - name: news_NewsLocation0 # Default created by mkNormalFieldName
292 - name: news_NewsLocation1 # Default created by mkNormalFieldName
293 dbName: news_locations_id
297 -- | Convert a 'NewsTeam' to/from XML.
299 pickle_news_team :: PU NewsTeam
302 xpWrap (from_string, to_string) xpText
304 to_string :: NewsTeam -> String
305 to_string = team_name
307 from_string :: String -> NewsTeam
308 from_string = NewsTeam
311 -- | Convert a 'MsgId' to/from XML.
313 pickle_msg_id :: PU MsgId
316 xpWrap (from_tuple, to_tuple) $
317 xpPair xpInt (xpAttr "EventId" (xpOption xpInt))
319 from_tuple = uncurryN MsgId
320 to_tuple m = (db_msg_id m, db_event_id m)
323 -- | Convert a 'NewsLocation' to/from XML.
325 pickle_location :: PU NewsLocation
328 xpWrap (from_tuple, to_tuple) $
329 xpTriple (xpOption (xpElem "city" xpText))
330 (xpOption (xpElem "state" xpText))
331 (xpElem "country" xpText)
334 uncurryN NewsLocation
335 to_tuple l = (city l, state l, country l)
338 -- | Convert a 'Message' to/from XML.
340 pickle_message :: PU Message
343 xpWrap (from_tuple, to_tuple) $
344 xp13Tuple (xpElem "XML_File_ID" xpInt)
345 (xpElem "heading" xpText)
347 (xpElem "category" xpText)
348 (xpElem "sport" xpText)
349 (xpElem "url" $ xpOption xpText)
350 (xpList pickle_news_team)
351 (xpList pickle_location)
352 (xpElem "SMS" xpText)
353 (xpOption (xpElem "Editor" xpText))
354 (xpOption (xpElem "text" xpText))
356 (xpElem "time_stamp" xpText)
358 from_tuple = uncurryN Message
359 to_tuple m = (xml_xml_file_id m, -- Verbose,
360 xml_heading m, -- but
361 xml_mid m, -- eliminates
362 xml_category m, -- GHC
363 xml_sport m, -- warnings
366 xml_locations m, -- .
373 -- | We combine all of the \<continue\> elements into one 'String'
374 -- while unpickling and do the reverse while pickling.
376 pickle_continue :: PU (Maybe String)
379 xpWrap (to_string, from_string) $
381 xpList (xpElem "P" xpText)
383 from_string :: String -> [String]
384 from_string = split "\n"
386 to_string :: [String] -> String
387 to_string = join "\n"
392 news_tests :: TestTree
396 [ test_news_fields_have_correct_names,
397 test_pickle_of_unpickle_is_identity,
398 test_unpickle_succeeds ]
401 test_news_fields_have_correct_names :: TestTree
402 test_news_fields_have_correct_names =
403 testCase "news fields get correct database names" $
404 mapM_ check (zip actual expected)
406 -- This is cool, it uses the (derived) Data instance of
407 -- News.News to get its constructor names.
408 field_names :: [String]
410 constrFields . head $ dataTypeConstrs $ dataTypeOf (undefined :: News)
414 map (\x -> tsn_db_field_namer "herp" "derp" 8675309 x 90210) field_names
417 actual = ["mid", "sport", "url", "sms", "editor", "text", "continue"]
419 check (x,y) = (x @?= y)
422 -- | Warning, succeess of this test does not mean that unpickling
424 test_pickle_of_unpickle_is_identity :: TestTree
425 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
426 [ check "pickle composed with unpickle is the identity"
427 "test/xml/newsxml.xml",
429 check "pickle composed with unpickle is the identity (with Editor)"
430 "test/xml/newsxml-with-editor.xml" ]
432 check desc path = testCase desc $ do
433 (expected, actual) <- pickle_unpickle pickle_message path
437 test_unpickle_succeeds :: TestTree
438 test_unpickle_succeeds = testGroup "unpickle tests"
439 [ check "unpickling succeeds"
440 "test/xml/newsxml.xml",
442 check "unpickling succeeds (with Editor)"
443 "test/xml/newsxml-with-editor.xml" ]
445 check desc path = testCase desc $ do
446 actual <- unpickleable path pickle_message