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