1 {-# LANGUAGE DeriveGeneric #-}
2 {-# LANGUAGE DeriveDataTypeable #-}
3 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE QuasiQuotes #-}
6 {-# LANGUAGE RecordWildCards #-}
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.
19 -- * WARNING: these are private but exported to silence warnings
20 News_LocationConstructor(..),
21 News_TeamConstructor(..),
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 qualified Data.Vector.HFixed as H ( HVector, convert )
32 import Database.Groundhog (
37 import Database.Groundhog.Core ( DefaultKey )
38 import Database.Groundhog.Generic ( runDbConn, runMigrationSilent )
39 import Database.Groundhog.Sqlite ( withSqliteConn )
40 import Database.Groundhog.TH (
43 import qualified GHC.Generics as GHC ( Generic )
44 import Test.Tasty ( TestTree, testGroup )
45 import Test.Tasty.HUnit ( (@?=), testCase )
46 import Text.XML.HXT.Core (
71 tsn_db_field_namer ) -- Used in a test
72 import TSN.Database ( insert_or_select )
73 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
74 import TSN.Location ( Location(..), pickle_location )
75 import TSN.Picklers ( xp_attr_option, xp_time_stamp )
76 import TSN.Team ( Team(..) )
77 import TSN.XmlImport ( XmlImport(..) )
83 unsafe_read_invalid_document,
87 -- | The DTD to which this module corresponds. Used to invoke dbimport.
99 -- | The msg_id child of \<message\> contains an event_id attribute; we
100 -- embed it into the 'News' type. We (pointlessly) use the \"db_\"
101 -- prefix here so that the two names don't collide on \"id\" when
102 -- Groundhog is creating its fields using our field namer.
104 -- The leading underscores prevent unused field warnings.
109 _db_event_id :: Maybe Int }
110 deriving (Data, Eq, GHC.Generic, Show, Typeable)
112 -- | For 'H.convert'.
114 instance H.HVector MsgId
117 -- | The XML representation of a news item (\<message\>).
121 xml_xml_file_id :: Int,
122 xml_heading :: String,
124 xml_category :: String,
126 xml_url :: Maybe String,
127 xml_teams :: [NewsTeamXml],
128 xml_locations :: [Location],
129 xml_sms :: Maybe String,
130 xml_editor :: Maybe String,
131 xml_text :: Maybe String, -- Text and continue seem to show up in pairs,
132 xml_continue :: Maybe String, -- either both present or both missing.
133 xml_time_stamp :: UTCTime }
134 deriving (Eq, GHC.Generic, Show)
137 -- | For 'H.convert'.
139 instance H.HVector Message
142 -- | The database representation of a news item. We drop several
143 -- uninteresting fields from 'Message', and omit the list fields which
144 -- will be represented as join tables.
148 db_xml_file_id :: Int,
151 db_url :: Maybe String,
152 db_sms :: Maybe String,
153 db_editor :: Maybe String,
154 db_text :: Maybe String,
155 db_continue :: Maybe String,
156 db_time_stamp :: UTCTime }
157 deriving (Data, Eq, Show, Typeable)
161 instance ToDb Message where
162 -- | The database representation of 'Message' is 'News'.
163 type Db Message = News
165 -- | Convert the XML representation 'Message' to the database
166 -- representation 'News'.
168 instance FromXml Message where
169 -- | We use a record wildcard so GHC doesn't complain that we never
170 -- used the field names.
172 -- To convert, we drop some fields.
174 from_xml Message{..} = News { db_xml_file_id = xml_xml_file_id,
176 db_sport = xml_sport,
179 db_editor = xml_editor,
181 db_continue = xml_continue,
182 db_time_stamp = xml_time_stamp }
184 -- | This lets us insert the XML representation 'Message' directly.
186 instance XmlImport Message
191 -- | The XML type for teams as they show up in the news. We can't
192 -- reuse the representation from "TSN.Team" because our name doesn't
193 -- appear optional and we have no abbreviation.
196 NewsTeamXml { xml_team_id :: String,
197 xml_team_name :: String }
198 deriving (Eq, GHC.Generic, Show)
201 -- | For 'H.convert'.
203 instance H.HVector NewsTeamXml
206 instance ToDb NewsTeamXml where
207 -- | The database representation of 'NewsTeamXml' is 'Team'.
208 type Db NewsTeamXml = Team
210 -- | Convert the XML representation 'NewsTeamXml' to the database
211 -- representation 'Team'.
213 instance FromXml NewsTeamXml where
214 from_xml NewsTeamXml{..} =
215 Team { team_id = xml_team_id,
216 abbreviation = Nothing,
217 name = Just xml_team_name }
219 -- | Allow us to import 'NewsTeamXml' directly.
221 instance XmlImport NewsTeamXml
226 -- | Mapping between News records and Team records in the database. We
227 -- don't name the fields because we don't use the names explicitly;
228 -- that means we have to give them nice database names via
231 data News_Team = News_Team (DefaultKey News) (DefaultKey Team)
236 -- | Mapping between 'News' records and 'Location' records in the
237 -- database. We don't name the fields because we don't use the names
238 -- explicitly; that means we have to give them nice database names
241 data News_Location = News_Location
243 (DefaultKey Location)
248 -- | Some newsxml documents contain two \<SMS\> elements in a row,
249 -- violating the DTD. The second one has always been empty, but it's
250 -- irrelevant: we can't parse these, and would like to detect them
251 -- in order to report the fact that the busted document is
254 -- This function detects whether two \<SMS\> elements appear in a
257 has_only_single_sms :: XmlTree -> Bool
258 has_only_single_sms xmltree =
263 parse :: XmlTree -> [XmlTree]
264 parse = runLA $ hasName "/"
268 >>> filterAxis (hasName "SMS")
269 >>> followingSiblingAxis
273 elements = parse xmltree
280 -- | Define 'dbmigrate' and 'dbimport' for 'Message's. The import is
281 -- slightly non-generic because of our 'News_Team' and
282 -- 'News_Location' join tables.
284 instance DbImport Message where
287 migrate (undefined :: Location)
288 migrate (undefined :: News)
289 migrate (undefined :: Team)
290 migrate (undefined :: News_Team)
291 migrate (undefined :: News_Location)
293 dbimport message = do
294 -- Insert the message and acquire its primary key (unique ID)
295 news_id <- insert_xml message
297 -- Now insert the teams. We use insert_xml_or_select because we
298 -- know that most teams will already exist, and we want to get
299 -- back the id for the existing team when there's a collision.
300 team_ids <- mapM insert_xml_or_select (xml_teams message)
302 -- Now that the teams have been inserted, create
303 -- news__team records mapping beween the two.
304 let news_teams = map (News_Team news_id) team_ids
305 mapM_ insert_ news_teams
307 -- Do all of that over again for the Locations.
308 loc_ids <- mapM insert_or_select (xml_locations message)
309 let news_news_locations = map (News_Location news_id) loc_ids
310 mapM_ insert_ news_news_locations
312 return ImportSucceeded
316 -- These types have fields with e.g. db_ and xml_ prefixes, so we
317 -- use our own codegen to peel those off before naming the columns.
318 mkPersist tsn_codegen_config [groundhog|
325 # Prevent multiple imports of the same message.
326 fields: [db_xml_file_id]
330 - {name: msg_id, dbName: msg_id}
331 - {name: event_id, dbName: event_id}
345 - name: news_Team0 # Default created by mkNormalFieldName
349 - name: news_Team1 # Default created by mkNormalFieldName
354 - entity: News_Location
355 dbName: news__locations
357 - name: News_Location
359 - name: news_Location0 # Default created by mkNormalFieldName
363 - name: news_Location1 # Default created by mkNormalFieldName
374 -- | Convert a 'NewsTeamXml' to/from XML.
376 pickle_news_team :: PU NewsTeamXml
379 xpWrap (from_tuple, H.convert) $
380 xpPair (xpAttr "id" xpText)
383 from_tuple = uncurry NewsTeamXml
386 -- | Convert a 'MsgId' to/from XML.
388 pickle_msg_id :: PU MsgId
391 xpWrap (from_tuple, H.convert) $
392 xpPair xpInt (xpAttr "EventId" xp_attr_option)
394 from_tuple = uncurryN MsgId
398 -- | Convert a 'Message' to/from XML.
400 pickle_message :: PU Message
403 xpWrap (from_tuple, H.convert) $
404 xp13Tuple (xpElem "XML_File_ID" xpInt)
405 (xpElem "heading" xpText)
407 (xpElem "category" xpText)
408 (xpElem "sport" xpText)
409 (xpElem "url" $ xpOption xpText)
410 (xpList pickle_news_team)
411 (xpList pickle_location)
412 (xpElem "SMS" $ xpOption xpText)
413 (xpOption (xpElem "Editor" xpText))
414 (xpOption (xpElem "text" xpText))
416 (xpElem "time_stamp" xp_time_stamp)
418 from_tuple = uncurryN Message
421 -- | We combine all of the \<continue\> elements into one 'String'
422 -- while unpickling and do the reverse while pickling.
424 pickle_continue :: PU (Maybe String)
427 xpWrap (to_string, from_string) $
429 xpList (xpElem "P" xpText)
431 from_string :: String -> [String]
432 from_string = split "\n"
434 to_string :: [String] -> String
435 to_string = join "\n"
442 -- | A list of all tests for this module.
444 news_tests :: TestTree
448 [ test_news_fields_have_correct_names,
449 test_on_delete_cascade,
450 test_pickle_of_unpickle_is_identity,
451 test_unpickle_succeeds,
452 test_sms_detected_correctly ]
455 -- | Make sure our codegen is producing the correct database names.
457 test_news_fields_have_correct_names :: TestTree
458 test_news_fields_have_correct_names =
459 testCase "news fields get correct database names" $
460 mapM_ check (zip actual expected)
462 -- This is cool, it uses the (derived) Data instance of
463 -- News.News to get its constructor names.
464 field_names :: [String]
466 constrFields . head $ dataTypeConstrs $ dataTypeOf (undefined :: News)
470 map (\x -> tsn_db_field_namer "herp" "derp" 8675309 x 90210) field_names
473 actual = ["xml_file_id",
482 check (x,y) = (x @?= y)
485 -- | If we unpickle something and then pickle it, we should wind up
486 -- with the same thing we started with. WARNING: success of this
487 -- test does not mean that unpickling succeeded.
489 test_pickle_of_unpickle_is_identity :: TestTree
490 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
491 [ check "pickle composed with unpickle is the identity"
492 "test/xml/newsxml.xml",
494 check "pickle composed with unpickle is the identity (with Editor)"
495 "test/xml/newsxml-with-editor.xml",
497 check "pickle composed with unpickle is the identity (empty SMS)"
498 "test/xml/newsxml-empty-sms.xml" ]
500 check desc path = testCase desc $ do
501 (expected, actual) <- pickle_unpickle pickle_message path
505 -- | Make sure we can actually unpickle these things.
507 test_unpickle_succeeds :: TestTree
508 test_unpickle_succeeds = testGroup "unpickle tests"
509 [ check "unpickling succeeds"
510 "test/xml/newsxml.xml",
512 check "unpickling succeeds (with Editor)"
513 "test/xml/newsxml-with-editor.xml",
515 check "unpickling succeeds (empty SMS)"
516 "test/xml/newsxml-empty-sms.xml" ]
518 check desc path = testCase desc $ do
519 actual <- unpickleable path pickle_message
524 -- | Make sure everything gets deleted when we delete the top-level
527 test_on_delete_cascade :: TestTree
528 test_on_delete_cascade = testGroup "cascading delete tests"
529 [ check "deleting news deletes its children"
530 "test/xml/newsxml.xml"
531 4 -- 2 news_teams and 2 news_locations that should remain.
533 check "deleting news deletes its children (empty SMS)"
534 "test/xml/newsxml-empty-sms.xml"
535 4 -- 2 news_teams and 2 news_locations
538 check desc path expected = testCase desc $ do
539 news <- unsafe_unpickle path pickle_message
540 let a = undefined :: Location
541 let b = undefined :: News
542 let c = undefined :: Team
543 let d = undefined :: News_Team
544 let e = undefined :: News_Location
545 actual <- withSqliteConn ":memory:" $ runDbConn $ do
546 runMigrationSilent $ do
554 count_a <- countAll a
555 count_b <- countAll b
556 count_c <- countAll c
557 count_d <- countAll d
558 count_e <- countAll e
559 return $ count_a + count_b + count_c + count_d + count_e
563 -- | We want to make sure the single-SMS documents and the multi-SMS
564 -- documents are identified correctly.
566 test_sms_detected_correctly :: TestTree
567 test_sms_detected_correctly =
568 testGroup "newsxml SMS count determined correctly"
569 [ check "test/xml/newsxml.xml"
570 "single SMS detected correctly"
572 check "test/xml/newsxml-multiple-sms.xml"
573 "multiple SMS detected correctly"
576 check path desc expected = testCase desc $ do
577 xmltree <- unsafe_read_invalid_document path
578 let actual = has_only_single_sms xmltree