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