News.hs

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