X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FNews.hs;h=67611e512bbcf55d85caac39b61cfe766dc3957d;hb=4cdcdbe593c30f6434a25896951a1a4dfcc2b1ca;hp=61da812807e7920a50f089a3767f13beff9200f6;hpb=76cf3eee776d35ba2b18dd0d07df7496a083ae3a;p=dead%2Fhtsn-import.git

diff --git a/src/TSN/XML/News.hs b/src/TSN/XML/News.hs
index 61da812..67611e5 100644
--- a/src/TSN/XML/News.hs
+++ b/src/TSN/XML/News.hs
@@ -1,9 +1,8 @@
-{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -16,16 +15,16 @@ module TSN.XML.News (
   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,
-  migrate,
-  runMigration )
+  insert_,
+  migrate )
 import Database.Groundhog.Core ( DefaultKey )
 import Database.Groundhog.TH (
+  defaultCodegenConfig,
   groundhog,
   mkPersist )
 import Test.Tasty ( TestTree, testGroup )
@@ -33,171 +32,180 @@ 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(..), run_dbmigrate )
+import TSN.XmlImport ( XmlImport(..) )
+import Xml ( FromXml(..), pickle_unpickle, unpickleable )
 
 
 
--- | The database type for teams as they show up in the news.  We need
---   this separate from its XML representation because of the
---   DefaultKey pointing to a message. We don't know how to create one
---   of those unless we've just inserted a message into the database,
---   so it screws up pickling.
+-- | The database type for teams as they show up in the news.
 data NewsTeam =
-  NewsTeam {
-    nt_news_id :: DefaultKey Message, -- ^ foreign key.
-    db_team_name :: String }
-deriving instance Eq NewsTeam  -- Standalone instances necessary for
-deriving instance Show NewsTeam  -- Groundhog types with DefaultKeys
-
--- | The XML type for teams as they show up in the news. See
---   'NewsTeam' for why there are two types.
-data NewsTeamXml =
-  NewsTeamXml {
-    xml_team_name :: String }
+  NewsTeam { team_name :: String }
   deriving (Eq, Show)
 
--- | Specify how to convert between the two representations NewsTeam
---   (database) and NewsTeamXml (XML).
-instance ToFromXml NewsTeam where
-  type Xml NewsTeam = NewsTeamXml
-  type Container NewsTeam = Message
-  -- Use a record wildcard here so GHC doesn't complain that we never
-  -- 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"
-  -- unless we're handed one.
-  from_xml_fk key = (NewsTeam key) . xml_team_name
-
-
--- | The database type for locations as they show up in the news.  We
---   need this separate from its XML representation because of the
---   DefaultKey pointing to a message. We don't know how to create one
---   of those unless we've just inserted a message into the database,
---   so it screws up pickling.
+instance FromXml NewsTeam where
+  type Db NewsTeam = NewsTeam
+  from_xml = id
+
+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 }
+
+-- | The database type for locations as they show up in the news.
 data NewsLocation =
   NewsLocation {
-    loc_news_id :: DefaultKey Message, -- ^ foreign key.
-    db_city ::String,
-    db_state :: String,
-    db_country :: String }
-deriving instance Eq NewsLocation -- Standalone instances necessary for
-deriving instance Show NewsLocation -- Groundhog types with DefaultKeys
-
--- | The XML type for locations as they show up in the news. See
---   'NewsLocation' for why there are two types.
-data NewsLocationXml =
-  NewsLocationXml {
-    xml_city :: String,
-    xml_state :: String,
-    xml_country :: String }
+    city :: Maybe String,
+    state :: Maybe String,
+    country :: String }
   deriving (Eq, Show)
 
+instance FromXml NewsLocation where
+  type Db NewsLocation = NewsLocation
+  from_xml = id
+
+instance XmlImport NewsLocation
+
 
--- | Specify how to convert between the two representations
---   NewsLocation (database) and NewsLocationXml (XML).
-instance ToFromXml NewsLocation where
-  type Xml NewsLocation = NewsLocationXml
-  type Container NewsLocation = Message
-  -- Use a record wildcard here so GHC doesn't complain that we never
-  -- 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"
-  -- unless we're given one.
-  from_xml_fk key (NewsLocationXml x y z) = NewsLocation key x y z
+-- | 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 }
 
 
 -- | The msg_id child of <message> contains an event_id attribute; we
---   embed it into the 'Message' type. We (pointlessly) use the "db_"
+--   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.
 data MsgId =
   MsgId {
     db_msg_id       :: Int,
     db_event_id     :: Maybe Int }
