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