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