X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FNews.hs;h=4a59859cacb770f55fb8472638f02051edbe9dd3;hb=49d528dc6b0a7b79ae17990872fdd7f58b80abc7;hp=a630ef7025cd6bbb31a4eb3a2db13253ad93687b;hpb=12a8d95e873234893066e9422e0ce731e0e3e6ac;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs index a630ef7..4a59859 100644 --- a/src/TSN/XML/News.hs +++ b/src/TSN/XML/News.hs @@ -11,8 +11,9 @@ -- root element \ that contains an entire news item. -- module TSN.XML.News ( - news_tests, pickle_message, + -- * Tests + news_tests, -- * WARNING: these are private but exported to silence warnings News_NewsLocationConstructor(..), News_NewsTeamConstructor(..), @@ -23,6 +24,7 @@ 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 ) @@ -54,6 +56,7 @@ 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 ) @@ -80,7 +83,9 @@ instance XmlImport NewsTeam -- | Mapping between News records and NewsTeam records in the --- database. +-- 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) @@ -111,7 +116,9 @@ instance XmlImport NewsLocation -- | Mapping between News records and NewsLocation records in the --- database. +-- 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) @@ -145,7 +152,7 @@ data Message = 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) @@ -161,7 +168,8 @@ data News = 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) @@ -180,7 +188,8 @@ instance FromXml Message where db_sms = xml_sms, db_editor = xml_editor, db_text = xml_text, - db_continue = xml_continue } + db_continue = xml_continue, + db_time_stamp = xml_time_stamp } -- | This lets us call 'insert_xml' on a 'Message'. -- @@ -222,9 +231,9 @@ instance DbImport Message where return ImportSucceeded --- | These types don't have special XML representations or field name --- collisions so we use the defaultCodegenConfig and give their --- fields nice simple names. +-- These types don't have special XML representations or field name +-- collisions so we use the defaultCodegenConfig and give their +-- fields nice simple names. mkPersist defaultCodegenConfig [groundhog| - entity: NewsTeam dbName: news_teams @@ -247,9 +256,8 @@ 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. --- +-- 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 @@ -273,20 +281,28 @@ mkPersist tsn_codegen_config [groundhog| constructors: - name: News_NewsTeam fields: - - name: news_NewsTeam0 + - name: news_NewsTeam0 # Default created by mkNormalFieldName dbName: news_id - - name: news_NewsTeam1 + 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 + - name: news_NewsLocation0 # Default created by mkNormalFieldName dbName: news_id - - name: news_NewsLocation1 + reference: + onDelete: cascade + - name: news_NewsLocation1 # Default created by mkNormalFieldName dbName: news_locations_id + reference: + onDelete: cascade |] @@ -349,7 +365,7 @@ pickle_message = (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, -- Verbose, @@ -383,8 +399,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 @@ -394,6 +414,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" $ @@ -415,8 +437,10 @@ test_news_fields_have_correct_names = 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" @@ -430,6 +454,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"