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   news_tests,
  15   pickle_message )
  16 where
  17
  18 import Data.Data ( Data, constrFields, dataTypeConstrs, dataTypeOf )
  19 import Data.List.Utils ( join, split )
  20 import Data.Tuple.Curry ( uncurryN )
  21 import Data.Typeable ( Typeable )
  22 import Database.Groundhog (
  23   insert_,
  24   migrate )
  25 import Database.Groundhog.Core ( DefaultKey )
  26 import Database.Groundhog.TH (
  27   defaultCodegenConfig,
  28   groundhog,
  29   mkPersist )
  30 import Test.Tasty ( TestTree, testGroup )
  31 import Test.Tasty.HUnit ( (@?=), testCase )
  32 import Text.XML.HXT.Core (
  33   PU,
  34   xp13Tuple,
  35   xpAttr,
  36   xpElem,
  37   xpInt,
  38   xpList,
  39   xpOption,
  40   xpPair,
  41   xpText,
  42   xpText0,
  43   xpTriple,
  44   xpWrap )
  45
  46 import TSN.Codegen (
  47   tsn_codegen_config,
  48   tsn_db_field_namer ) -- Used in a test
  49 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  50 import TSN.XmlImport ( XmlImport(..) )
  51 import Xml ( FromXml(..), pickle_unpickle, unpickleable )
  52
  53
  54
  55 -- | The database type for teams as they show up in the news.
  56 data NewsTeam =
  57   NewsTeam { team_name :: String }
  58   deriving (Eq, Show)
  59
  60 instance FromXml NewsTeam where
  61   type Db NewsTeam = NewsTeam
  62   from_xml = id
  63
  64 instance XmlImport NewsTeam
  65
  66
  67 -- | Mapping between News records and NewsTeam records in the
  68 --   database. We name the fields (even though they're never used) for
  69 --   Groundhog's benefit.
  70 data News_NewsTeam =
  71   News_NewsTeam {
  72     nnt_news_id :: DefaultKey News,
  73     nnt_news_team_id :: DefaultKey NewsTeam }
  74
  75 -- | The database type for locations as they show up in the news.
  76 data NewsLocation =
  77   NewsLocation {
  78     city :: Maybe String,
  79     state :: Maybe String,
  80     country :: String }
  81   deriving (Eq, Show)
  82
  83 instance FromXml NewsLocation where
  84   type Db NewsLocation = NewsLocation
  85   from_xml = id
  86
  87 instance XmlImport NewsLocation
  88
  89
  90 -- | Mapping between News records and NewsLocation records in the
  91 --   database. We name the fields (even though they're never used) for
  92 --   Groundhog's benefit.
  93 data News_NewsLocation =
  94   News_NewsLocation {
  95     nnl_news_id :: DefaultKey News,
  96     nnl_news_location_id :: DefaultKey NewsLocation }
  97
  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 collide on "id" when Groundhog
 102 --   is creating its fields using our field namer.
 103 data MsgId =
 104   MsgId {
 105     db_msg_id       :: Int,
 106     db_event_id     :: Maybe Int }
 107   deriving (Data, Eq, Show, Typeable)
 108
 109
 110 data Message =
 111   Message {
 112     xml_xml_file_id :: Int,
 113     xml_heading :: String,
 114     xml_mid :: MsgId,
 115     xml_category :: String,
 116     xml_sport :: String,
 117     xml_url :: String,
 118     xml_teams :: [NewsTeam],
 119     xml_locations :: [NewsLocation],
 120     xml_sms :: String,
 121     xml_editor :: Maybe String,
 122     xml_text :: Maybe String,     -- Text and continue seem to show up in pairs,
 123     xml_continue :: Maybe String, -- either both present or both missing.
 124     xml_time_stamp :: String }
 125   deriving (Eq, Show)
 126
 127 data News =
 128   News {
 129     db_mid :: MsgId,
 130     db_sport :: String,
 131     db_url :: String,
 132     db_sms :: String,
 133     db_editor :: Maybe String,
 134     db_text :: Maybe String,
 135     db_continue :: Maybe String }
 136   deriving (Data, Eq, Show, Typeable)
 137
 138 instance FromXml Message where
 139   type Db Message = News
 140
 141   -- We don't need the key argument (from_xml_fk) since the XML type
 142   -- contains more information in this case.
 143   from_xml (Message _ _ c _ e f _ _ i j k l _) =
 144     News c e f i j k l
 145
 146 instance XmlImport Message
 147
 148 instance DbImport Message where
 149   dbmigrate _ =
 150     run_dbmigrate $ do
 151       migrate (undefined :: NewsTeam)
 152       migrate (undefined :: NewsLocation)
 153       migrate (undefined :: News)
 154       migrate (undefined :: News_NewsTeam)
 155       migrate (undefined :: News_NewsLocation)
 156
 157   dbimport message = do
 158     -- Insert the message and acquire its primary key (unique ID)
 159     news_id <- insert_xml message
 160
 161     -- And insert each one into its own table. We use insert_xml_or_select
 162     -- because we know that most teams will already exist, and we
 163     -- want to get back the id for the existing team when
 164     -- there's a collision.
 165     nt_ids <- mapM insert_xml_or_select (xml_teams message)
 166
 167     -- Now that the teams have been inserted, create
 168     -- news__news_team records mapping beween the two.
 169     let news_news_teams = map (News_NewsTeam news_id) nt_ids
 170     mapM_ insert_ news_news_teams
 171
 172     -- Do all of that over again for the NewsLocations.
 173     loc_ids <- mapM insert_xml_or_select (xml_locations message)
 174     let news_news_locations = map (News_NewsLocation news_id) loc_ids
 175     mapM_ insert_ news_news_locations
 176
 177     return ImportSucceeded
 178
 179
 180 -- These types don't have special XML representations or field name
 181 -- collisions so we use the defaultCodegenConfig and give their fields
 182 -- nice simple names.
 183 mkPersist defaultCodegenConfig [groundhog|
 184 - entity: NewsTeam
 185   dbName: news_teams
 186   constructors:
 187     - name: NewsTeam
 188       uniques:
 189         - name: unique_news_team
 190           type: constraint
 191           fields: [team_name]
 192
 193 - entity: NewsLocation
 194   dbName: news_locations
 195   constructors:
 196     - name: NewsLocation
 197       uniques:
 198         - name: unique_news_location
 199           type: constraint
 200           fields: [city, state, country]
 201
 202 |]
 203
 204 mkPersist tsn_codegen_config [groundhog|
 205 - entity: News
 206   dbName: news
 207   constructors:
 208     - name: News
 209       fields:
 210         - name: db_mid
 211           embeddedType:
 212             - {name: msg_id, dbName: msg_id}
 213             - {name: event_id, dbName: event_id}
 214 - embedded: MsgId
 215   fields:
 216     - name: db_msg_id
 217       dbName: msg_id
 218     - name: db_event_id
 219       dbName: event_id
 220
 221
 222 - entity: News_NewsTeam
 223   dbName: news__news_teams
 224
 225 - entity: News_NewsLocation
 226   dbName: news__news_locations
 227 |]
 228
 229 pickle_news_team :: PU NewsTeam
 230 pickle_news_team =
 231   xpElem "team" $
 232     xpWrap (from_string, to_string) xpText
 233   where
 234     to_string :: NewsTeam -> String
 235     to_string = team_name
 236
 237     from_string :: String -> NewsTeam
 238     from_string = NewsTeam
 239
 240
 241 pickle_msg_id :: PU MsgId
 242 pickle_msg_id =
 243   xpElem "msg_id" $
 244     xpWrap (from_tuple, to_tuple) $
 245     xpPair xpInt (xpAttr "EventId" (xpOption xpInt))
 246   where
 247     from_tuple = uncurryN MsgId
 248     to_tuple m = (db_msg_id m, db_event_id m)
 249
 250
 251 pickle_location :: PU NewsLocation
 252 pickle_location =
 253   xpElem "location" $
 254     xpWrap (from_tuple, to_tuple) $
 255     xpTriple (xpOption (xpElem "city" xpText))
 256              (xpOption (xpElem "state" xpText))
 257              (xpElem "country" xpText)
 258   where
 259     from_tuple =
 260       uncurryN NewsLocation
 261     to_tuple l = (city l, state l, country l)
 262
 263
 264
 265 pickle_message :: PU Message
 266 pickle_message =
 267   xpElem "message" $
 268     xpWrap (from_tuple, to_tuple) $
 269     xp13Tuple (xpElem "XML_File_ID" xpInt)
 270               (xpElem "heading" xpText)
 271               pickle_msg_id
 272               (xpElem "category" xpText)
 273               (xpElem "sport" xpText)
 274               (xpElem "url" xpText0)
 275               (xpList pickle_news_team)
 276               (xpList pickle_location)
 277               (xpElem "SMS" xpText)
 278               (xpOption (xpElem "Editor" xpText))
 279               (xpOption (xpElem "text" xpText))
 280               pickle_continue
 281               (xpElem "time_stamp" xpText)
 282   where
 283     from_tuple = uncurryN Message
 284     to_tuple m = (xml_xml_file_id m,
 285                   xml_heading m,
 286                   xml_mid m,
 287                   xml_category m,
 288                   xml_sport m,
 289                   xml_url m,
 290                   xml_teams m,
 291                   xml_locations m,
 292                   xml_sms m,
 293                   xml_editor m,
 294                   xml_text m,
 295                   xml_continue m,
 296                   xml_time_stamp m)
 297
 298     pickle_continue :: PU (Maybe String)
 299     pickle_continue =
 300       xpOption $
 301         xpWrap (to_string, from_string) $
 302           xpElem "continue" $
 303             xpList (xpElem "P" xpText)
 304       where
 305         from_string :: String -> [String]
 306         from_string = split "\n"
 307
 308         to_string :: [String] -> String
 309         to_string = join "\n"
 310
 311
 312
 313 -- * Tasty Tests
 314 news_tests :: TestTree
 315 news_tests =
 316   testGroup
 317     "News tests"
 318     [ test_news_fields_have_correct_names,
 319       test_pickle_of_unpickle_is_identity,
 320       test_unpickle_succeeds ]
 321
 322
 323 test_news_fields_have_correct_names :: TestTree
 324 test_news_fields_have_correct_names =
 325   testCase "news fields get correct database names" $
 326     mapM_ check (zip actual expected)
 327   where
 328     -- This is cool, it uses the (derived) Data instance of
 329     -- News.News to get its constructor names.
 330     field_names :: [String]
 331     field_names =
 332       constrFields . head $ dataTypeConstrs $ dataTypeOf (undefined :: News)
 333
 334     expected :: [String]
 335     expected =
 336       map (\x -> tsn_db_field_namer "herp" "derp" 8675309 x 90210) field_names
 337
 338     actual :: [String]
 339     actual = ["mid", "sport", "url", "sms", "editor", "text", "continue"]
 340
 341     check (x,y) = (x @?= y)
 342
 343
 344 -- | Warning, succeess of this test does not mean that unpickling
 345 --   succeeded.
 346 test_pickle_of_unpickle_is_identity :: TestTree
 347 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 348   [ check "pickle composed with unpickle is the identity"
 349           "test/xml/newsxml.xml",
 350
 351     check "pickle composed with unpickle is the identity (with Editor)"
 352           "test/xml/newsxml-with-editor.xml" ]
 353   where
 354     check desc path = testCase desc $ do
 355       (expected, actual) <- pickle_unpickle pickle_message path
 356       actual @?= expected
 357
 358
 359 test_unpickle_succeeds :: TestTree
 360 test_unpickle_succeeds = testGroup "unpickle tests"
 361   [ check "unpickling succeeds"
 362           "test/xml/newsxml.xml",
 363
 364     check "unpickling succeeds (with Editor)"
 365           "test/xml/newsxml-with-editor.xml" ]
 366   where
 367     check desc path = testCase desc $ do
 368       actual <- unpickleable path pickle_message
 369       let expected = True
 370       actual @?= expected