X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FNews.hs;h=78dc935ca6d3ab1e3e4947cc6a5ae0e23fbf97bb;hb=84cf25190eeb5c2059cf6b9aea47e0f2bb073188;hp=49ff8b7d655ff1c41cc2ef1423b79948e4b8731c;hpb=2069d0a786bf2c418f27574f5384eae39527d03f;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs index 49ff8b7..78dc935 100644 --- a/src/TSN/XML/News.hs +++ b/src/TSN/XML/News.hs @@ -11,11 +11,20 @@ -- root element \ that contains an entire news item. -- module TSN.XML.News ( + pickle_message, + -- * Tests news_tests, - pickle_message ) + -- * WARNING: these are private but exported to silence warnings + News_NewsLocationConstructor(..), + News_NewsTeamConstructor(..), + NewsConstructor(..), + NewsLocationConstructor(..), + NewsTeamConstructor(..) ) where +-- System imports. import Data.Data ( Data, constrFields, dataTypeConstrs, dataTypeOf ) +import Data.Time.Clock ( UTCTime ) import Data.List.Utils ( join, split ) import Data.Tuple.Curry ( uncurryN ) import Data.Typeable ( Typeable ) @@ -39,67 +48,29 @@ import Text.XML.HXT.Core ( xpOption, xpPair, xpText, - xpText0, xpTriple, xpWrap ) +-- Local imports. import TSN.Codegen ( tsn_codegen_config, tsn_db_field_namer ) -- Used in a test import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) +import TSN.Picklers ( xp_time_stamp ) import TSN.XmlImport ( XmlImport(..) ) -import Xml ( FromXml(..), pickle_unpickle, unpickleable ) +import Xml ( FromXml(..), ToDb(..), pickle_unpickle, unpickleable ) +-- +-- DB/XML Data types +-- --- | The database type for teams as they show up in the news. -data NewsTeam = - NewsTeam { team_name :: String } - deriving (Eq, Show) - -instance FromXml NewsTeam where - type Db NewsTeam = NewsTeam - from_xml = id - -instance XmlImport NewsTeam - - --- | Mapping between News records and NewsTeam records in the --- database. We name the fields (even though they're never used) for --- Groundhog's benefit. -data News_NewsTeam = - News_NewsTeam { - nnt_news_id :: DefaultKey News, - nnt_news_team_id :: DefaultKey NewsTeam } - --- | The database type for locations as they show up in the news. -data NewsLocation = - NewsLocation { - city :: Maybe String, - state :: Maybe String, - country :: String } - deriving (Eq, Show) - -instance FromXml NewsLocation where - type Db NewsLocation = NewsLocation - from_xml = id - -instance XmlImport NewsLocation - - --- | Mapping between News records and NewsLocation records in the --- database. We name the fields (even though they're never used) for --- Groundhog's benefit. -data News_NewsLocation = - News_NewsLocation { - nnl_news_id :: DefaultKey News, - nnl_news_location_id :: DefaultKey NewsLocation } - +-- * News/Message -- | The msg_id child of contains an event_id attribute; we -- embed it into the 'News' type. We (pointlessly) use the "db_" --- prefix here so that the two names collide on "id" when Groundhog --- is creating its fields using our field namer. +-- prefix here so that the two names don't collide on "id" when +-- Groundhog is creating its fields using our field namer. data MsgId = MsgId { db_msg_id :: Int, @@ -107,6 +78,8 @@ data MsgId = deriving (Data, Eq, Show, Typeable) +-- | The XML representation of a news item (message). +-- data Message = Message { xml_xml_file_id :: Int, @@ -114,37 +87,147 @@ data Message = xml_mid :: MsgId, xml_category :: String, xml_sport :: String, - xml_url :: String, + xml_url :: Maybe String, xml_teams :: [NewsTeam], xml_locations :: [NewsLocation], xml_sms :: String, xml_editor :: Maybe String, xml_text :: Maybe String, -- Text and continue seem to show up in pairs, xml_continue :: Maybe String, -- either both present or both missing. - xml_time_stamp :: String } + xml_time_stamp :: UTCTime } deriving (Eq, Show) + +-- | The database representation of a news item. We drop several +-- uninteresting fields from 'Message', and omit the list fields which +-- will be represented as join tables. +-- data News = News { + db_xml_file_id :: Int, db_mid :: MsgId, db_sport :: String, - db_url :: String, + db_url :: Maybe String, db_sms :: String, db_editor :: Maybe String, db_text :: Maybe String, - db_continue :: Maybe String } + db_continue :: Maybe String, + db_time_stamp :: UTCTime } deriving (Data, Eq, Show, Typeable) -instance FromXml Message where - type Db Message = News - -- We don't need the key argument (from_xml_fk) since the XML type - -- contains more information in this case. - from_xml (Message _ _ c _ e f _ _ i j k l _) = - News c e f i j k l +instance ToDb Message where + type Db Message = News + +-- | Convert the XML representation 'Message' to the database +-- representation 'News'. +-- +instance FromXml Message where + -- | We use a record wildcard so GHC doesn't complain that we never + -- used the field names. + -- + from_xml Message{..} = News { db_xml_file_id = xml_xml_file_id, + db_mid = xml_mid, + db_sport = xml_sport, + db_url = xml_url, + db_sms = xml_sms, + db_editor = xml_editor, + db_text = xml_text, + db_continue = xml_continue, + db_time_stamp = xml_time_stamp } + +-- | This lets us call 'insert_xml' on a 'Message'. +-- instance XmlImport Message + +-- * NewsTeam + +-- | The database type for teams as they show up in the news. +-- +data NewsTeam = + NewsTeam { team_name :: String } + deriving (Eq, Show) + + +instance ToDb NewsTeam where + -- | The database representaion of a 'NewsTeam' is itself. + type Db NewsTeam = NewsTeam + +-- | This is needed to define the XmlImport instance for NewsTeam. +-- +instance FromXml NewsTeam where + -- | How to we get a 'NewsTeam' from itself? + from_xml = id + +-- | Allow us to call 'insert_xml' on the XML representation of +-- NewsTeams. +-- +instance XmlImport NewsTeam + + + +-- * News_NewsTeam + +-- | Mapping between News records and NewsTeam records in the +-- database. We don't name the fields because we don't use the names +-- explicitly; that means we have to give them nice database names +-- via groundhog. +-- +data News_NewsTeam = News_NewsTeam + (DefaultKey News) + (DefaultKey NewsTeam) + + +-- * NewsLocation + +-- | The database type for locations as they show up in the news. +-- +data NewsLocation = + NewsLocation { + city :: Maybe String, + state :: Maybe String, + country :: String } + deriving (Eq, Show) + +instance ToDb NewsLocation where + -- | The database representation of a 'NewsLocation' is itself. + type Db NewsLocation = NewsLocation + +-- | This is needed to define the XmlImport instance for NewsLocation. +-- +instance FromXml NewsLocation where + -- | How to we get a 'NewsLocation' from itself? + from_xml = id + +-- | Allow us to call 'insert_xml' on the XML representation of +-- NewsLocations. +-- +instance XmlImport NewsLocation + + +-- * News_NewsLocation + +-- | Mapping between News records and NewsLocation records in the +-- database. We don't name the fields because we don't use the names +-- explicitly; that means we have to give them nice database names +-- via groundhog. +-- +data News_NewsLocation = News_NewsLocation + (DefaultKey News) + (DefaultKey NewsLocation) + + + +-- +-- Database code +-- + +-- | Define 'dbmigrate' and 'dbimport' for 'Message's. The import is +-- slightly non-generic because of our 'News_NewsTeam' and +-- 'News_NewsLocation' join tables. +-- instance DbImport Message where dbmigrate _ = run_dbmigrate $ do @@ -178,8 +261,8 @@ instance DbImport Message where -- These types don't have special XML representations or field name --- collisions so we use the defaultCodegenConfig and give their fields --- nice simple names. +-- collisions so we use the defaultCodegenConfig and give their +-- fields nice simple names. mkPersist defaultCodegenConfig [groundhog| - entity: NewsTeam dbName: news_teams @@ -201,16 +284,25 @@ mkPersist defaultCodegenConfig [groundhog| |] + +-- These types have fields with e.g. db_ and xml_ prefixes, so we +-- use our own codegen to peel those off before naming the columns. mkPersist tsn_codegen_config [groundhog| - entity: News dbName: news constructors: - name: News + uniques: + - name: unique_news + type: constraint + # Prevent multiple imports of the same message. + fields: [db_xml_file_id] fields: - name: db_mid embeddedType: - {name: msg_id, dbName: msg_id} - {name: event_id, dbName: event_id} + - embedded: MsgId fields: - name: db_msg_id @@ -218,14 +310,41 @@ mkPersist tsn_codegen_config [groundhog| - name: db_event_id dbName: event_id - - entity: News_NewsTeam dbName: news__news_teams + constructors: + - name: News_NewsTeam + fields: + - name: news_NewsTeam0 # Default created by mkNormalFieldName + dbName: news_id + reference: + onDelete: cascade + - name: news_NewsTeam1 # Default created by mkNormalFieldName + dbName: news_teams_id + reference: + onDelete: cascade - entity: News_NewsLocation dbName: news__news_locations + constructors: + - name: News_NewsLocation + fields: + - name: news_NewsLocation0 # Default created by mkNormalFieldName + dbName: news_id + reference: + onDelete: cascade + - name: news_NewsLocation1 # Default created by mkNormalFieldName + dbName: news_locations_id + reference: + onDelete: cascade |] +-- +-- XML Picklers +-- + +-- | Convert a 'NewsTeam' to/from XML. +-- pickle_news_team :: PU NewsTeam pickle_news_team = xpElem "team" $ @@ -238,6 +357,8 @@ pickle_news_team = from_string = NewsTeam +-- | Convert a 'MsgId' to/from XML. +-- pickle_msg_id :: PU MsgId pickle_msg_id = xpElem "msg_id" $ @@ -248,6 +369,8 @@ pickle_msg_id = to_tuple m = (db_msg_id m, db_event_id m) +-- | Convert a 'NewsLocation' to/from XML. +-- pickle_location :: PU NewsLocation pickle_location = xpElem "location" $ @@ -261,7 +384,8 @@ pickle_location = to_tuple l = (city l, state l, country l) - +-- | Convert a 'Message' to/from XML. +-- pickle_message :: PU Message pickle_message = xpElem "message" $ @@ -271,30 +395,33 @@ pickle_message = pickle_msg_id (xpElem "category" xpText) (xpElem "sport" xpText) - (xpElem "url" xpText0) + (xpElem "url" $ xpOption xpText) (xpList pickle_news_team) (xpList pickle_location) (xpElem "SMS" xpText) (xpOption (xpElem "Editor" xpText)) (xpOption (xpElem "text" xpText)) pickle_continue - (xpElem "time_stamp" xpText) + (xpElem "time_stamp" xp_time_stamp) where from_tuple = uncurryN Message - to_tuple m = (xml_xml_file_id m, - xml_heading m, - xml_mid m, - xml_category m, - xml_sport m, - xml_url m, - xml_teams m, - xml_locations m, + to_tuple m = (xml_xml_file_id m, -- Verbose, + xml_heading m, -- but + xml_mid m, -- eliminates + xml_category m, -- GHC + xml_sport m, -- warnings + xml_url m, -- . + xml_teams m, -- . + xml_locations m, -- . xml_sms m, xml_editor m, xml_text m, xml_continue m, xml_time_stamp m) + -- | We combine all of the \ elements into one 'String' + -- while unpickling and do the reverse while pickling. + -- pickle_continue :: PU (Maybe String) pickle_continue = xpOption $ @@ -309,8 +436,12 @@ pickle_message = to_string = join "\n" +-- +-- Tasty Tests +-- --- * Tasty Tests +-- | A list of all tests for this module. +-- news_tests :: TestTree news_tests = testGroup @@ -320,6 +451,8 @@ news_tests = test_unpickle_succeeds ] +-- | Make sure our codegen is producing the correct database names. +-- test_news_fields_have_correct_names :: TestTree test_news_fields_have_correct_names = testCase "news fields get correct database names" $ @@ -336,13 +469,22 @@ test_news_fields_have_correct_names = map (\x -> tsn_db_field_namer "herp" "derp" 8675309 x 90210) field_names actual :: [String] - actual = ["mid", "sport", "url", "sms", "editor", "text", "continue"] + actual = ["xml_file_id", + "mid", + "sport", + "url", + "sms", + "editor", + "text", + "continue"] check (x,y) = (x @?= y) --- | Warning, succeess of this test does not mean that unpickling --- succeeded. +-- | If we unpickle something and then pickle it, we should wind up +-- with the same thing we started with. WARNING: success of this +-- test does not mean that unpickling succeeded. +-- test_pickle_of_unpickle_is_identity :: TestTree test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" [ check "pickle composed with unpickle is the identity" @@ -356,6 +498,8 @@ test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" actual @?= expected +-- | Make sure we can actually unpickle these things. +-- test_unpickle_succeeds :: TestTree test_unpickle_succeeds = testGroup "unpickle tests" [ check "unpickling succeeds"