+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
--- | Parse TSN XML for the DTD "newsxml.dtd". Each document contains a
--- root element \<message\> that contains an entire news item.
+-- | Parse TSN XML for the DTD \"newsxml.dtd\". Each document contains
+-- a root element \<message\> that contains an entire news item.
--
module TSN.XML.News (
+ dtd,
+ has_only_single_sms,
pickle_message,
-- * Tests
news_tests,
-- * WARNING: these are private but exported to silence warnings
- News_NewsLocationConstructor(..),
- News_NewsTeamConstructor(..),
- NewsConstructor(..),
- NewsLocationConstructor(..),
- NewsTeamConstructor(..) )
+ News_LocationConstructor(..),
+ News_TeamConstructor(..),
+ NewsConstructor(..) )
where
-- 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 )
+import qualified Data.Vector.HFixed as H ( HVector, convert )
import Database.Groundhog (
+ countAll,
+ deleteAll,
insert_,
migrate )
import Database.Groundhog.Core ( DefaultKey )
+import Database.Groundhog.Generic ( runDbConn, runMigrationSilent )
+import Database.Groundhog.Sqlite ( withSqliteConn )
import Database.Groundhog.TH (
- defaultCodegenConfig,
groundhog,
mkPersist )
+import qualified GHC.Generics as GHC ( Generic )
import Test.Tasty ( TestTree, testGroup )
import Test.Tasty.HUnit ( (@?=), testCase )
import Text.XML.HXT.Core (
PU,
+ XmlTree,
+ (/>),
+ (>>>),
+ addNav,
+ descendantAxis,
+ filterAxis,
+ followingSiblingAxis,
+ hasName,
+ remNav,
+ runLA,
xp13Tuple,
xpAttr,
xpElem,
xpOption,
xpPair,
xpText,
- xpTriple,
xpWrap )
-- Local imports.
import TSN.Codegen (
tsn_codegen_config,
tsn_db_field_namer ) -- Used in a test
+import TSN.Database ( insert_or_select )
import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
+import TSN.Location ( Location(..), pickle_location )
+import TSN.Picklers ( xp_attr_option, xp_time_stamp )
+import TSN.Team ( Team(..) )
import TSN.XmlImport ( XmlImport(..) )
-import Xml ( FromXml(..), pickle_unpickle, unpickleable )
+import Xml (
+ FromXml(..),
+ ToDb(..),
+ pickle_unpickle,
+ unpickleable,
+ unsafe_read_invalid_document,
+ unsafe_unpickle )
-
--- | The database type for teams as they show up in the news.
+-- | The DTD to which this module corresponds. Used to invoke dbimport.
--
-data NewsTeam =
- NewsTeam { team_name :: String }
- deriving (Eq, Show)
+dtd :: String
+dtd = "newsxml.dtd"
--- | 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 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.
+-- DB/XML Data types
--
-data News_NewsTeam = News_NewsTeam
- (DefaultKey News)
- (DefaultKey NewsTeam)
+-- * News/Message
--- | The database type for locations as they show up in the news.
+-- | 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 don't collide on \"id\" when
+-- Groundhog is creating its fields using our field namer.
--
-data NewsLocation =
- NewsLocation {
- city :: Maybe String,
- state :: 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.
+-- The leading underscores prevent unused field warnings.
--
-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 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 don't collide on "id" when
--- Groundhog is creating its fields using our field namer.
data MsgId =
MsgId {
- db_msg_id :: Int,
- db_event_id :: Maybe Int }
- deriving (Data, Eq, Show, Typeable)
+ _db_msg_id :: Int,
+ _db_event_id :: Maybe Int }
+ deriving (Data, Eq, GHC.Generic, Show, Typeable)
+
+-- | For 'H.convert'.
+--
+instance H.HVector MsgId
--- | The XML representation of a news item (message).
+-- | The XML representation of a news item (\<message\>).
--
data Message =
Message {
xml_category :: String,
xml_sport :: String,
xml_url :: Maybe String,
- xml_teams :: [NewsTeam],
- xml_locations :: [NewsLocation],
- xml_sms :: String,
+ xml_teams :: [NewsTeamXml],
+ xml_locations :: [Location],
+ xml_sms :: Maybe String,
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 }
- deriving (Eq, Show)
+ xml_time_stamp :: UTCTime }
+ deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'H.convert'.
+--
+instance H.HVector Message
-- | The database representation of a news item. We drop several
--
data News =
News {
+ db_xml_file_id :: Int,
db_mid :: MsgId,
db_sport :: String,
db_url :: Maybe String,
- db_sms :: String,
+ db_sms :: Maybe 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
+ -- | The database representation of 'Message' is 'News'.
+ 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.
--
- from_xml Message{..} = News { db_mid = xml_mid,
+ -- To convert, we drop some fields.
+ --
+ from_xml Message{..} = News { db_xml_file_id = xml_xml_file_id,
+ 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 }
+ db_continue = xml_continue,
+ db_time_stamp = xml_time_stamp }
--- | This lets us call 'insert_xml' on a 'Message'.
+-- | This lets us insert the XML representation 'Message' directly.
--
instance XmlImport Message
+
+-- * NewsTeamXml
+
+-- | The XML type for teams as they show up in the news. We can't
+-- reuse the representation from "TSN.Team" because our name doesn't
+-- appear optional and we have no abbreviation.
+--
+data NewsTeamXml =
+ NewsTeamXml { xml_team_id :: String,
+ xml_team_name :: String }
+ deriving (Eq, GHC.Generic, Show)
+
+
+-- | For 'H.convert'.
+--
+instance H.HVector NewsTeamXml
+
+
+instance ToDb NewsTeamXml where
+ -- | The database representation of 'NewsTeamXml' is 'Team'.
+ type Db NewsTeamXml = Team
+
+-- | Convert the XML representation 'NewsTeamXml' to the database
+-- representation 'Team'.
+--
+instance FromXml NewsTeamXml where
+ from_xml NewsTeamXml{..} =
+ Team { team_id = xml_team_id,
+ abbreviation = Nothing,
+ name = Just xml_team_name }
+
+-- | Allow us to import 'NewsTeamXml' directly.
+--
+instance XmlImport NewsTeamXml
+
+
+-- * News_Team
+
+-- | Mapping between News records and Team records in the 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_Team = News_Team (DefaultKey News) (DefaultKey Team)
+
+
+-- * News_Location
+
+-- | Mapping between 'News' records and 'Location' records in the
+-- 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_Location = News_Location
+ (DefaultKey News)
+ (DefaultKey Location)
+
+
+
+
+-- | Some newsxml documents contain two \<SMS\> elements in a row,
+-- violating the DTD. The second one has always been empty, but it's
+-- irrelevant: we can't parse these, and would like to detect them
+-- in order to report the fact that the busted document is
+-- unsupported.
+--
+-- This function detects whether two \<SMS\> elements appear in a
+-- row, as siblings.
+--
+has_only_single_sms :: XmlTree -> Bool
+has_only_single_sms xmltree =
+ case elements of
+ [] -> True
+ _ -> False
+ where
+ parse :: XmlTree -> [XmlTree]
+ parse = runLA $ hasName "/"
+ /> hasName "message"
+ >>> addNav
+ >>> descendantAxis
+ >>> filterAxis (hasName "SMS")
+ >>> followingSiblingAxis
+ >>> remNav
+ >>> hasName "SMS"
+
+ elements = parse xmltree
+
+
+--
+-- * Database code
+--
+
-- | Define 'dbmigrate' and 'dbimport' for 'Message's. The import is
--- slightly non-generic because of our 'News_NewsTeam' and
--- 'News_NewsLocation' join tables.
+-- slightly non-generic because of our 'News_Team' and
+-- 'News_Location' join tables.
--
instance DbImport Message where
dbmigrate _ =
run_dbmigrate $ do
- migrate (undefined :: NewsTeam)
- migrate (undefined :: NewsLocation)
+ migrate (undefined :: Location)
migrate (undefined :: News)
- migrate (undefined :: News_NewsTeam)
- migrate (undefined :: News_NewsLocation)
+ migrate (undefined :: Team)
+ migrate (undefined :: News_Team)
+ migrate (undefined :: News_Location)
dbimport message = do
-- 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 insert_xml_or_select
- -- because we know that most teams will already exist, and we
- -- 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 insert the teams. We use insert_xml_or_select because we
+ -- know that most teams will already exist, and we want to get
+ -- back the id for the existing team when there's a collision.
+ team_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.
- let news_news_teams = map (News_NewsTeam news_id) nt_ids
- mapM_ insert_ news_news_teams
+ -- news__team records mapping beween the two.
+ let news_teams = map (News_Team news_id) team_ids
+ mapM_ insert_ news_teams
- -- Do all of that over again for the NewsLocations.
- loc_ids <- mapM insert_xml_or_select (xml_locations message)
- let news_news_locations = map (News_NewsLocation news_id) loc_ids
+ -- Do all of that over again for the Locations.
+ loc_ids <- mapM insert_or_select (xml_locations message)
+ let news_news_locations = map (News_Location news_id) loc_ids
mapM_ insert_ news_news_locations
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.
-mkPersist defaultCodegenConfig [groundhog|
-- entity: NewsTeam
- dbName: news_teams
- constructors:
- - name: NewsTeam
- uniques:
- - name: unique_news_team
- type: constraint
- fields: [team_name]
-
-- entity: NewsLocation
- dbName: news_locations
- constructors:
- - name: NewsLocation
- uniques:
- - name: unique_news_location
- type: constraint
- fields: [city, state, country]
-
-|]
-
-- 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
+ uniques:
+ - name: unique_news
+ type: constraint
+ # Prevent multiple imports of the same message.
+ fields: [db_xml_file_id]
fields:
- name: db_mid
embeddedType:
- {name: msg_id, dbName: msg_id}
- {name: event_id, dbName: event_id}
+
- embedded: MsgId
fields:
- - name: db_msg_id
+ - name: _db_msg_id
dbName: msg_id
- - name: db_event_id
+ - name: _db_event_id
dbName: event_id
-
-- entity: News_NewsTeam
- dbName: news__news_teams
+- entity: News_Team
+ dbName: news__teams
constructors:
- - name: News_NewsTeam
+ - name: News_Team
fields:
- - name: news_NewsTeam0 # Default created by mkNormalFieldName
+ - name: news_Team0 # 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
+ reference:
+ onDelete: cascade
+ - name: news_Team1 # Default created by mkNormalFieldName
+ dbName: teams_id
+ reference:
+ onDelete: cascade
+
+- entity: News_Location
+ dbName: news__locations
constructors:
- - name: News_NewsLocation
+ - name: News_Location
fields:
- - name: news_NewsLocation0 # Default created by mkNormalFieldName
+ - name: news_Location0 # Default created by mkNormalFieldName
dbName: news_id
- - name: news_NewsLocation1 # Default created by mkNormalFieldName
- dbName: news_locations_id
+ reference:
+ onDelete: cascade
+ - name: news_Location1 # Default created by mkNormalFieldName
+ dbName: locations_id
+ reference:
+ onDelete: cascade
|]
--- | Convert a 'NewsTeam' to/from XML.
--
-pickle_news_team :: PU NewsTeam
+-- XML Picklers
+--
+
+-- | Convert a 'NewsTeamXml' to/from XML.
+--
+pickle_news_team :: PU NewsTeamXml
pickle_news_team =
xpElem "team" $
- xpWrap (from_string, to_string) xpText
+ xpWrap (from_tuple, H.convert) $
+ xpPair (xpAttr "id" xpText)
+ xpText -- team name
where
- to_string :: NewsTeam -> String
- to_string = team_name
-
- from_string :: String -> NewsTeam
- from_string = NewsTeam
+ from_tuple = uncurry NewsTeamXml
-- | Convert a 'MsgId' to/from XML.
pickle_msg_id :: PU MsgId
pickle_msg_id =
xpElem "msg_id" $
- xpWrap (from_tuple, to_tuple) $
- xpPair xpInt (xpAttr "EventId" (xpOption xpInt))
+ xpWrap (from_tuple, H.convert) $
+ xpPair xpInt (xpAttr "EventId" xp_attr_option)
where
from_tuple = uncurryN MsgId
- to_tuple m = (db_msg_id m, db_event_id m)
--- | Convert a 'NewsLocation' to/from XML.
---
-pickle_location :: PU NewsLocation
-pickle_location =
- xpElem "location" $
- xpWrap (from_tuple, to_tuple) $
- xpTriple (xpOption (xpElem "city" xpText))
- (xpOption (xpElem "state" xpText))
- (xpElem "country" xpText)
- where
- from_tuple =
- uncurryN NewsLocation
- to_tuple l = (city l, state l, country l)
-
-- | Convert a 'Message' to/from XML.
--
pickle_message :: PU Message
pickle_message =
xpElem "message" $
- xpWrap (from_tuple, to_tuple) $
+ xpWrap (from_tuple, H.convert) $
xp13Tuple (xpElem "XML_File_ID" xpInt)
(xpElem "heading" xpText)
pickle_msg_id
(xpElem "url" $ xpOption xpText)
(xpList pickle_news_team)
(xpList pickle_location)
- (xpElem "SMS" xpText)
+ (xpElem "SMS" $ xpOption xpText)
(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,
- 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.
testGroup
"News tests"
[ test_news_fields_have_correct_names,
+ test_on_delete_cascade,
test_pickle_of_unpickle_is_identity,
- test_unpickle_succeeds ]
+ test_unpickle_succeeds,
+ test_sms_detected_correctly ]
-- | Make sure our codegen is producing the correct database names.
map (\x -> tsn_db_field_namer "herp" "derp" 8675309 x 90210) field_names
actual :: [String]
- actual = ["mid", "sport", "url", "sms", "editor", "text", "continue"]
+ actual = ["xml_file_id",
+ "mid",
+ "sport",
+ "url",
+ "sms",
+ "editor",
+ "text",
+ "continue"]
check (x,y) = (x @?= y)
"test/xml/newsxml.xml",
check "pickle composed with unpickle is the identity (with Editor)"
- "test/xml/newsxml-with-editor.xml" ]
+ "test/xml/newsxml-with-editor.xml",
+
+ check "pickle composed with unpickle is the identity (empty SMS)"
+ "test/xml/newsxml-empty-sms.xml" ]
where
check desc path = testCase desc $ do
(expected, actual) <- pickle_unpickle pickle_message path
"test/xml/newsxml.xml",
check "unpickling succeeds (with Editor)"
- "test/xml/newsxml-with-editor.xml" ]
+ "test/xml/newsxml-with-editor.xml",
+
+ check "unpickling succeeds (empty SMS)"
+ "test/xml/newsxml-empty-sms.xml" ]
where
check desc path = testCase desc $ do
actual <- unpickleable path pickle_message
let expected = True
actual @?= expected
+
+
+-- | Make sure everything gets deleted when we delete the top-level
+-- record.
+--
+test_on_delete_cascade :: TestTree
+test_on_delete_cascade = testGroup "cascading delete tests"
+ [ check "deleting news deletes its children"
+ "test/xml/newsxml.xml"
+ 4 -- 2 news_teams and 2 news_locations that should remain.
+ ,
+ check "deleting news deletes its children (empty SMS)"
+ "test/xml/newsxml-empty-sms.xml"
+ 4 -- 2 news_teams and 2 news_locations
+ ]
+ where
+ check desc path expected = testCase desc $ do
+ news <- unsafe_unpickle path pickle_message
+ let a = undefined :: Location
+ let b = undefined :: News
+ let c = undefined :: Team
+ let d = undefined :: News_Team
+ let e = undefined :: News_Location
+ actual <- withSqliteConn ":memory:" $ runDbConn $ do
+ runMigrationSilent $ do
+ migrate a
+ migrate b
+ migrate c
+ migrate d
+ migrate e
+ _ <- dbimport news
+ deleteAll b
+ count_a <- countAll a
+ count_b <- countAll b
+ count_c <- countAll c
+ count_d <- countAll d
+ count_e <- countAll e
+ return $ count_a + count_b + count_c + count_d + count_e
+ actual @?= expected
+
+
+-- | We want to make sure the single-SMS documents and the multi-SMS
+-- documents are identified correctly.
+--
+test_sms_detected_correctly :: TestTree
+test_sms_detected_correctly =
+ testGroup "newsxml SMS count determined correctly"
+ [ check "test/xml/newsxml.xml"
+ "single SMS detected correctly"
+ True,
+ check "test/xml/newsxml-multiple-sms.xml"
+ "multiple SMS detected correctly"
+ False ]
+ where
+ check path desc expected = testCase desc $ do
+ xmltree <- unsafe_read_invalid_document path
+ let actual = has_only_single_sms xmltree
+ actual @?= expected
projects / dead / htsn-import.git / blobdiff