1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE DeriveDataTypeable #-}
3 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE QuasiQuotes #-}
6 {-# LANGUAGE RecordWildCards #-}
7 {-# LANGUAGE ScopedTypeVariables #-}
8 {-# LANGUAGE StandaloneDeriving #-}
9 {-# LANGUAGE TemplateHaskell #-}
10 {-# LANGUAGE TypeFamilies #-}
12 -- | Parse TSN XML for the DTD "newsxml.dtd". Each document contains a
13 -- root element \<message\> that contains an entire news item.
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,
29 import Database.Groundhog.Core ( DefaultKey )
30 import Database.Groundhog.TH (
33 import System.Console.CmdArgs.Default ( Default(..) )
34 import Test.Tasty ( TestTree, testGroup )
35 import Test.Tasty.HUnit ( (@?=), testCase )
36 import Text.XML.HXT.Core (
53 tsn_db_field_namer ) -- Used in a test
54 import TSN.DbImport ( DbImport(..), ImportResult(..) )
55 import Xml ( ToFromXml(..), pickle_unpickle, unpickleable )
59 -- | The database type for teams as they show up in the news. We need
60 -- this separate from its XML representation because of the
61 -- DefaultKey pointing to a message. We don't know how to create one
62 -- of those unless we've just inserted a message into the database,
63 -- so it screws up pickling.
66 nt_news_id :: DefaultKey Message, -- ^ foreign key.
67 db_team_name :: String }
68 deriving instance Eq NewsTeam -- Standalone instances necessary for
69 deriving instance Show NewsTeam -- Groundhog types with DefaultKeys
71 -- | The XML type for teams as they show up in the news. See
72 -- 'NewsTeam' for why there are two types.
75 xml_team_name :: String }
78 -- | Specify how to convert between the two representations NewsTeam
79 -- (database) and NewsTeamXml (XML).
80 instance ToFromXml NewsTeam where
81 type Xml NewsTeam = NewsTeamXml
82 type Container NewsTeam = Message
83 -- Use a record wildcard here so GHC doesn't complain that we never
84 -- used our named fields.
85 to_xml (NewsTeam {..}) = NewsTeamXml db_team_name
86 -- We can't create a DefaultKey Message...
87 from_xml = error "Called from_xml on a NewsTeam."
88 -- unless we're handed one.
89 from_xml_fk key = (NewsTeam key) . xml_team_name
92 -- | The database type for locations as they show up in the news. We
93 -- need this separate from its XML representation because of the
94 -- DefaultKey pointing to a message. We don't know how to create one
95 -- of those unless we've just inserted a message into the database,
96 -- so it screws up pickling.
99 loc_news_id :: DefaultKey Message, -- ^ foreign key.
102 db_country :: String }
103 deriving instance Eq NewsLocation -- Standalone instances necessary for
104 deriving instance Show NewsLocation -- Groundhog types with DefaultKeys
106 -- | The XML type for locations as they show up in the news. See
107 -- 'NewsLocation' for why there are two types.
108 data NewsLocationXml =
112 xml_country :: String }
116 -- | Specify how to convert between the two representations
117 -- NewsLocation (database) and NewsLocationXml (XML).
118 instance ToFromXml NewsLocation where
119 type Xml NewsLocation = NewsLocationXml
120 type Container NewsLocation = Message
121 -- Use a record wildcard here so GHC doesn't complain that we never
122 -- used our named fields.
123 to_xml (NewsLocation {..}) = NewsLocationXml db_city db_state db_country
124 -- We can't create a DefaultKey Message...
125 from_xml = error "Called from_xml on a NewsLocation."
126 -- unless we're given one.
127 from_xml_fk key (NewsLocationXml x y z) = NewsLocation key x y z
130 -- | The msg_id child of <message> contains an event_id attribute; we
131 -- embed it into the 'Message' type. We (pointlessly) use the "db_"
132 -- prefix here so that the two names collide on "id" when Groundhog
133 -- is creating its fields using our field namer.
137 db_event_id :: Maybe Int }
138 deriving (Data, Eq, Show, Typeable)
143 xml_xml_file_id :: Int,
144 xml_heading :: String,
146 xml_category :: String,
149 xml_teams :: [NewsTeamXml],
150 xml_locations :: [NewsLocationXml],
152 xml_editor :: Maybe String,
154 xml_continue :: String,
155 xml_time_stamp :: String }
164 db_editor :: Maybe String,
166 db_continue :: String }
167 deriving (Data, Eq, Show, Typeable)
169 instance ToFromXml Message where
170 type Xml Message = MessageXml
171 type Container Message = ()
173 -- Use a record wildcard here so GHC doesn't complain that we never
174 -- used our named fields.
175 to_xml (Message {..}) =
191 -- We don't need the key argument (from_xml_fk) since the XML type
192 -- contains more information in this case.
193 from_xml (MessageXml _ _ c _ e f _ _ i j k l _) =
194 Message c e f i j k l
197 mkPersist tsn_codegen_config [groundhog|
201 - entity: NewsLocation
202 dbName: news_locations
211 - {name: msg_id, dbName: msg_id}
212 - {name: event_id, dbName: event_id}
221 pickle_news_team :: PU NewsTeamXml
224 xpWrap (from_string, to_string) xpText
226 to_string :: NewsTeamXml -> String
227 to_string = xml_team_name
229 from_string :: String -> NewsTeamXml
230 from_string = NewsTeamXml
232 instance XmlPickler NewsTeamXml where
233 xpickle = pickle_news_team
235 pickle_msg_id :: PU MsgId
238 xpWrap (from_tuple, to_tuple) $
239 xpPair xpInt (xpAttr "EventId" (xpOption xpInt))
241 from_tuple = uncurryN MsgId
242 to_tuple m = (db_msg_id m, db_event_id m)
244 instance XmlPickler MsgId where
245 xpickle = pickle_msg_id
247 pickle_location :: PU NewsLocationXml
250 xpWrap (from_tuple, to_tuple) $
251 xpTriple (xpElem "city" xpText)
252 (xpElem "state" xpText)
253 (xpElem "country" xpText)
256 uncurryN NewsLocationXml
257 to_tuple l = (xml_city l, xml_state l, xml_country l)
259 instance XmlPickler NewsLocationXml where
260 xpickle = pickle_location
263 pickle_message :: PU MessageXml
266 xpWrap (from_tuple, to_tuple) $
267 xp13Tuple (xpElem "XML_File_ID" xpInt)
268 (xpElem "heading" xpText)
270 (xpElem "category" xpText)
271 (xpElem "sport" xpText)
272 (xpElem "url" xpText)
273 (xpList pickle_news_team)
274 (xpList pickle_location)
275 (xpElem "SMS" xpText)
276 (xpOption (xpElem "Editor" xpText))
277 (xpElem "text" xpText)
279 (xpElem "time_stamp" xpText)
281 from_tuple = uncurryN MessageXml
282 to_tuple m = (xml_xml_file_id m,
296 pickle_continue :: PU String
298 xpWrap (to_string, from_string) $
300 xpList (xpElem "P" xpText)
302 from_string :: String -> [String]
303 from_string = split "\n"
305 to_string :: [String] -> String
306 to_string = join "\n"
308 instance XmlPickler MessageXml where
309 xpickle = pickle_message
313 instance DbImport Message where
315 runMigration defaultMigrationLogger $ do
316 migrate (undefined :: Message)
317 migrate (undefined :: NewsTeam)
318 migrate (undefined :: NewsLocation)
319 let root_element = unpickleDoc xpickle xml :: Maybe MessageXml
322 let errmsg = "Could not unpickle News message in dbimport."
323 return $ ImportFailed errmsg
325 news_id <- insert (from_xml message :: Message)
326 let nts :: [NewsTeam] = map (from_xml_fk news_id)
328 let nlocs :: [NewsLocation] = map (from_xml_fk news_id)
329 (xml_locations message)
330 nt_ids <- mapM insert nts
331 loc_ids <- mapM insert nlocs
333 return $ ImportSucceeded (1 + (length nt_ids) + (length loc_ids))
337 news_tests :: TestTree
341 [ test_news_fields_have_correct_names,
342 test_pickle_of_unpickle_is_identity,
343 test_unpickle_succeeds ]
346 test_news_fields_have_correct_names :: TestTree
347 test_news_fields_have_correct_names =
348 testCase "news fields get correct database names" $
349 mapM_ check (zip actual expected)
351 -- This is cool, it uses the (derived) Data instance of
352 -- News.Message to get its constructor names.
353 field_names :: [String]
355 constrFields . head $ dataTypeConstrs $ dataTypeOf (undefined :: Message)
359 map (\x -> tsn_db_field_namer "herp" "derp" 8675309 x 90210) field_names
362 actual = ["mid", "sport", "url", "sms", "editor", "text", "continue"]
364 check (x,y) = (x @?= y)
367 -- | Warning, succeess of this test does not mean that unpickling
369 test_pickle_of_unpickle_is_identity :: TestTree
370 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
371 [ check "pickle composed with unpickle is the identity"
372 "test/xml/newsxml.xml",
374 check "pickle composed with unpickle is the identity (with Editor)"
375 "test/xml/newsxml-with-editor.xml" ]
377 check desc path = testCase desc $ do
378 (expected :: [MessageXml], actual) <- pickle_unpickle "message" path
382 test_unpickle_succeeds :: TestTree
383 test_unpickle_succeeds = testGroup "unpickle tests"
384 [ check "unpickling succeeds"
385 "test/xml/newsxml.xml",
387 check "unpickling succeeds (with Editor)"
388 "test/xml/newsxml-with-editor.xml" ]
390 check desc path = testCase desc $ do
391 actual <- unpickleable path pickle_message