src/TSN/XML/News.hs

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