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