X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FNews.hs;h=aa1a01c278dea76709a6c528beb0d9b41bf48104;hb=9fff5c185dd7a2c8655815f36b72736d61401e41;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..aa1a01c 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, @@ -45,9 +47,11 @@ import Text.XML.HXT.Core ( xpTriple, xpWrap ) -import Network.Services.TSN.Report ( report_error ) -import TSN.Codegen ( tsn_codegen_config ) -import TSN.DbImport ( DbImport(..) ) +import TSN.Codegen ( + tsn_codegen_config, + tsn_db_field_namer -- Used in a test. + ) +import TSN.DbImport ( DbImport(..), ImportResult(..) ) import Xml ( ToFromXml(..), pickle_unpickle ) @@ -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 @@ -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,7 +333,8 @@ 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_pickle_of_unpickle_is_identity :: TestTree @@ -339,3 +343,24 @@ test_pickle_of_unpickle_is_identity = let path = "test/xml/newsxml.xml" (expected :: [MessageXml], actual) <- pickle_unpickle "message" path actual @?= expected + + +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)