-  deriving (Eq, Show)
+  deriving (Data, Eq, Show, Typeable)
 
 
-data MessageXml =
-  MessageXml {
+data Message =
+  Message {
     xml_xml_file_id :: Int,
     xml_heading :: String,
     xml_mid :: MsgId,
     xml_category :: String,
     xml_sport :: String,
     xml_url :: String,
-    xml_teams :: [NewsTeamXml],
-    xml_locations :: [NewsLocationXml],
+    xml_teams :: [NewsTeam],
+    xml_locations :: [NewsLocation],
     xml_sms :: String,
-    xml_text :: String,
-    xml_continue :: 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)
 
-data Message =
-  Message {
+data News =
+  News {
     db_mid :: MsgId,
     db_sport :: String,
     db_url :: String,
     db_sms :: String,
-    db_text :: String,
-    db_continue :: String }
-  deriving (Eq, Show)
+    db_editor :: Maybe String,
+    db_text :: Maybe String,
+    db_continue :: Maybe String }
+  deriving (Data, Eq, Show, Typeable)
 
-instance ToFromXml Message where
-  type Xml Message = MessageXml
-  type Container Message = ()
-
-  -- Use a record wildcard here so GHC doesn't complain that we never
-  -- used our named fields.
-  to_xml (Message {..}) =
-    MessageXml
-      0
-      ""
-      db_mid
-      ""
-      db_sport
-      db_url
-      []
-      []
-      db_sms
-      db_text
-      db_continue
-      ""
+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 (MessageXml _ _ c _ e f _ _ g h i _) =
-    Message c e f g h i
+  from_xml (Message _ _ c _ e f _ _ i j k l _) =
+    News c e f i j k l
 
+instance XmlImport Message
 
-mkPersist tsn_codegen_config [groundhog|
+instance DbImport Message where
+  dbmigrate _ =
+    run_dbmigrate $ do
+      migrate (undefined :: NewsTeam)
+      migrate (undefined :: NewsLocation)
+      migrate (undefined :: News)
+      migrate (undefined :: News_NewsTeam)
+      migrate (undefined :: News_NewsLocation)
+
+  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 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
+    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]
+
+|]
 
-- entity: Message
+mkPersist tsn_codegen_config [groundhog|
+- entity: News
   dbName: news
   constructors:
-    - name: Message
+    - name: News
       fields:
         - name: db_mid
           embeddedType:
@@ -209,27 +217,34 @@ mkPersist tsn_codegen_config [groundhog|
       dbName: msg_id
     - name: db_event_id
       dbName: event_id
+
+
+- entity: News_NewsTeam
+  dbName: news__news_teams
+
+- entity: News_NewsLocation
+  dbName: news__news_locations
 |]
 
-pickle_news_team :: PU NewsTeamXml
+pickle_news_team :: PU NewsTeam
 pickle_news_team =
   xpElem "team" $
     xpWrap (from_string, to_string) xpText
   where
-    to_string :: NewsTeamXml -> String
-    to_string = xml_team_name
+    to_string :: NewsTeam -> String
+    to_string = team_name
 
-    from_string :: String -> NewsTeamXml
-    from_string = NewsTeamXml
+    from_string :: String -> NewsTeam
+    from_string = NewsTeam
 
-instance XmlPickler NewsTeamXml where
+instance XmlPickler NewsTeam where
   xpickle = pickle_news_team
 
 pickle_msg_id :: PU MsgId
 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)
@@ -237,40 +252,41 @@ pickle_msg_id =
 instance XmlPickler MsgId where
   xpickle = pickle_msg_id
 
-pickle_location :: PU NewsLocationXml
+pickle_location :: PU NewsLocation
 pickle_location =
   xpElem "location" $
     xpWrap (from_tuple, to_tuple) $
-    xpTriple (xpElem "city" xpText)
-             (xpElem "state" xpText)
+    xpTriple (xpOption (xpElem "city" xpText))
+             (xpOption (xpElem "state" xpText))
              (xpElem "country" xpText)
   where
     from_tuple =
-      uncurryN NewsLocationXml
-    to_tuple l = (xml_city l, xml_state l, xml_country l)
+      uncurryN NewsLocation
+    to_tuple l = (city l, state l, country l)
 
-instance XmlPickler NewsLocationXml where
+instance XmlPickler NewsLocation where
   xpickle = pickle_location
 
 
-pickle_message :: PU MessageXml
+pickle_message :: PU Message
 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)
               (xpElem "sport" xpText)
               (xpElem "url" xpText)
