X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FNews.hs;h=565c7a52fb038b10e377b651bee1b58c73a49777;hb=579f3e4c6b01f0e89fa6dc8c41a22330d4cb7b8f;hp=61da812807e7920a50f089a3767f13beff9200f6;hpb=76cf3eee776d35ba2b18dd0d07df7496a083ae3a;p=dead%2Fhtsn-import.git

diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs
index 61da812..565c7a5 100644
--- a/src/TSN/XML/News.hs
+++ b/src/TSN/XML/News.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE QuasiQuotes #-}
@@ -16,9 +17,10 @@ module TSN.XML.News (
   news_tests )
 where
 
-import Control.Monad.IO.Class ( MonadIO, liftIO )
+import Data.Data ( Data, constrFields, dataTypeConstrs, dataTypeOf )
 import Data.List.Utils ( join, split )
 import Data.Tuple.Curry ( uncurryN )
+import Data.Typeable ( Typeable )
 import Database.Groundhog (
   defaultMigrationLogger,
   insert,
@@ -28,27 +30,29 @@ import Database.Groundhog.Core ( DefaultKey )
 import Database.Groundhog.TH (
   groundhog,
   mkPersist )
+import System.Console.CmdArgs.Default ( Default(..) )
 import Test.Tasty ( TestTree, testGroup )
 import Test.Tasty.HUnit ( (@?=), testCase )
 import Text.XML.HXT.Core (
   PU,
   XmlPickler(..),
   unpickleDoc,
-  xp12Tuple,
+  xp13Tuple,
   xpAttr,
   xpElem,
+  xpInt,
   xpList,
   xpOption,
   xpPair,
-  xpPrim,
   xpText,
   xpTriple,
   xpWrap )
 
-import Network.Services.TSN.Report ( report_error )
-import TSN.Codegen ( tsn_codegen_config )
-import TSN.DbImport ( DbImport(..) )
-import Xml ( ToFromXml(..), pickle_unpickle )
+import TSN.Codegen (
+  tsn_codegen_config,
+  tsn_db_field_namer ) -- Used in a test
+import TSN.DbImport ( DbImport(..), ImportResult(..) )
+import Xml ( ToFromXml(..), pickle_unpickle, unpickleable )
 
 
 
@@ -80,7 +84,7 @@ instance ToFromXml NewsTeam where
   -- used our named fields.
   to_xml (NewsTeam {..}) = NewsTeamXml db_team_name
   -- We can't create a DefaultKey Message...
-  from_xml = error "Called from_xml on a NewsTeam"
+  from_xml = error "Called from_xml on a NewsTeam."
   -- unless we're handed one.
   from_xml_fk key = (NewsTeam key) . xml_team_name
 
@@ -118,7 +122,7 @@ instance ToFromXml NewsLocation where
   -- used our named fields.
   to_xml (NewsLocation {..}) = NewsLocationXml db_city db_state db_country
   -- We can't create a DefaultKey Message...
-  from_xml = error "Called from_xml on a NewsLocation"
+  from_xml = error "Called from_xml on a NewsLocation."
   -- unless we're given one.
   from_xml_fk key (NewsLocationXml x y z) = NewsLocation key x y z
 
@@ -131,7 +135,7 @@ data MsgId =
   MsgId {
     db_msg_id       :: Int,
     db_event_id     :: Maybe Int }
-  deriving (Eq, Show)
+  deriving (Data, Eq, Show, Typeable)
 
 
 data MessageXml =
@@ -145,6 +149,7 @@ data MessageXml =
     xml_teams :: [NewsTeamXml],
     xml_locations :: [NewsLocationXml],
     xml_sms :: String,
+    xml_editor :: Maybe String,
     xml_text :: String,
     xml_continue :: String,
     xml_time_stamp :: String }
@@ -156,9 +161,10 @@ data Message =
     db_sport :: String,
     db_url :: String,
     db_sms :: String,
+    db_editor :: Maybe String,
     db_text :: String,
     db_continue :: String }
-  deriving (Eq, Show)
+  deriving (Data, Eq, Show, Typeable)
 
 instance ToFromXml Message where
   type Xml Message = MessageXml
@@ -168,23 +174,24 @@ instance ToFromXml Message where
   -- used our named fields.
   to_xml (Message {..}) =
     MessageXml
-      0
-      ""
+      def
+      def
       db_mid
-      ""
+      def
       db_sport
       db_url
-      []
-      []
+      def
+      def
       db_sms
+      db_editor
       db_text
       db_continue
-      ""
+      def
 
   -- We don't need the key argument (from_xml_fk) since the XML type
   -- contains more information in this case.
