{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
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,
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 )
-- 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
-- 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
MsgId {
db_msg_id :: Int,
db_event_id :: Maybe Int }
- deriving (Eq, Show)
+ deriving (Data, Eq, Show, Typeable)
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 }
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
-- 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|
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)
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)
(xpList $ pickle_news_team)
(xpList $ pickle_location)
(xpElem "SMS" xpText)
+ (xpOption (xpElem "Editor" xpText))
(xpElem "text" xpText)
pickle_continue
(xpElem "time_stamp" xpText)
xml_teams m,
xml_locations m,
xml_sms m,
+ xml_editor m,
xml_text m,
xml_continue m,
xml_time_stamp m)
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)
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
news_tests =
testGroup
"News tests"
- [ test_pickle_of_unpickle_is_identity ]
+ [ test_news_fields_have_correct_names,
+ test_pickle_of_unpickle_is_identity1,
+ test_pickle_of_unpickle_is_identity2,
+ test_unpickle_succeeds1,
+ test_unpickle_succeeds2 ]
+
+
+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", "editor", "text", "continue"]
-test_pickle_of_unpickle_is_identity :: TestTree
-test_pickle_of_unpickle_is_identity =
+ check (x,y) = (x @?= y)
+
+
+-- | Warning, succeess of this test does not mean that unpickling
+-- succeeded.
+test_pickle_of_unpickle_is_identity1 :: TestTree
+test_pickle_of_unpickle_is_identity1 =
testCase "pickle composed with unpickle is the identity" $ do
let path = "test/xml/newsxml.xml"
(expected :: [MessageXml], actual) <- pickle_unpickle "message" path
actual @?= expected
+
+-- | Repeat of 'test_pickle_of_unpickle_is_identity1' with a different
+-- XML file.
+test_pickle_of_unpickle_is_identity2 :: TestTree
+test_pickle_of_unpickle_is_identity2 =
+ testCase "pickle composed with unpickle is the identity (with Editor)" $ do
+ let path = "test/xml/newsxml-with-editor.xml"
+ (expected :: [MessageXml], actual) <- pickle_unpickle "message" path
+ actual @?= expected
+
+test_unpickle_succeeds1 :: TestTree
+test_unpickle_succeeds1 =
+ testCase "unpickling succeeds" $ do
+ let path = "test/xml/newsxml.xml"
+ actual <- unpickleable path pickle_message
+ let expected = True
+ actual @?= expected
+
+test_unpickle_succeeds2 :: TestTree
+test_unpickle_succeeds2 =
+ testCase "unpickling succeeds (with Editor)" $ do
+ let path = "test/xml/newsxml-with-editor.xml"
+ actual <- unpickleable path pickle_message
+ let expected = True
+ actual @?= expected
projects / dead / htsn-import.git / blobdiff