1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE QuasiQuotes #-}
5 {-# LANGUAGE RecordWildCards #-}
6 {-# LANGUAGE ScopedTypeVariables #-}
7 {-# LANGUAGE StandaloneDeriving #-}
8 {-# LANGUAGE TemplateHaskell #-}
9 {-# LANGUAGE TypeFamilies #-}
11 -- | Parse TSN XML for the DTD "newsxml.dtd". Each document contains a
12 -- root element \<message\> that contains an entire news item.
19 import Data.Data ( Data, constrFields, dataTypeConstrs, dataTypeOf )
20 import Data.List.Utils ( join, split )
21 import Data.Tuple.Curry ( uncurryN )
22 import Data.Typeable ( Typeable )
23 import Database.Groundhog (
24 defaultMigrationLogger,
29 import Database.Groundhog.Core ( DefaultKey )
30 import Database.Groundhog.TH (
34 import System.Console.CmdArgs.Default ( Default(..) )
35 import Test.Tasty ( TestTree, testGroup )
36 import Test.Tasty.HUnit ( (@?=), testCase )
37 import Text.XML.HXT.Core (
54 tsn_db_field_namer ) -- Used in a test
55 import TSN.DbImport ( DbImport(..), ImportResult(..) )
56 import Xml ( ToFromXml(..), pickle_unpickle, unpickleable )
60 -- | The database type for teams as they show up in the news.
62 NewsTeam { team_name :: String }
65 -- | Mapping between News records and NewsTeam records in the
66 -- database. We name the fields (even though they're never used) for
67 -- Groundhog's benefit.
70 nnt_news_id :: DefaultKey News,
71 nnt_news_team_id :: DefaultKey NewsTeam }
73 -- | The database type for locations as they show up in the news.
77 state :: Maybe String,
81 -- | Mapping between News records and NewsLocation records in the
82 -- database. We name the fields (even though they're never used) for
83 -- Groundhog's benefit.
84 data News_NewsLocation =
86 nnl_news_id :: DefaultKey News,
87 nnl_news_location_id :: DefaultKey NewsLocation }
90 -- | The msg_id child of <message> contains an event_id attribute; we
91 -- embed it into the 'News' type. We (pointlessly) use the "db_"
92 -- prefix here so that the two names collide on "id" when Groundhog
93 -- is creating its fields using our field namer.
97 db_event_id :: Maybe Int }
98 deriving (Data, Eq, Show, Typeable)
103 xml_xml_file_id :: Int,
104 xml_heading :: String,
106 xml_category :: String,
109 xml_teams :: [NewsTeam],
110 xml_locations :: [NewsLocation],
112 xml_editor :: Maybe String,
113 xml_text :: Maybe String, -- Text and continue seem to show up in pairs,
114 xml_continue :: Maybe String, -- either both present or both missing.
115 xml_time_stamp :: String }
124 db_editor :: Maybe String,
125 db_text :: Maybe String,
126 db_continue :: Maybe String }
127 deriving (Data, Eq, Show, Typeable)
129 instance ToFromXml News where
130 type Xml News = Message
131 type Container News = ()
133 -- Use a record wildcard here so GHC doesn't complain that we never
134 -- used our named fields.
151 -- We don't need the key argument (from_xml_fk) since the XML type
152 -- contains more information in this case.
153 from_xml (Message _ _ c _ e f _ _ i j k l _) =
157 -- These types don't have special XML representations or field name
158 -- collisions so we use the defaultCodegenConfig and give their fields
159 -- nice simple names.
160 mkPersist defaultCodegenConfig [groundhog|
166 - name: unique_news_team
170 - entity: NewsLocation
171 dbName: news_locations
175 - name: unique_news_location
177 fields: [city, state, country]
181 mkPersist tsn_codegen_config [groundhog|
189 - {name: msg_id, dbName: msg_id}
190 - {name: event_id, dbName: event_id}
199 - entity: News_NewsTeam
200 dbName: news__news_teams
202 - entity: News_NewsLocation
203 dbName: news__news_locations
206 pickle_news_team :: PU NewsTeam
209 xpWrap (from_string, to_string) xpText
211 to_string :: NewsTeam -> String
212 to_string = team_name
214 from_string :: String -> NewsTeam
215 from_string = NewsTeam
217 instance XmlPickler NewsTeam where
218 xpickle = pickle_news_team
220 pickle_msg_id :: PU MsgId
223 xpWrap (from_tuple, to_tuple) $
224 xpPair xpInt (xpAttr "EventId" (xpOption xpInt))
226 from_tuple = uncurryN MsgId
227 to_tuple m = (db_msg_id m, db_event_id m)
229 instance XmlPickler MsgId where
230 xpickle = pickle_msg_id
232 pickle_location :: PU NewsLocation
235 xpWrap (from_tuple, to_tuple) $
236 xpTriple (xpOption (xpElem "city" xpText))
237 (xpOption (xpElem "state" xpText))
238 (xpElem "country" xpText)
241 uncurryN NewsLocation
242 to_tuple l = (city l, state l, country l)
244 instance XmlPickler NewsLocation where
245 xpickle = pickle_location
248 pickle_message :: PU Message
251 xpWrap (from_tuple, to_tuple) $
252 xp13Tuple (xpElem "XML_File_ID" xpInt)
253 (xpElem "heading" xpText)
255 (xpElem "category" xpText)
256 (xpElem "sport" xpText)
257 (xpElem "url" xpText)
258 (xpList pickle_news_team)
259 (xpList pickle_location)
260 (xpElem "SMS" xpText)
261 (xpOption (xpElem "Editor" xpText))
262 (xpOption (xpElem "text" xpText))
264 (xpElem "time_stamp" xpText)
266 from_tuple = uncurryN Message
267 to_tuple m = (xml_xml_file_id m,
281 pickle_continue :: PU (Maybe String)
284 xpWrap (to_string, from_string) $
286 xpList (xpElem "P" xpText)
288 from_string :: String -> [String]
289 from_string = split "\n"
291 to_string :: [String] -> String
292 to_string = join "\n"
294 instance XmlPickler Message where
295 xpickle = pickle_message
299 instance DbImport News where
301 runMigration defaultMigrationLogger $ do
302 migrate (undefined :: News)
303 migrate (undefined :: NewsTeam)
304 migrate (undefined :: NewsLocation)
305 migrate (undefined :: News_NewsTeam)
306 migrate (undefined :: News_NewsLocation)
307 let root_element = unpickleDoc xpickle xml :: Maybe Message
310 let errmsg = "Could not unpickle News message in dbimport."
311 return $ ImportFailed errmsg
313 -- Insert the message and acquire its primary key (unique ID)
314 news_id <- insert (from_xml message :: News)
316 -- And insert each one into its own table. We use insertByAll
317 -- because we know that most teams will already exist, and we
318 -- want to get back a Left (id) for the existing team when
319 -- there's a collision. In fact, if the insert succeeds, we'll
320 -- get a Right (id) back, so we can disregard the Either
321 -- constructor entirely. That's what the (either id id) does.
322 either_nt_ids <- mapM insertByAll (xml_teams message)
323 let nt_ids = map (either id id) either_nt_ids
325 -- Now that the teams have been inserted, create
326 -- news__news_team records mapping beween the two.
327 let news_news_teams = map (News_NewsTeam news_id) nt_ids
328 nnt_ids <- mapM insert news_news_teams
331 -- Do all of that over again for the NewsLocations.
332 either_loc_ids <- mapM insertByAll (xml_locations message)
333 let loc_ids = map (either id id) either_loc_ids
334 let news_news_locations = map (News_NewsLocation news_id) loc_ids
335 nnl_ids <- mapM insertByAll news_news_locations
337 return $ ImportSucceeded (1 + -- for the News
345 news_tests :: TestTree
349 [ test_news_fields_have_correct_names,
350 test_pickle_of_unpickle_is_identity,
351 test_unpickle_succeeds ]
354 test_news_fields_have_correct_names :: TestTree
355 test_news_fields_have_correct_names =
356 testCase "news fields get correct database names" $
357 mapM_ check (zip actual expected)
359 -- This is cool, it uses the (derived) Data instance of
360 -- News.News to get its constructor names.
361 field_names :: [String]
363 constrFields . head $ dataTypeConstrs $ dataTypeOf (undefined :: News)
367 map (\x -> tsn_db_field_namer "herp" "derp" 8675309 x 90210) field_names
370 actual = ["mid", "sport", "url", "sms", "editor", "text", "continue"]
372 check (x,y) = (x @?= y)
375 -- | Warning, succeess of this test does not mean that unpickling
377 test_pickle_of_unpickle_is_identity :: TestTree
378 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
379 [ check "pickle composed with unpickle is the identity"
380 "test/xml/newsxml.xml",
382 check "pickle composed with unpickle is the identity (with Editor)"
383 "test/xml/newsxml-with-editor.xml" ]
385 check desc path = testCase desc $ do
386 (expected :: [Message], actual) <- pickle_unpickle "message" path
390 test_unpickle_succeeds :: TestTree
391 test_unpickle_succeeds = testGroup "unpickle tests"
392 [ check "unpickling succeeds"
393 "test/xml/newsxml.xml",
395 check "unpickling succeeds (with Editor)"
396 "test/xml/newsxml-with-editor.xml" ]
398 check desc path = testCase desc $ do
399 actual <- unpickleable path pickle_message