src/TSN/XML/News.hs

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