src/TSN/XML/News.hs

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