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