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_LocationConstructor(..),
19 News_NewsTeamConstructor(..),
21 NewsTeamConstructor(..) )
25 import Data.Data ( Data, constrFields, dataTypeConstrs, dataTypeOf )
26 import Data.Time.Clock ( UTCTime )
27 import Data.List.Utils ( join, split )
28 import Data.Tuple.Curry ( uncurryN )
29 import Data.Typeable ( Typeable )
30 import Database.Groundhog (
36 silentMigrationLogger )
37 import Database.Groundhog.Core ( DefaultKey )
38 import Database.Groundhog.Generic ( runDbConn )
39 import Database.Groundhog.Sqlite ( withSqliteConn )
40 import Database.Groundhog.TH (
44 import Test.Tasty ( TestTree, testGroup )
45 import Test.Tasty.HUnit ( (@?=), testCase )
46 import Text.XML.HXT.Core (
61 tsn_db_field_namer ) -- Used in a test
62 import TSN.Database ( insert_or_select )
63 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
64 import TSN.Picklers ( xp_time_stamp )
65 import TSN.Location ( Location(..), pickle_location )
66 import TSN.XmlImport ( XmlImport(..) )
75 -- | The DTD to which this module corresponds. Used to invoke dbimport.
87 -- | The msg_id child of \<message\> contains an event_id attribute; we
88 -- embed it into the 'News' type. We (pointlessly) use the \"db_\"
89 -- prefix here so that the two names don't collide on \"id\" when
90 -- Groundhog is creating its fields using our field namer.
95 db_event_id :: Maybe Int }
96 deriving (Data, Eq, Show, Typeable)
99 -- | The XML representation of a news item (\<message\>).
103 xml_xml_file_id :: Int,
104 xml_heading :: String,
106 xml_category :: String,
108 xml_url :: Maybe String,
109 xml_teams :: [NewsTeam],
110 xml_locations :: [Location],
112 xml_editor :: Maybe String,
113 xml_text :: Maybe String, -- Text and continue seem to show up in pairs,
114 xml_continue :: Maybe String, -- either both present or both missing.
115 xml_time_stamp :: UTCTime }
119 -- | The database representation of a news item. We drop several
120 -- uninteresting fields from 'Message', and omit the list fields which
121 -- will be represented as join tables.
125 db_xml_file_id :: Int,
128 db_url :: Maybe String,
130 db_editor :: Maybe String,
131 db_text :: Maybe String,
132 db_continue :: Maybe String,
133 db_time_stamp :: UTCTime }
134 deriving (Data, Eq, Show, Typeable)
138 instance ToDb Message where
139 -- | The database representation of 'Message' is 'News'.
140 type Db Message = News
142 -- | Convert the XML representation 'Message' to the database
143 -- representation 'News'.
145 instance FromXml Message where
146 -- | We use a record wildcard so GHC doesn't complain that we never
147 -- used the field names.
149 from_xml Message{..} = News { db_xml_file_id = xml_xml_file_id,
151 db_sport = xml_sport,
154 db_editor = xml_editor,
156 db_continue = xml_continue,
157 db_time_stamp = xml_time_stamp }
159 -- | This lets us insert the XML representation 'Message' directly.
161 instance XmlImport Message
166 -- | The database/XML type for teams as they show up in the news. We
167 -- can't reuse the representation from "TSN.Team" because they
168 -- require a team id. We wouldn't want to make the team ID optional
169 -- and then insert a team with no id, only to find the same team
170 -- later with an id and be unable to update the record. (We could
171 -- add the update logic, but it would be more trouble than it's
175 NewsTeam { team_name :: String }
182 -- | Mapping between News records and NewsTeam records in the
183 -- database. We don't name the fields because we don't use the names
184 -- explicitly; that means we have to give them nice database names
187 data News_NewsTeam = News_NewsTeam
189 (DefaultKey NewsTeam)
194 -- | Mapping between 'News' records and 'Location' records in the
195 -- database. We don't name the fields because we don't use the names
196 -- explicitly; that means we have to give them nice database names
199 data News_Location = News_Location
201 (DefaultKey Location)
209 -- | Define 'dbmigrate' and 'dbimport' for 'Message's. The import is
210 -- slightly non-generic because of our 'News_NewsTeam' and
211 -- 'News_Location' join tables.
213 instance DbImport Message where
216 migrate (undefined :: Location)
217 migrate (undefined :: News)
218 migrate (undefined :: NewsTeam)
219 migrate (undefined :: News_NewsTeam)
220 migrate (undefined :: News_Location)
222 dbimport message = do
223 -- Insert the message and acquire its primary key (unique ID)
224 news_id <- insert_xml message
226 -- Now insert the teams. We use insert_or_select because we know
227 -- that most teams will already exist, and we want to get back the
228 -- id for the existing team when there's a collision.
229 nt_ids <- mapM insert_or_select (xml_teams message)
231 -- Now that the teams have been inserted, create
232 -- news__news_team records mapping beween the two.
233 let news_news_teams = map (News_NewsTeam news_id) nt_ids
234 mapM_ insert_ news_news_teams
236 -- Do all of that over again for the Locations.
237 loc_ids <- mapM insert_or_select (xml_locations message)
238 let news_news_locations = map (News_Location news_id) loc_ids
239 mapM_ insert_ news_news_locations
241 return ImportSucceeded
244 -- These types don't have special XML representations or field name
245 -- collisions so we use the defaultCodegenConfig and give their
246 -- fields nice simple names.
247 mkPersist defaultCodegenConfig [groundhog|
253 - name: unique_news_team
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|
269 # Prevent multiple imports of the same message.
270 fields: [db_xml_file_id]
274 - {name: msg_id, dbName: msg_id}
275 - {name: event_id, dbName: event_id}
284 - entity: News_NewsTeam
285 dbName: news__news_teams
287 - name: News_NewsTeam
289 - name: news_NewsTeam0 # Default created by mkNormalFieldName
293 - name: news_NewsTeam1 # Default created by mkNormalFieldName
294 dbName: news_teams_id
298 - entity: News_Location
299 dbName: news__locations
301 - name: News_Location
303 - name: news_Location0 # Default created by mkNormalFieldName
307 - name: news_Location1 # Default created by mkNormalFieldName
318 -- | Convert a 'NewsTeam' to/from XML.
320 pickle_news_team :: PU NewsTeam
323 xpWrap (from_string, to_string) xpText
325 to_string :: NewsTeam -> String
326 to_string = team_name
328 from_string :: String -> NewsTeam
329 from_string = NewsTeam
332 -- | Convert a 'MsgId' to/from XML.
334 pickle_msg_id :: PU MsgId
337 xpWrap (from_tuple, to_tuple) $
338 xpPair xpInt (xpAttr "EventId" (xpOption xpInt))
340 from_tuple = uncurryN MsgId
341 to_tuple m = (db_msg_id m, db_event_id m)
345 -- | Convert a 'Message' to/from XML.
347 pickle_message :: PU Message
350 xpWrap (from_tuple, to_tuple) $
351 xp13Tuple (xpElem "XML_File_ID" xpInt)
352 (xpElem "heading" xpText)
354 (xpElem "category" xpText)
355 (xpElem "sport" xpText)
356 (xpElem "url" $ xpOption xpText)
357 (xpList pickle_news_team)
358 (xpList pickle_location)
359 (xpElem "SMS" xpText)
360 (xpOption (xpElem "Editor" xpText))
361 (xpOption (xpElem "text" xpText))
363 (xpElem "time_stamp" xp_time_stamp)
365 from_tuple = uncurryN Message
366 to_tuple m = (xml_xml_file_id m, -- Verbose,
367 xml_heading m, -- but
368 xml_mid m, -- eliminates
369 xml_category m, -- GHC
370 xml_sport m, -- warnings
373 xml_locations m, -- .
380 -- | We combine all of the \<continue\> elements into one 'String'
381 -- while unpickling and do the reverse while pickling.
383 pickle_continue :: PU (Maybe String)
386 xpWrap (to_string, from_string) $
388 xpList (xpElem "P" xpText)
390 from_string :: String -> [String]
391 from_string = split "\n"
393 to_string :: [String] -> String
394 to_string = join "\n"
401 -- | A list of all tests for this module.
403 news_tests :: TestTree
407 [ test_news_fields_have_correct_names,
408 test_on_delete_cascade,
409 test_pickle_of_unpickle_is_identity,
410 test_unpickle_succeeds ]
413 -- | Make sure our codegen is producing the correct database names.
415 test_news_fields_have_correct_names :: TestTree
416 test_news_fields_have_correct_names =
417 testCase "news fields get correct database names" $
418 mapM_ check (zip actual expected)
420 -- This is cool, it uses the (derived) Data instance of
421 -- News.News to get its constructor names.
422 field_names :: [String]
424 constrFields . head $ dataTypeConstrs $ dataTypeOf (undefined :: News)
428 map (\x -> tsn_db_field_namer "herp" "derp" 8675309 x 90210) field_names
431 actual = ["xml_file_id",
440 check (x,y) = (x @?= y)
443 -- | If we unpickle something and then pickle it, we should wind up
444 -- with the same thing we started with. WARNING: success of this
445 -- test does not mean that unpickling succeeded.
447 test_pickle_of_unpickle_is_identity :: TestTree
448 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
449 [ check "pickle composed with unpickle is the identity"
450 "test/xml/newsxml.xml",
452 check "pickle composed with unpickle is the identity (with Editor)"
453 "test/xml/newsxml-with-editor.xml" ]
455 check desc path = testCase desc $ do
456 (expected, actual) <- pickle_unpickle pickle_message path
460 -- | Make sure we can actually unpickle these things.
462 test_unpickle_succeeds :: TestTree
463 test_unpickle_succeeds = testGroup "unpickle tests"
464 [ check "unpickling succeeds"
465 "test/xml/newsxml.xml",
467 check "unpickling succeeds (with Editor)"
468 "test/xml/newsxml-with-editor.xml" ]
470 check desc path = testCase desc $ do
471 actual <- unpickleable path pickle_message
476 -- | Make sure everything gets deleted when we delete the top-level
479 test_on_delete_cascade :: TestTree
480 test_on_delete_cascade = testGroup "cascading delete tests"
481 [ check "deleting news deletes its children"
482 "test/xml/newsxml.xml"
483 4 -- 2 news_teams and 2 news_locations that should remain.
486 check desc path expected = testCase desc $ do
487 news <- unsafe_unpickle path pickle_message
488 let a = undefined :: Location
489 let b = undefined :: News
490 let c = undefined :: NewsTeam
491 let d = undefined :: News_NewsTeam
492 let e = undefined :: News_Location
493 actual <- withSqliteConn ":memory:" $ runDbConn $ do
494 runMigration silentMigrationLogger $ do
502 count_a <- countAll a
503 count_b <- countAll b
504 count_c <- countAll c
505 count_d <- countAll d
506 count_e <- countAll e
507 return $ count_a + count_b + count_c + count_d + count_e