-  from_xml (MessageXml _ _ c _ e f _ _ g h i _) =
-    Message c e f g h i
+  from_xml (MessageXml _ _ c _ e f _ _ i j k l _) =
+    Message c e f i j k l
 
 
 mkPersist tsn_codegen_config [groundhog|
@@ -229,7 +236,7 @@ pickle_msg_id :: PU MsgId
 pickle_msg_id =
   xpElem "msg_id" $
     xpWrap (from_tuple, to_tuple) $
-    xpPair xpPrim (xpAttr "EventId" (xpOption xpPrim))
+    xpPair xpInt (xpAttr "EventId" (xpOption xpInt))
   where
     from_tuple = uncurryN MsgId
     to_tuple m = (db_msg_id m, db_event_id m)
@@ -257,15 +264,16 @@ pickle_message :: PU MessageXml
 pickle_message =
   xpElem "message" $
     xpWrap (from_tuple, to_tuple) $
-    xp12Tuple (xpElem "XML_File_ID" xpPrim)
+    xp13Tuple (xpElem "XML_File_ID" xpInt)
               (xpElem "heading" xpText)
               pickle_msg_id
               (xpElem "category" xpText)
               (xpElem "sport" xpText)
               (xpElem "url" xpText)
-              (xpList $ pickle_news_team)
-              (xpList $ pickle_location)
+              (xpList pickle_news_team)
+              (xpList pickle_location)
               (xpElem "SMS" xpText)
+              (xpOption (xpElem "Editor" xpText))
               (xpElem "text" xpText)
               pickle_continue
               (xpElem "time_stamp" xpText)
@@ -280,6 +288,7 @@ pickle_message =
                   xml_teams m,
                   xml_locations m,
                   xml_sms m,
+                  xml_editor m,
                   xml_text m,
                   xml_continue m,
                   xml_time_stamp m)
@@ -288,7 +297,7 @@ pickle_message =
     pickle_continue =
       xpWrap (to_string, from_string) $
         xpElem "continue" $
-          (xpList $ xpElem "P" xpText)
+          xpList (xpElem "P" xpText)
       where
         from_string :: String -> [String]
         from_string = split "\n"
@@ -311,8 +320,7 @@ instance DbImport Message where
     case root_element of
       Nothing -> do
         let errmsg = "Could not unpickle News message in dbimport."
-        liftIO $ report_error errmsg
-        return Nothing
+        return $ ImportFailed errmsg
       Just message  -> do
         news_id <- insert (from_xml message :: Message)
         let nts :: [NewsTeam] = map (from_xml_fk news_id)
@@ -322,7 +330,7 @@ instance DbImport Message where
         nt_ids <- mapM insert nts
         loc_ids <- mapM insert nlocs
 
-        return $ Just (1 + (length nt_ids) + (length loc_ids))
+        return $ ImportSucceeded (1 + (length nt_ids) + (length loc_ids))
 
 
 -- * Tasty Tests
@@ -330,12 +338,56 @@ news_tests :: TestTree
 news_tests =
   testGroup
     "News tests"
-    [ test_pickle_of_unpickle_is_identity ]
+    [ test_news_fields_have_correct_names,
+      test_pickle_of_unpickle_is_identity,
+      test_unpickle_succeeds ]
+
+
+test_news_fields_have_correct_names :: TestTree
+test_news_fields_have_correct_names =
+  testCase "news fields get correct database names" $
+    mapM_ check (zip actual expected)
+  where
+    -- This is cool, it uses the (derived) Data instance of
+    -- News.Message to get its constructor names.
+    field_names :: [String]
+    field_names =
+      constrFields . head $ dataTypeConstrs $ dataTypeOf (undefined :: Message)
+
+    expected :: [String]
+    expected =
+      map (\x -> tsn_db_field_namer "herp" "derp" 8675309 x 90210) field_names
+
+    actual :: [String]
+    actual = ["mid", "sport", "url", "sms", "editor", "text", "continue"]
 
+    check (x,y) = (x @?= y)
 
+
+-- | Warning, succeess of this test does not mean that unpickling
+--   succeeded.
 test_pickle_of_unpickle_is_identity :: TestTree
-test_pickle_of_unpickle_is_identity =
-  testCase "pickle composed with unpickle is the identity" $ do
-    let path = "test/xml/newsxml.xml"
-    (expected :: [MessageXml], actual) <- pickle_unpickle "message" path
-    actual @?= expected
+test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
+  [ check "pickle composed with unpickle is the identity"
+          "test/xml/newsxml.xml",
+
+    check "pickle composed with unpickle is the identity (with Editor)"
+          "test/xml/newsxml-with-editor.xml" ]
+  where
+    check desc path = testCase desc $ do
+      (expected :: [MessageXml], actual) <- pickle_unpickle "message" path
+      actual @?= expected
+
+
+test_unpickle_succeeds :: TestTree
+test_unpickle_succeeds = testGroup "unpickle tests"
+  [ check "unpickling succeeds"
+          "test/xml/newsxml.xml",
+
+    check "unpickling succeeds (with Editor)"
+          "test/xml/newsxml-with-editor.xml" ]
+  where
+    check desc path = testCase desc $ do
+      actual <- unpickleable path pickle_message
+      let expected = True
+      actual @?= expected