src/TSN/XML/News.hs

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