Use the timestamp pickler in TSN.XML.News.

[dead/htsn-import.git] / src / TSN / XML / News.hs

diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs
index b9bc3df4f84b98c58f369085868987d9cbecdbe3..4a59859cacb770f55fb8472638f02051edbe9dd3 100644 (file)
--- a/src/TSN/XML/News.hs
+++ b/src/TSN/XML/News.hs
@@ -11,8 +11,9 @@
 --   root element \<message\> 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 )
 
@@ -149,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)
 
 
@@ -165,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)
 
 
@@ -184,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'.
 --
@@ -226,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
@@ -251,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
@@ -279,8 +283,12 @@ mkPersist tsn_codegen_config [groundhog|
       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
@@ -289,8 +297,12 @@ mkPersist tsn_codegen_config [groundhog|
       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
 |]
 
 
@@ -353,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,
@@ -387,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
@@ -398,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" $
@@ -419,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"
@@ -434,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"