X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FNews.hs;h=661279272e5f1056221fdcb1e06cbfc1ccfe5157;hb=a1edb885c755aac52e805255382dda50f6664b60;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..6612792 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,6 +30,7 @@ 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 ( @@ -37,18 +40,19 @@ import Text.XML.HXT.Core ( xp12Tuple, 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 = @@ -158,7 +162,7 @@ data Message = db_sms :: 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 +172,23 @@ 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_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 _) = + Message c e f i j k mkPersist tsn_codegen_config [groundhog| @@ -229,7 +233,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,7 +261,7 @@ pickle_message :: PU MessageXml pickle_message = xpElem "message" $ xpWrap (from_tuple, to_tuple) $ - xp12Tuple (xpElem "XML_File_ID" xpPrim) + xp12Tuple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) pickle_msg_id (xpElem "category" xpText) @@ -311,8 +315,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 +325,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 +333,46 @@ 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" $ do + 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", "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_unpickle_succeeds :: TestTree +test_unpickle_succeeds = + testCase "unpickling succeeds" $ do + let path = "test/xml/newsxml.xml" + actual <- unpickleable path pickle_message + let expected = True + actual @?= expected