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