src/TSN/XML/News.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE QuasiQuotes #-}
   5 {-# LANGUAGE RecordWildCards #-}
   6 {-# LANGUAGE TemplateHaskell #-}
   7 {-# LANGUAGE TypeFamilies #-}
   8
   9 -- | Parse TSN XML for the DTD \"newsxml.dtd\". Each document contains
  10 --   a root element \<message\> that contains an entire news item.
  11 --
  12 module TSN.XML.News (
  13   dtd,
  14   has_only_single_sms,
  15   pickle_message,
  16   -- * Tests
  17   news_tests,
  18   -- * WARNING: these are private but exported to silence warnings
  19   News_LocationConstructor(..),
  20   News_TeamConstructor(..),
  21   NewsConstructor(..) )
  22 where
  23
  24 -- System imports.
  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 (
  31   countAll,
  32   deleteAll,
  33   insert_,
  34   migrate,
  35   runMigration,
  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 (
  41   groundhog,
  42   mkPersist )
  43 import Test.Tasty ( TestTree, testGroup )
  44 import Test.Tasty.HUnit ( (@?=), testCase )
  45 import Text.XML.HXT.Core (
  46   PU,
  47   XmlTree,
  48   (/>),
  49   (>>>),
  50   addNav,
  51   descendantAxis,
  52   filterAxis,
  53   followingSiblingAxis,
  54   hasName,
  55   remNav,
  56   runLA,
  57   xp13Tuple,
  58   xpAttr,
  59   xpElem,
  60   xpInt,
  61   xpList,
  62   xpOption,
  63   xpPair,
  64   xpText,
  65   xpWrap )
  66
  67 -- Local imports.
  68 import TSN.Codegen (
  69   tsn_codegen_config,
  70   tsn_db_field_namer ) -- Used in a test
  71 import TSN.Database ( insert_or_select )
  72 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  73 import TSN.Location ( Location(..), pickle_location )
  74 import TSN.Picklers ( xp_time_stamp )
  75 import TSN.Team ( Team(..) )
  76 import TSN.XmlImport ( XmlImport(..) )
  77 import Xml (
  78   FromXml(..),
  79   ToDb(..),
  80   pickle_unpickle,
  81   unpickleable,
  82   unsafe_read_document,
  83   unsafe_unpickle )
  84
  85
  86 -- | The DTD to which this module corresponds. Used to invoke dbimport.
  87 --
  88 dtd :: String
  89 dtd = "newsxml.dtd"
  90
  91
  92 --
  93 -- DB/XML Data types
  94 --
  95
  96 -- * News/Message
  97
  98 -- | The msg_id child of \<message\> contains an event_id attribute; we
  99 --   embed it into the 'News' type. We (pointlessly) use the \"db_\"
 100 --   prefix here so that the two names don't collide on \"id\" when
 101 --   Groundhog is creating its fields using our field namer.
 102 --
 103 data MsgId =
 104   MsgId {
 105     db_msg_id       :: Int,
 106     db_event_id     :: Maybe Int }
 107   deriving (Data, Eq, Show, Typeable)
 108
 109
 110 -- | The XML representation of a news item (\<message\>).
 111 --
 112 data Message =
 113   Message {
 114     xml_xml_file_id :: Int,
 115     xml_heading :: String,
 116     xml_mid :: MsgId,
 117     xml_category :: String,
 118     xml_sport :: String,
 119     xml_url :: Maybe String,
 120     xml_teams :: [NewsTeamXml],
 121     xml_locations :: [Location],
 122     xml_sms :: Maybe String,
 123     xml_editor :: Maybe String,
 124     xml_text :: Maybe String,     -- Text and continue seem to show up in pairs,
 125     xml_continue :: Maybe String, -- either both present or both missing.
 126     xml_time_stamp :: UTCTime }
 127   deriving (Eq, Show)
 128
 129
 130 -- | The database representation of a news item. We drop several
 131 --   uninteresting fields from 'Message', and omit the list fields which
 132 --   will be represented as join tables.
 133 --
 134 data News =
 135   News {
 136     db_xml_file_id :: Int,
 137     db_mid :: MsgId,
 138     db_sport :: String,
 139     db_url :: Maybe String,
 140     db_sms :: Maybe String,
 141     db_editor :: Maybe String,
 142     db_text :: Maybe String,
 143     db_continue :: Maybe String,
 144     db_time_stamp :: UTCTime }
 145   deriving (Data, Eq, Show, Typeable)
 146
 147
 148
 149 instance ToDb Message where
 150   -- | The database representation of 'Message' is 'News'.
 151   type Db Message = News
 152
 153 -- | Convert the XML representation 'Message' to the database
 154 --   representation 'News'.
 155 --
 156 instance FromXml Message where
 157   -- | We use a record wildcard so GHC doesn't complain that we never
 158   --   used the field names.
 159   --
 160   from_xml Message{..} = News { db_xml_file_id = xml_xml_file_id,
 161                                 db_mid = xml_mid,
 162                                 db_sport = xml_sport,
 163                                 db_url = xml_url,
 164                                 db_sms = xml_sms,
 165                                 db_editor = xml_editor,
 166                                 db_text = xml_text,
 167                                 db_continue = xml_continue,
 168                                 db_time_stamp = xml_time_stamp }
 169
 170 -- | This lets us insert the XML representation 'Message' directly.
 171 --
 172 instance XmlImport Message
 173
 174
 175 -- * NewsTeamXml
 176
 177 -- | The XML type for teams as they show up in the news. We can't
 178 --   reuse the representation from "TSN.Team" because our name doesn't
 179 --   appear optional and we have no abbreviation.
 180 --
 181 data NewsTeamXml =
 182   NewsTeamXml { xml_team_id :: String,
 183                 xml_team_name :: String }
 184   deriving (Eq, Show)
 185
 186 instance ToDb NewsTeamXml where
 187   -- | The database representation of 'NewsTeamXml' is 'Team'.
 188   type Db NewsTeamXml = Team
 189
 190 -- | Convert the XML representation 'NewsTeamXml' to the database
 191 --   representation 'Team'.
 192 --
 193 instance FromXml NewsTeamXml where
 194   from_xml NewsTeamXml{..} =
 195     Team { team_id = xml_team_id,
 196            abbreviation = Nothing,
 197            name = Just xml_team_name }
 198
 199 -- | Allow us to import 'NewsTeamXml' directly.
 200 --
 201 instance XmlImport NewsTeamXml
 202
 203
 204 -- * News_Team
 205
 206 -- | Mapping between News records and Team records in the database. We
 207 --   don't name the fields because we don't use the names explicitly;
 208 --   that means we have to give them nice database names via
 209 --   groundhog.
 210 --
 211 data News_Team = News_Team (DefaultKey News) (DefaultKey Team)
 212
 213
 214 -- * News_Location
 215
 216 -- | Mapping between 'News' records and 'Location' records in the
 217 --   database. We don't name the fields because we don't use the names
 218 --   explicitly; that means we have to give them nice database names
 219 --   via groundhog.
 220 --
 221 data News_Location = News_Location
 222                        (DefaultKey News)
 223                        (DefaultKey Location)
 224
 225
 226
 227
 228 -- | Some newsxml documents contain two \<SMS\> elements in a row,
 229 --   violating the DTD. The second one has always been empty, but it's
 230 --   irrelevant: we can't parse these, and would like to detect them
 231 --   in order to report the fact that the busted document is
 232 --   unsupported.
 233 --
 234 --   This function detects whether two \<SMS\> elements appear in a
 235 --   row, as siblings.
 236 --
 237 has_only_single_sms :: XmlTree -> Bool
 238 has_only_single_sms xmltree =
 239     case elements of
 240     [] -> True
 241     _  -> False
 242   where
 243     parse :: XmlTree -> [XmlTree]
 244     parse = runLA $  hasName "/"
 245                   /> hasName "message"
 246                   >>> addNav
 247                   >>> descendantAxis
 248                   >>> filterAxis (hasName "SMS")
 249                   >>> followingSiblingAxis
 250                   >>> remNav
 251                   >>> hasName "SMS"
 252
 253     elements = parse xmltree
 254
 255
 256 --
 257 -- * Database code
 258 --
 259
 260 -- | Define 'dbmigrate' and 'dbimport' for 'Message's. The import is
 261 --   slightly non-generic because of our 'News_Team' and
 262 --   'News_Location' join tables.
 263 --
 264 instance DbImport Message where
 265   dbmigrate _ =
 266     run_dbmigrate $ do
 267       migrate (undefined :: Location)
 268       migrate (undefined :: News)
 269       migrate (undefined :: Team)
 270       migrate (undefined :: News_Team)
 271       migrate (undefined :: News_Location)
 272
 273   dbimport message = do
 274     -- Insert the message and acquire its primary key (unique ID)
 275     news_id <- insert_xml message
 276
 277     -- Now insert the teams. We use insert_xml_or_select because we
 278     -- know that most teams will already exist, and we want to get
 279     -- back the id for the existing team when there's a collision.
 280     team_ids <- mapM insert_xml_or_select (xml_teams message)
 281
 282     -- Now that the teams have been inserted, create
 283     -- news__team records mapping beween the two.
 284     let news_teams = map (News_Team news_id) team_ids
 285     mapM_ insert_ news_teams
 286
 287     -- Do all of that over again for the Locations.
 288     loc_ids <- mapM insert_or_select (xml_locations message)
 289     let news_news_locations = map (News_Location news_id) loc_ids
 290     mapM_ insert_ news_news_locations
 291
 292     return ImportSucceeded
 293
 294
 295
 296 -- These types have fields with e.g. db_ and xml_ prefixes, so we
 297 -- use our own codegen to peel those off before naming the columns.
 298 mkPersist tsn_codegen_config [groundhog|
 299 - entity: News
 300   constructors:
 301     - name: News
 302       uniques:
 303         - name: unique_news
 304           type: constraint
 305           # Prevent multiple imports of the same message.
 306           fields: [db_xml_file_id]
 307       fields:
 308         - name: db_mid
 309           embeddedType:
 310             - {name: msg_id, dbName: msg_id}
 311             - {name: event_id, dbName: event_id}
 312
 313 - embedded: MsgId
 314   fields:
 315     - name: db_msg_id
 316       dbName: msg_id
 317     - name: db_event_id
 318       dbName: event_id
 319
 320 - entity: News_Team
 321   dbName: news__teams
 322   constructors:
 323     - name: News_Team
 324       fields:
 325         - name: news_Team0 # Default created by mkNormalFieldName
 326           dbName: news_id
 327           reference:
 328             onDelete: cascade
 329         - name: news_Team1 # Default created by mkNormalFieldName
 330           dbName: teams_id
 331           reference:
 332             onDelete: cascade
 333
 334 - entity: News_Location
 335   dbName: news__locations
 336   constructors:
 337     - name: News_Location
 338       fields:
 339         - name: news_Location0 # Default created by mkNormalFieldName
 340           dbName: news_id
 341           reference:
 342             onDelete: cascade
 343         - name: news_Location1 # Default created by mkNormalFieldName
 344           dbName: locations_id
 345           reference:
 346             onDelete: cascade
 347 |]
 348
 349
 350 --
 351 -- XML Picklers
 352 --
 353
 354 -- | Convert a 'NewsTeamXml' to/from XML.
 355 --
 356 pickle_news_team :: PU NewsTeamXml
 357 pickle_news_team =
 358   xpElem "team" $
 359     xpWrap (from_pair, to_pair) $
 360       xpPair (xpAttr "id" xpText)
 361              xpText -- team name
 362   where
 363     from_pair :: (String, String) -> NewsTeamXml
 364     from_pair = uncurry NewsTeamXml
 365
 366     to_pair :: NewsTeamXml -> (String, String)
 367     to_pair (NewsTeamXml x y) = (x,y)
 368
 369
 370 -- | Convert a 'MsgId' to/from XML.
 371 --
 372 pickle_msg_id :: PU MsgId
 373 pickle_msg_id =
 374   xpElem "msg_id" $
 375     xpWrap (from_tuple, to_tuple) $
 376     xpPair xpInt (xpAttr "EventId" (xpOption xpInt))
 377   where
 378     from_tuple = uncurryN MsgId
 379     to_tuple m = (db_msg_id m, db_event_id m)
 380
 381
 382
 383 -- | Convert a 'Message' to/from XML.
 384 --
 385 pickle_message :: PU Message
 386 pickle_message =
 387   xpElem "message" $
 388     xpWrap (from_tuple, to_tuple) $
 389     xp13Tuple (xpElem "XML_File_ID" xpInt)
 390               (xpElem "heading" xpText)
 391               pickle_msg_id
 392               (xpElem "category" xpText)
 393               (xpElem "sport" xpText)
 394               (xpElem "url" $ xpOption xpText)
 395               (xpList pickle_news_team)
 396               (xpList pickle_location)
 397               (xpElem "SMS" $ xpOption xpText)
 398               (xpOption (xpElem "Editor" xpText))
 399               (xpOption (xpElem "text" xpText))
 400               pickle_continue
 401               (xpElem "time_stamp" xp_time_stamp)
 402   where
 403     from_tuple = uncurryN Message
 404     to_tuple m = (xml_xml_file_id m, -- Verbose,
 405                   xml_heading m,     -- but
 406                   xml_mid m,         -- eliminates
 407                   xml_category m,    -- GHC
 408                   xml_sport m,       -- warnings
 409                   xml_url m,         -- .
 410                   xml_teams m,       -- .
 411                   xml_locations m,   -- .
 412                   xml_sms m,
 413                   xml_editor m,
 414                   xml_text m,
 415                   xml_continue m,
 416                   xml_time_stamp m)
 417
 418     -- | We combine all of the \<continue\> elements into one 'String'
 419     --   while unpickling and do the reverse while pickling.
 420     --
 421     pickle_continue :: PU (Maybe String)
 422     pickle_continue =
 423       xpOption $
 424         xpWrap (to_string, from_string) $
 425           xpElem "continue" $
 426             xpList (xpElem "P" xpText)
 427       where
 428         from_string :: String -> [String]
 429         from_string = split "\n"
 430
 431         to_string :: [String] -> String
 432         to_string = join "\n"
 433
 434
 435 --
 436 -- Tasty Tests
 437 --
 438
 439 -- | A list of all tests for this module.
 440 --
 441 news_tests :: TestTree
 442 news_tests =
 443   testGroup
 444     "News tests"
 445     [ test_news_fields_have_correct_names,
 446       test_on_delete_cascade,
 447       test_pickle_of_unpickle_is_identity,
 448       test_unpickle_succeeds,
 449       test_sms_detected_correctly ]
 450
 451
 452 -- | Make sure our codegen is producing the correct database names.
 453 --
 454 test_news_fields_have_correct_names :: TestTree
 455 test_news_fields_have_correct_names =
 456   testCase "news fields get correct database names" $
 457     mapM_ check (zip actual expected)
 458   where
 459     -- This is cool, it uses the (derived) Data instance of
 460     -- News.News to get its constructor names.
 461     field_names :: [String]
 462     field_names =
 463       constrFields . head $ dataTypeConstrs $ dataTypeOf (undefined :: News)
 464
 465     expected :: [String]
 466     expected =
 467       map (\x -> tsn_db_field_namer "herp" "derp" 8675309 x 90210) field_names
 468
 469     actual :: [String]
 470     actual = ["xml_file_id",
 471               "mid",
 472               "sport",
 473               "url",
 474               "sms",
 475               "editor",
 476               "text",
 477               "continue"]
 478
 479     check (x,y) = (x @?= y)
 480
 481
 482 -- | If we unpickle something and then pickle it, we should wind up
 483 --   with the same thing we started with. WARNING: success of this
 484 --   test does not mean that unpickling succeeded.
 485 --
 486 test_pickle_of_unpickle_is_identity :: TestTree
 487 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 488   [ check "pickle composed with unpickle is the identity"
 489           "test/xml/newsxml.xml",
 490
 491     check "pickle composed with unpickle is the identity (with Editor)"
 492           "test/xml/newsxml-with-editor.xml",
 493
 494     check "pickle composed with unpickle is the identity (empty SMS)"
 495           "test/xml/newsxml-empty-sms.xml" ]
 496   where
 497     check desc path = testCase desc $ do
 498       (expected, actual) <- pickle_unpickle pickle_message path
 499       actual @?= expected
 500
 501
 502 -- | Make sure we can actually unpickle these things.
 503 --
 504 test_unpickle_succeeds :: TestTree
 505 test_unpickle_succeeds = testGroup "unpickle tests"
 506   [ check "unpickling succeeds"
 507           "test/xml/newsxml.xml",
 508
 509     check "unpickling succeeds (with Editor)"
 510           "test/xml/newsxml-with-editor.xml",
 511
 512     check "unpickling succeeds (empty SMS)"
 513           "test/xml/newsxml-empty-sms.xml" ]
 514   where
 515     check desc path = testCase desc $ do
 516       actual <- unpickleable path pickle_message
 517       let expected = True
 518       actual @?= expected
 519
 520
 521 -- | Make sure everything gets deleted when we delete the top-level
 522 --   record.
 523 --
 524 test_on_delete_cascade :: TestTree
 525 test_on_delete_cascade = testGroup "cascading delete tests"
 526   [ check "deleting news deletes its children"
 527           "test/xml/newsxml.xml"
 528           4 -- 2 news_teams and 2 news_locations that should remain.
 529     ,
 530     check "deleting news deletes its children (empty SMS)"
 531           "test/xml/newsxml-empty-sms.xml"
 532           4 -- 2 news_teams and 2 news_locations
 533   ]
 534   where
 535     check desc path expected = testCase desc $ do
 536       news <- unsafe_unpickle path pickle_message
 537       let a = undefined :: Location
 538       let b = undefined :: News
 539       let c = undefined :: Team
 540       let d = undefined :: News_Team
 541       let e = undefined :: News_Location
 542       actual <- withSqliteConn ":memory:" $ runDbConn $ do
 543                   runMigration silentMigrationLogger $ do
 544                     migrate a
 545                     migrate b
 546                     migrate c
 547                     migrate d
 548                     migrate e
 549                   _ <- dbimport news
 550                   deleteAll b
 551                   count_a <- countAll a
 552                   count_b <- countAll b
 553                   count_c <- countAll c
 554                   count_d <- countAll d
 555                   count_e <- countAll e
 556                   return $ count_a + count_b + count_c + count_d + count_e
 557       actual @?= expected
 558
 559
 560 -- | We want to make sure the single-SMS documents and the multi-SMS
 561 --   documents are identified correctly.
 562 --
 563 test_sms_detected_correctly :: TestTree
 564 test_sms_detected_correctly =
 565   testGroup "newsxml SMS count determined correctly"
 566     [ check "test/xml/newsxml.xml"
 567             "single SMS detected correctly"
 568             True,
 569       check "test/xml/newsxml-multiple-sms.xml"
 570             "multiple SMS detected correctly"
 571             False ]
 572   where
 573     check path desc expected = testCase desc $ do
 574       xmltree <- unsafe_read_document path
 575       let actual = has_only_single_sms xmltree
 576       actual @?= expected