-- 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(..),
-- 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 )
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 )
+import Xml ( FromXml(..), ToDb(..), pickle_unpickle, unpickleable )
NewsTeam { team_name :: String }
deriving (Eq, Show)
--- | This is needed to define the XmlImport instance for NewsTeam; it
--- basically says that the DB representation is the same as the XML
--- representation.
+
+instance ToDb NewsTeam where
+ -- | The database representaion of a 'NewsTeam' is itself.
+ type Db NewsTeam = NewsTeam
+
+-- | This is needed to define the XmlImport instance for NewsTeam.
--
instance FromXml NewsTeam where
- type Db NewsTeam = NewsTeam
+ -- | How to we get a 'NewsTeam' from itself?
from_xml = id
-- | Allow us to call 'insert_xml' on the XML representation of
-- | Mapping between News records and NewsTeam records in the
--- database.
+-- database. We don't name the fields because we don't use the names
+-- explicitly; that means we have to give them nice database names
+-- via groundhog.
--
data News_NewsTeam = News_NewsTeam
(DefaultKey News)
country :: String }
deriving (Eq, Show)
--- | This is needed to define the XmlImport instance for NewsLocation; it
--- basically says that the DB representation is the same as the XML
--- representation.
+instance ToDb NewsLocation where
+ -- | The database representation of a 'NewsLocation' is itself.
+ type Db NewsLocation = NewsLocation
+
+-- | This is needed to define the XmlImport instance for NewsLocation.
--
instance FromXml NewsLocation where
- type Db NewsLocation = NewsLocation
+ -- | How to we get a 'NewsLocation' from itself?
from_xml = id
-- | Allow us to call 'insert_xml' on the XML representation of
-- | Mapping between News records and NewsLocation records in the
--- database.
+-- database. We don't name the fields because we don't use the names
+-- explicitly; that means we have to give them nice database names
+-- via groundhog.
--
data News_NewsLocation = News_NewsLocation
(DefaultKey News)
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)
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)
+
+instance ToDb Message where
+ type Db Message = News
+
-- | Convert the XML representation 'Message' to the database
-- representation 'News'.
--
instance FromXml Message where
- type Db Message = News
-
-- | We use a record wildcard so GHC doesn't complain that we never
-- used the field names.
--
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'.
--
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
|]
--- | 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
constructors:
- name: News_NewsTeam
fields:
- - name: news_NewsTeam0
+ - name: news_NewsTeam0 # Default created by mkNormalFieldName
dbName: news_id
- - name: news_NewsTeam1
+ reference:
+ onDelete: cascade
+ - name: news_NewsTeam1 # Default created by mkNormalFieldName
dbName: news_teams_id
+ reference:
+ onDelete: cascade
- entity: News_NewsLocation
dbName: news__news_locations
constructors:
- name: News_NewsLocation
fields:
- - name: news_NewsLocation0
+ - name: news_NewsLocation0 # Default created by mkNormalFieldName
dbName: news_id
- - name: news_NewsLocation1
+ reference:
+ onDelete: cascade
+ - name: news_NewsLocation1 # Default created by mkNormalFieldName
dbName: news_locations_id
+ reference:
+ onDelete: cascade
|]
(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,
to_string = join "\n"
+--
+-- Tasty Tests
+--
--- * Tasty Tests
+-- | A list of all tests for this module.
+--
news_tests :: TestTree
news_tests =
testGroup
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" $
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"
actual @?= expected
+-- | Make sure we can actually unpickle these things.
+--
test_unpickle_succeeds :: TestTree
test_unpickle_succeeds = testGroup "unpickle tests"
[ check "unpickling succeeds"
projects / dead / htsn-import.git / blobdiff