src/TSN/News.hs

   1 {-# LANGUAGE BangPatterns #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE QuasiQuotes #-}
   5 {-# LANGUAGE ScopedTypeVariables #-}
   6 {-# LANGUAGE StandaloneDeriving #-}
   7 {-# LANGUAGE TemplateHaskell #-}
   8 {-# LANGUAGE TypeFamilies #-}
   9
  10 -- | Parse TSN XML for the DTD "newsxml.dtd". Each document contains a
  11 --   root element \<message\> that contains an entire news item.
  12 --
  13 module TSN.News (
  14   Message,
  15   news_tests )
  16 where
  17
  18 import Control.Monad.IO.Class ( MonadIO, liftIO )
  19 import Data.Int ( Int64 )
  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, PersistBackend )
  28 import Database.Groundhog.TH (
  29   defaultCodegenConfig,
  30   groundhog,
  31   mkPersist )
  32 import Test.Tasty ( TestTree, testGroup )
  33 import Test.Tasty.HUnit ( (@?=), testCase )
  34 import Text.XML.HXT.Core (
  35   PU,
  36   XmlPickler(..),
  37   XmlTree,
  38   unpickleDoc,
  39   xp12Tuple,
  40   xpAttr,
  41   xpElem,
  42   xpList,
  43   xpPair,
  44   xpPrim,
  45   xpText,
  46   xpText0,
  47   xpTriple,
  48   xpWrap )
  49 import Unsafe.Coerce ( unsafeCoerce )
  50
  51 import Network.Services.TSN.Report ( report_error )
  52 import TSN.DbImport ( DbImport(..) )
  53 import Xml ( pickle_unpickle )
  54
  55
  56 -- Can't use a newtype with Groundhog.
  57 data NewsTeam =
  58   NewsTeam {
  59     nt_news_id :: Int64, -- Foreign key.
  60     team_name  :: String }
  61 deriving instance Eq NewsTeam
  62 deriving instance Show NewsTeam
  63
  64 data MsgId =
  65   MsgId {
  66     msg_id       :: Int,
  67     event_id     :: String } -- TODO: make optional
  68   deriving (Eq, Show)
  69
  70 data NewsLocation =
  71   NewsLocation {
  72     loc_news_id  :: Int64, -- Foreign key.
  73     city :: String,
  74     state :: String,
  75     country :: String }
  76 deriving instance Eq NewsLocation
  77 deriving instance Show NewsLocation
  78
  79 data Message =
  80   Message {
  81     xml_file_id :: Int,
  82     heading :: String,
  83     mid :: MsgId,
  84     category :: String,
  85     sport :: String,
  86     url :: String,
  87     teams :: [NewsTeam],
  88     locations :: [NewsLocation],
  89     sms :: String,
  90     text :: String,
  91     continue :: String,
  92     time_stamp :: String }
  93   deriving (Eq, Show)
  94
  95
  96 mkPersist defaultCodegenConfig [groundhog|
  97 - entity: NewsTeam
  98   dbName: news_teams
  99   constructors:
 100     - name: NewsTeam
 101       fields:
 102         - name: nt_news_id
 103           reference:
 104             - table: news
 105             - columns: [id]
 106
 107 - entity: NewsLocation
 108   dbName: news_locations
 109
 110 - entity: Message
 111   dbName: news
 112   constructors:
 113     - name: Message
 114       fields:
 115         - name: mid
 116           embeddedType:
 117             - {name: msg_id, dbName: msg_id}
 118             - {name: event_id, dbName: event_id}
 119
 120 - embedded: MsgId
 121   fields:
 122     - name: msg_id
 123     - name: event_id
 124 |]
 125
 126
 127 pickle_news_team :: PU NewsTeam
 128 pickle_news_team =
 129   xpElem "team" $
 130     xpWrap (from_string, to_string) xpText
 131   where
 132     to_string :: NewsTeam -> String
 133     to_string = team_name
 134
 135     from_string :: String -> NewsTeam
 136     from_string = NewsTeam 0
 137
 138 instance XmlPickler NewsTeam where
 139   xpickle = pickle_news_team
 140
 141 pickle_msg_id :: PU MsgId
 142 pickle_msg_id =
 143   xpElem "msg_id" $
 144     xpWrap (from_tuple, to_tuple) $
 145     xpPair xpPrim (xpAttr "EventId" xpText0)
 146   where
 147     from_tuple = uncurryN MsgId
 148     to_tuple m = (msg_id m, event_id m)
 149
 150 instance XmlPickler MsgId where
 151   xpickle = pickle_msg_id
 152
 153 pickle_location :: PU NewsLocation
 154 pickle_location =
 155   xpElem "location" $
 156     xpWrap (from_tuple, to_tuple) $
 157     xpTriple (xpElem "city" xpText)
 158              (xpElem "state" xpText)
 159              (xpElem "country" xpText)
 160   where
 161     from_tuple =
 162       uncurryN (NewsLocation 0)
 163     to_tuple l = (city l, state l, country l) -- Don't pickle the PK
 164
 165 instance XmlPickler NewsLocation where
 166   xpickle = pickle_location
 167
 168
 169 pickle_message :: PU Message
 170 pickle_message =
 171   xpElem "message" $
 172     xpWrap (from_tuple, to_tuple) $
 173     xp12Tuple (xpElem "XML_File_ID" xpPrim)
 174               (xpElem "heading" xpText)
 175               pickle_msg_id
 176               (xpElem "category" xpText)
 177               (xpElem "sport" xpText)
 178               (xpElem "url" xpText)
 179               (xpList $ pickle_news_team)
 180               (xpList $ pickle_location)
 181               (xpElem "SMS" xpText)
 182               (xpElem "text" xpText)
 183               pickle_continue
 184               (xpElem "time_stamp" xpText)
 185   where
 186     from_tuple = uncurryN Message
 187     to_tuple m = (xml_file_id m,
 188                   heading m,
 189                   mid m,
 190                   category m,
 191                   sport m,
 192                   url m,
 193                   teams m,
 194                   locations m,
 195                   sms m,
 196                   text m,
 197                   continue m,
 198                   time_stamp m)
 199
 200     pickle_continue :: PU String
 201     pickle_continue =
 202       xpWrap (to_string, from_string) $
 203         xpElem "continue" $
 204           (xpList $ xpElem "P" xpText)
 205       where
 206         from_string :: String -> [String]
 207         from_string = split "\n"
 208
 209         to_string :: [String] -> String
 210         to_string = join "\n"
 211
 212 instance XmlPickler Message where
 213   xpickle = pickle_message
 214
 215
 216
 217 instance DbImport Message where
 218   dbimport _ xml = do
 219     runMigration defaultMigrationLogger $ do
 220       migrate (undefined :: Message)
 221       migrate (undefined :: NewsTeam)
 222       migrate (undefined :: NewsLocation)
 223     let root_element = unpickleDoc xpickle xml
 224     case root_element of
 225       Nothing -> do
 226         let errmsg = "Could not unpickle document in import_news."
 227         liftIO $ report_error errmsg
 228         return Nothing
 229       Just message  -> do
 230         news_id <- insert message
 231
 232         let insert_news_team nt = insert (nt { nt_news_id = unsafeCoerce news_id })
 233         nt_ids <- mapM insert_news_team (teams message)
 234
 235         let insert_news_location loc = insert (loc { loc_news_id = unsafeCoerce news_id })
 236         loc_ids <- mapM insert_news_location (locations message)
 237
 238         return $ Just (1 + (length nt_ids) + (length loc_ids))
 239
 240
 241 -- * Tasty Tests
 242 news_tests :: TestTree
 243 news_tests =
 244   testGroup
 245     "News tests"
 246     [ test_pickle_of_unpickle_is_identity ]
 247
 248
 249 test_pickle_of_unpickle_is_identity :: TestTree
 250 test_pickle_of_unpickle_is_identity =
 251   testCase "pickle composed with unpickle is the identity" $ do
 252     let path = "test/xml/newsxml.xml"
 253     (expected :: [Message], actual) <- pickle_unpickle "message" path
 254     actual @?= expected