{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
-- root element \<message\> that contains an entire news item.
--
module TSN.XML.News (
- Message,
- news_tests )
+ pickle_message,
+ -- * Tests
+ news_tests,
+ -- * WARNING: these are private but exported to silence warnings
+ News_NewsLocationConstructor(..),
+ News_NewsTeamConstructor(..),
+ NewsConstructor(..),
+ NewsLocationConstructor(..),
+ NewsTeamConstructor(..) )
where
+-- System imports.
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_,
- migrate,
- runMigration )
+ migrate )
import Database.Groundhog.Core ( DefaultKey )
import Database.Groundhog.TH (
defaultCodegenConfig,
import Test.Tasty.HUnit ( (@?=), testCase )
import Text.XML.HXT.Core (
PU,
- XmlPickler(..),
xp13Tuple,
xpAttr,
xpElem,
xpTriple,
xpWrap )
+-- Local imports.
import TSN.Codegen (
tsn_codegen_config,
tsn_db_field_namer ) -- Used in a test
-import TSN.DbImport ( DbImport(..), ImportResult(..) )
+import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
import TSN.XmlImport ( XmlImport(..) )
import Xml ( FromXml(..), pickle_unpickle, unpickleable )
-- | The database type for teams as they show up in the news.
+--
data NewsTeam =
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 FromXml NewsTeam where
type Db NewsTeam = NewsTeam
from_xml = id
+-- | Allow us to call 'insert_xml' on the XML representation of
+-- NewsTeams.
+--
instance XmlImport NewsTeam
-- | Mapping between News records and NewsTeam records in the
--- database. We name the fields (even though they're never used) for
--- Groundhog's benefit.
-data News_NewsTeam =
- News_NewsTeam {
- nnt_news_id :: DefaultKey News,
- nnt_news_team_id :: DefaultKey NewsTeam }
+-- 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)
+ (DefaultKey NewsTeam)
+
-- | The database type for locations as they show up in the news.
+--
data NewsLocation =
NewsLocation {
city :: Maybe String,
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 FromXml NewsLocation where
type Db NewsLocation = NewsLocation
from_xml = id
+-- | Allow us to call 'insert_xml' on the XML representation of
+-- NewsLocations.
+--
instance XmlImport NewsLocation
-- | Mapping between News records and NewsLocation records in the
--- database. We name the fields (even though they're never used) for
--- Groundhog's benefit.
-data News_NewsLocation =
- News_NewsLocation {
- nnl_news_id :: DefaultKey News,
- nnl_news_location_id :: DefaultKey NewsLocation }
+-- 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)
+ (DefaultKey NewsLocation)
-- | The msg_id child of <message> contains an event_id attribute; we
-- embed it into the 'News' type. We (pointlessly) use the "db_"
--- prefix here so that the two names collide on "id" when Groundhog
--- is creating its fields using our field namer.
+-- prefix here so that the two names don't collide on "id" when
+-- Groundhog is creating its fields using our field namer.
data MsgId =
MsgId {
db_msg_id :: Int,
deriving (Data, Eq, Show, Typeable)
+-- | The XML representation of a news item (message).
+--
data Message =
Message {
xml_xml_file_id :: Int,
xml_mid :: MsgId,
xml_category :: String,
xml_sport :: String,
- xml_url :: String,
+ xml_url :: Maybe String,
xml_teams :: [NewsTeam],
xml_locations :: [NewsLocation],
xml_sms :: String,
xml_time_stamp :: String }
deriving (Eq, Show)
+
+-- | The database representation of a news item. We drop several
+-- uninteresting fields from 'Message', and omit the list fields which
+-- will be represented as join tables.
+--
data News =
News {
db_mid :: MsgId,
db_sport :: String,
- db_url :: String,
+ db_url :: Maybe String,
db_sms :: String,
db_editor :: Maybe String,
db_text :: Maybe String,
db_continue :: Maybe String }
deriving (Data, Eq, Show, Typeable)
+
+-- | Convert the XML representation 'Message' to the database
+-- representation 'News'.
+--
instance FromXml Message where
type Db Message = News
- -- We don't need the key argument (from_xml_fk) since the XML type
- -- contains more information in this case.
- from_xml (Message _ _ c _ e f _ _ i j k l _) =
- News c e f i j k l
-
+ -- | We use a record wildcard so GHC doesn't complain that we never
+ -- used the field names.
+ --
+ from_xml Message{..} = News { db_mid = xml_mid,
+ db_sport = xml_sport,
+ db_url = xml_url,
+ db_sms = xml_sms,
+ db_editor = xml_editor,
+ db_text = xml_text,
+ db_continue = xml_continue }
+
+-- | This lets us call 'insert_xml' on a 'Message'.
+--
instance XmlImport Message
+-- | Define 'dbmigrate' and 'dbimport' for 'Message's. The import is
+-- slightly non-generic because of our 'News_NewsTeam' and
+-- 'News_NewsLocation' join tables.
+--
instance DbImport Message where
dbmigrate _ =
- runMigration defaultMigrationLogger $ do
+ run_dbmigrate $ do
migrate (undefined :: NewsTeam)
migrate (undefined :: NewsLocation)
migrate (undefined :: News)
-- Insert the message and acquire its primary key (unique ID)
news_id <- insert_xml message
- -- And insert each one into its own table. We use insertByAll_xml
+ -- And insert each one into its own table. We use insert_xml_or_select
-- because we know that most teams will already exist, and we
- -- want to get back a Left (id) for the existing team when
- -- there's a collision. In fact, if the insert succeeds, we'll
- -- get a Right (id) back, so we can disregard the Either
- -- constructor entirely. That's what the (either id id) does.
- either_nt_ids <- mapM insertByAll_xml (xml_teams message)
- let nt_ids = map (either id id) either_nt_ids
+ -- want to get back the id for the existing team when
+ -- there's a collision.
+ nt_ids <- mapM insert_xml_or_select (xml_teams message)
-- Now that the teams have been inserted, create
-- news__news_team records mapping beween the two.
mapM_ insert_ news_news_teams
-- Do all of that over again for the NewsLocations.
- either_loc_ids <- mapM insertByAll_xml (xml_locations message)
- let loc_ids = map (either id id) either_loc_ids
+ loc_ids <- mapM insert_xml_or_select (xml_locations message)
let news_news_locations = map (News_NewsLocation news_id) loc_ids
mapM_ insert_ news_news_locations
-- These types don't have special XML representations or field name
--- collisions so we use the defaultCodegenConfig and give their fields
--- nice simple names.
+-- 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.
mkPersist tsn_codegen_config [groundhog|
- entity: News
dbName: news
- entity: News_NewsTeam
dbName: news__news_teams
+ constructors:
+ - name: News_NewsTeam
+ fields:
+ - name: news_NewsTeam0 # Default created by mkNormalFieldName
+ dbName: news_id
+ - name: news_NewsTeam1 # Default created by mkNormalFieldName
+ dbName: news_teams_id
- entity: News_NewsLocation
dbName: news__news_locations
+ constructors:
+ - name: News_NewsLocation
+ fields:
+ - name: news_NewsLocation0 # Default created by mkNormalFieldName
+ dbName: news_id
+ - name: news_NewsLocation1 # Default created by mkNormalFieldName
+ dbName: news_locations_id
|]
+
+-- | Convert a 'NewsTeam' to/from XML.
+--
pickle_news_team :: PU NewsTeam
pickle_news_team =
xpElem "team" $
from_string :: String -> NewsTeam
from_string = NewsTeam
-instance XmlPickler NewsTeam where
- xpickle = pickle_news_team
+-- | Convert a 'MsgId' to/from XML.
+--
pickle_msg_id :: PU MsgId
pickle_msg_id =
xpElem "msg_id" $
from_tuple = uncurryN MsgId
to_tuple m = (db_msg_id m, db_event_id m)
-instance XmlPickler MsgId where
- xpickle = pickle_msg_id
+-- | Convert a 'NewsLocation' to/from XML.
+--
pickle_location :: PU NewsLocation
pickle_location =
xpElem "location" $
uncurryN NewsLocation
to_tuple l = (city l, state l, country l)
-instance XmlPickler NewsLocation where
- xpickle = pickle_location
-
+-- | Convert a 'Message' to/from XML.
+--
pickle_message :: PU Message
pickle_message =
xpElem "message" $
pickle_msg_id
(xpElem "category" xpText)
(xpElem "sport" xpText)
- (xpElem "url" xpText)
+ (xpElem "url" $ xpOption xpText)
(xpList pickle_news_team)
(xpList pickle_location)
(xpElem "SMS" xpText)
(xpElem "time_stamp" xpText)
where
from_tuple = uncurryN Message
- to_tuple m = (xml_xml_file_id m,
- xml_heading m,
- xml_mid m,
- xml_category m,
- xml_sport m,
- xml_url m,
- xml_teams m,
- xml_locations m,
+ to_tuple m = (xml_xml_file_id m, -- Verbose,
+ xml_heading m, -- but
+ xml_mid m, -- eliminates
+ xml_category m, -- GHC
+ xml_sport m, -- warnings
+ xml_url m, -- .
+ xml_teams m, -- .
+ xml_locations m, -- .
xml_sms m,
xml_editor m,
xml_text m,
xml_continue m,
xml_time_stamp m)
+ -- | We combine all of the \<continue\> elements into one 'String'
+ -- while unpickling and do the reverse while pickling.
+ --
pickle_continue :: PU (Maybe String)
pickle_continue =
xpOption $
to_string :: [String] -> String
to_string = join "\n"
-instance XmlPickler Message where
- xpickle = pickle_message
-
+--
+-- 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: succeess 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"
"test/xml/newsxml-with-editor.xml" ]
where
check desc path = testCase desc $ do
- (expected :: [Message], actual) <- pickle_unpickle "message" path
+ (expected, actual) <- pickle_unpickle pickle_message path
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