X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FNews.hs;h=10c51956fa20c23a16ff45b3469bc477aac078a7;hb=9b28d5ed0e1570f0890eae1ee01721688c20e266;hp=6e10aed9d166089d7119b543066340a28596f717;hpb=d476419274cdf2997d768444cecc47922a902fdf;p=dead%2Fhtsn-import.git

diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs
index 6e10aed..10c5195 100644
--- a/src/TSN/XML/News.hs
+++ b/src/TSN/XML/News.hs
@@ -3,34 +3,41 @@
 {-# 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_LocationConstructor(..),
   News_NewsTeamConstructor(..),
   NewsConstructor(..),
-  NewsLocationConstructor(..),
   NewsTeamConstructor(..) )
 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 Database.Groundhog (
+  countAll,
+  deleteAll,
   insert_,
-  migrate )
+  migrate,
+  runMigration,
+  silentMigrationLogger )
 import Database.Groundhog.Core ( DefaultKey )
+import Database.Groundhog.Generic ( runDbConn )
+import Database.Groundhog.Sqlite ( withSqliteConn )
 import Database.Groundhog.TH (
   defaultCodegenConfig,
   groundhog,
@@ -39,6 +46,16 @@ 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,
@@ -47,86 +64,43 @@ import Text.XML.HXT.Core (
   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.Picklers ( xp_time_stamp )
+import TSN.Location ( Location(..), pickle_location )
 import TSN.XmlImport ( XmlImport(..) )
-import Xml ( FromXml(..), pickle_unpickle, unpickleable )
+import Xml (
+  FromXml(..),
+  ToDb(..),
+  pickle_unpickle,
+  unpickleable,
+  unsafe_read_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.
---
-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,
-    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.
---
-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.
+-- DB/XML Data types
 --
-data News_NewsLocation = News_NewsLocation
-                           (DefaultKey News)
-                           (DefaultKey NewsLocation)
 
+-- * News/Message
 
--- | 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
+-- | 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,
@@ -134,7 +108,7 @@ data MsgId =
   deriving (Data, Eq, Show, Typeable)
 
 
--- | The XML representation of a news item (message).
+-- | The XML representation of a news item (\<message\>).
 --
 data Message =
   Message {
@@ -145,12 +119,12 @@ data Message =
     xml_sport :: String,
     xml_url :: Maybe String,
     xml_teams :: [NewsTeam],
-    xml_locations :: [NewsLocation],
+    xml_locations :: [Location],
     xml_sms :: 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 }
+    xml_time_stamp :: UTCTime }
   deriving (Eq, Show)
 
 
@@ -160,68 +134,149 @@ data Message =
 --
 data News =
   News {
+    db_xml_file_id :: Int,
     db_mid :: MsgId,
     db_sport :: String,
     db_url :: Maybe String,
     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
+  -- | 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,
+  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
 
+
+-- * NewsTeam
+
+-- | The database/XML type for teams as they show up in the news. We
+--   can't reuse the representation from "TSN.Team" because they
+--   require a team id. We wouldn't want to make the team ID optional
+--   and then insert a team with no id, only to find the same team
+--   later with an id and be unable to update the record. (We could
+--   add the update logic, but it would be more trouble than it's
+--   worth.)
+--
+data NewsTeam =
+  NewsTeam { team_name :: String }
+  deriving (Eq, Show)
+
+
+
+-- * News_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.
+--
+data News_NewsTeam = News_NewsTeam
+                       (DefaultKey News)
+                       (DefaultKey NewsTeam)
+
+
+-- * 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.
+--   '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 :: NewsTeam)
       migrate (undefined :: News_NewsTeam)
-      migrate (undefined :: News_NewsLocation)
+      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_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_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
 
-    -- 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
@@ -240,15 +295,6 @@ mkPersist defaultCodegenConfig [groundhog|
           type: constraint
           fields: [team_name]
 
-- entity: NewsLocation
-  dbName: news_locations
-  constructors:
-    - name: NewsLocation
-      uniques:
-        - name: unique_news_location
-          type: constraint
-          fields: [city, state, country]
-
 |]
 
 
@@ -256,14 +302,19 @@ mkPersist defaultCodegenConfig [groundhog|
 -- 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
@@ -271,7 +322,6 @@ mkPersist tsn_codegen_config [groundhog|
     - name: db_event_id
       dbName: event_id
 
-
 - entity: News_NewsTeam
   dbName: news__news_teams
   constructors:
@@ -279,21 +329,33 @@ mkPersist tsn_codegen_config [groundhog|
       fields:
         - name: news_NewsTeam0 # Default created by mkNormalFieldName
           dbName: news_id
+          reference:
+            onDelete: cascade
         - name: news_NewsTeam1 # Default created by mkNormalFieldName
           dbName: news_teams_id
+          reference:
+            onDelete: cascade
 
-- entity: News_NewsLocation
-  dbName: news__news_locations
+- 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
 |]
 
 
+--
+-- XML Picklers
+--
+
 -- | Convert a 'NewsTeam' to/from XML.
 --
 pickle_news_team :: PU NewsTeam
@@ -320,20 +382,6 @@ pickle_msg_id =
     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.
 --
@@ -353,7 +401,7 @@ pickle_message =
               (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,
@@ -398,8 +446,10 @@ news_tests =
   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.
@@ -420,13 +470,20 @@ test_news_fields_have_correct_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)
 
 
 -- | If we unpickle something and then pickle it, we should wind up
---   with the same thing we started with. WARNING: succeess of this
+--   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
@@ -456,3 +513,57 @@ test_unpickle_succeeds = testGroup "unpickle tests"
       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.
+  ]
+  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 :: NewsTeam
+      let d = undefined :: News_NewsTeam
+      let e = undefined :: News_Location
+      actual <- withSqliteConn ":memory:" $ runDbConn $ do
+                  runMigration silentMigrationLogger $ 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_document path
+      let actual = has_only_single_sms xmltree
+      actual @?= expected