-              (xpList $ pickle_news_team)
-              (xpList $ pickle_location)
+              (xpList pickle_news_team)
+              (xpList pickle_location)
               (xpElem "SMS" xpText)
-              (xpElem "text" xpText)
+              (xpOption (xpElem "Editor" xpText))
+              (xpOption (xpElem "text" xpText))
               pickle_continue
               (xpElem "time_stamp" xpText)
   where
-    from_tuple = uncurryN MessageXml
+    from_tuple = uncurryN Message
     to_tuple m = (xml_xml_file_id m,
                   xml_heading m,
                   xml_mid m,
@@ -280,15 +296,17 @@ pickle_message =
                   xml_teams m,
                   xml_locations m,
                   xml_sms m,
+                  xml_editor m,
                   xml_text m,
                   xml_continue m,
                   xml_time_stamp m)
 
-    pickle_continue :: PU String
+    pickle_continue :: PU (Maybe String)
     pickle_continue =
-      xpWrap (to_string, from_string) $
-        xpElem "continue" $
-          (xpList $ xpElem "P" xpText)
+      xpOption $
+        xpWrap (to_string, from_string) $
+          xpElem "continue" $
+            xpList (xpElem "P" xpText)
       where
         from_string :: String -> [String]
         from_string = split "\n"
@@ -296,46 +314,66 @@ pickle_message =
         to_string :: [String] -> String
         to_string = join "\n"
 
-instance XmlPickler MessageXml where
+instance XmlPickler Message where
   xpickle = pickle_message
 
 
 
-instance DbImport Message where
-  dbimport _ xml = do
-    runMigration defaultMigrationLogger $ do
-      migrate (undefined :: Message)
-      migrate (undefined :: NewsTeam)
-      migrate (undefined :: NewsLocation)
-    let root_element = unpickleDoc xpickle xml :: Maybe MessageXml
-    case root_element of
-      Nothing -> do
-        let errmsg = "Could not unpickle News message in dbimport."
-        liftIO $ report_error errmsg
-        return Nothing
-      Just message  -> do
-        news_id <- insert (from_xml message :: Message)
-        let nts :: [NewsTeam] = map (from_xml_fk news_id)
-                                    (xml_teams message)
-        let nlocs :: [NewsLocation] = map (from_xml_fk news_id)
-                                          (xml_locations message)
-        nt_ids <- mapM insert nts
-        loc_ids <- mapM insert nlocs
-
-        return $ Just (1 + (length nt_ids) + (length loc_ids))
-
-
 -- * Tasty Tests
 news_tests :: TestTree
 news_tests =
   testGroup
     "News tests"
-    [ test_pickle_of_unpickle_is_identity ]
+    [ test_news_fields_have_correct_names,
+      test_pickle_of_unpickle_is_identity,
+      test_unpickle_succeeds ]
 
 
+test_news_fields_have_correct_names :: TestTree
+test_news_fields_have_correct_names =
+  testCase "news fields get correct database names" $
+    mapM_ check (zip actual expected)
+  where
+    -- This is cool, it uses the (derived) Data instance of
+    -- News.News to get its constructor names.
+    field_names :: [String]
+    field_names =
+      constrFields . head $ dataTypeConstrs $ dataTypeOf (undefined :: News)
+
+    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"]
+
+    check (x,y) = (x @?= y)
+
+
+-- | Warning, succeess of this test does not mean that unpickling
+--   succeeded.
 test_pickle_of_unpickle_is_identity :: TestTree
-test_pickle_of_unpickle_is_identity =
-  testCase "pickle composed with unpickle is the identity" $ do
-    let path = "test/xml/newsxml.xml"
-    (expected :: [MessageXml], actual) <- pickle_unpickle "message" path
-    actual @?= expected
+test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
+  [ check "pickle composed with unpickle is the identity"
+          "test/xml/newsxml.xml",
+
+    check "pickle composed with unpickle is the identity (with Editor)"
+          "test/xml/newsxml-with-editor.xml" ]
+  where
+    check desc path = testCase desc $ do
+      (expected, actual) <- pickle_unpickle pickle_message path
+      actual @?= expected
+
+
+test_unpickle_succeeds :: TestTree
+test_unpickle_succeeds = testGroup "unpickle tests"
+  [ check "unpickling succeeds"
+          "test/xml/newsxml.xml",
+
+    check "unpickling succeeds (with Editor)"
+          "test/xml/newsxml-with-editor.xml" ]
+  where
+    check desc path = testCase desc $ do
+      actual <- unpickleable path pickle_message
+      let expected = True
+      actual @?= expected