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