X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FWeather.hs;h=6df3ce37615cfa48ba28cc028fb355a90dcbbb1d;hb=b2c39ebe5ff9c1ea3224231df5078c52d0ad8737;hp=3773b312bc021af4a78a97b93c85db4f02e736b4;hpb=f6c65520e560a354899d780cf311674a3e00f009;p=dead%2Fhtsn-import.git

diff --git a/src/TSN/XML/Weather.hs b/src/TSN/XML/Weather.hs
index 3773b31..6df3ce3 100644
--- a/src/TSN/XML/Weather.hs
+++ b/src/TSN/XML/Weather.hs
@@ -5,18 +5,17 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 
--- | Parse TSN XML for the DTD "weatherxml.dtd". Each document
---   contains a bunch of forecasts, which each contain one league, and
---   that league contains a bunch of listings.
+-- | Parse TSN XML for the DTD \"weatherxml.dtd\". Each document
+--   contains a bunch of forecasts, which each contain zero or more
+--   leagues, which in turn (each) contain a bunch of listings.
 --
 module TSN.XML.Weather (
+  dtd,
   pickle_message,
   -- * Tests
   weather_tests,
   -- * WARNING: these are private but exported to silence warnings
-  Weather_WeatherForecastConstructor(..),
   WeatherConstructor(..),
-  WeatherForecast_WeatherForecastListingConstructor(..),
   WeatherForecastConstructor(..),
   WeatherForecastListingConstructor(..) )
 where
@@ -26,9 +25,15 @@ import Control.Monad ( forM_ )
 import Data.Time ( UTCTime )
 import Data.Tuple.Curry ( uncurryN )
 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 (
   groundhog,
   mkPersist )
@@ -50,91 +55,145 @@ import Text.XML.HXT.Core (
 import TSN.Codegen (
   tsn_codegen_config )
 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
-import TSN.Picklers ( xp_gamedate )
-import TSN.XmlImport ( XmlImport(..) )
-import Xml ( FromXml(..), pickle_unpickle, unpickleable )
+import TSN.Picklers ( xp_gamedate, xp_time_stamp )
+import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
+import Xml (
+  Child(..),
+  FromXml(..),
+  FromXmlFk(..),
+  ToDb(..),
+  pickle_unpickle,
+  unpickleable,
+  unsafe_unpickle )
 
 
 
--- | Database/XML representation of a weather forecast listing.
+-- | The DTD to which this module corresponds. Used to invoke dbimport.
+--
+dtd :: String
+dtd = "weatherxml.dtd"
+
+
+--
+-- DB/XML Data types
+--
+
+-- * WeatherForecastListing/WeatherForecastListingXml
+
+-- | XML representation of a weather forecast listing.
+--
+data WeatherForecastListingXml =
+  WeatherForecastListingXml {
+    xml_teams :: String,
+    xml_weather :: String }
+  deriving (Eq, Show)
+
+
+-- | Database representation of a weather forecast listing. The
+--   'db_league_name' field should come from the containing \<league\>
+--   element which is not stored in the database.
 --
 data WeatherForecastListing =
   WeatherForecastListing {
+    db_weather_forecasts_id :: DefaultKey WeatherForecast,
+    db_league_name :: Maybe String,
     db_teams :: String,
     db_weather :: String }
-  deriving (Eq, Show)
 
--- | This is needed to define the XmlImport instance for
--- 'WeatherForecastListing'; it basically says that the DB
--- representation is the same as the XML representation.
---
-instance FromXml WeatherForecastListing where
-  type Db WeatherForecastListing = WeatherForecastListing
-  from_xml = id
 
--- | Allows us to call 'insert_xml' on the XML representation of
---   WeatherForecastListing.
+-- | We don't make 'WeatherForecastListingXml' an instance of
+--   'FromXmlFk' because it needs some additional information, namely
+--   the league name from its containing \<league\> element.
+--
+--   When supplied with a forecast id and a league name, this will
+--   turn an XML listing into a database one.
 --
-instance XmlImport WeatherForecastListing
+from_xml_fk_league :: DefaultKey WeatherForecast
+                   -> (Maybe String)
+                   -> WeatherForecastListingXml
+                   -> WeatherForecastListing
+from_xml_fk_league fk ln WeatherForecastListingXml{..} =
+    WeatherForecastListing {
+      db_weather_forecasts_id = fk,
+      db_league_name = ln,
+      db_teams = xml_teams,
+      db_weather = xml_weather }
 
 
+-- * WeatherLeague
+
 -- | XML representation of a league, as they appear in the weather
 --   documents. There is no associated database representation because
 --   the league element really adds no information besides its own
---   (usually empty) name. Since there's exactly one league per
---   forecast, we just store the league_name in the database
---   representation of a forecast.
+--   (usually empty) name. The leagues contain listings, so we
+--   associate the league name with each listing instead.
 --
 data WeatherLeague =
   WeatherLeague {
-    league_name     :: Maybe String,
-    listings :: [WeatherForecastListing] }
+    league_name :: Maybe String,
+    listings    :: [WeatherForecastListingXml] }
   deriving (Eq, Show)
 
 
+-- * WeatherForecast/WeatherForecastXml
+
 -- | Database representation of a weather forecast.
 --
 data WeatherForecast =
   WeatherForecast {
-    db_game_date :: UTCTime,
-    db_league_name :: Maybe String }
+    db_weather_id :: DefaultKey Weather,
+    db_game_date :: UTCTime }
 
--- | XML representation of a weather forecast. It would have been
---   cleaner to omit the 'WeatherLeague' middleman, but having it
---   simplifies parsing.
+
+-- | XML representation of a weather forecast.
 --
 data WeatherForecastXml =
   WeatherForecastXml {
     xml_game_date :: UTCTime,
-    xml_league :: WeatherLeague }
+    xml_leagues :: [WeatherLeague] }
   deriving (Eq, Show)
 
 
-instance FromXml WeatherForecastXml where
+instance ToDb WeatherForecastXml where
   -- | The database representation of a 'WeatherForecastXml' is a
   --   'WeatherForecast'.
   --
   type Db WeatherForecastXml = WeatherForecast
 
+
+instance Child WeatherForecastXml where
+  -- | The database type containing a 'WeatherForecastXml' is
+  --   'Weather'.
+  type Parent WeatherForecastXml = Weather
+
+
+instance FromXmlFk WeatherForecastXml where
+
   -- | To convert a 'WeatherForecastXml' into a 'WeatherForecast', we
-  --   replace the 'WeatherLeague' with its name.
+  --   just copy everything verbatim.
   --
-  from_xml WeatherForecastXml{..} =
-    WeatherForecast { db_game_date   = xml_game_date,
-                      db_league_name = (league_name xml_league) }
+  from_xml_fk fk WeatherForecastXml{..} =
+    WeatherForecast {
+      db_weather_id  = fk,
+      db_game_date   = xml_game_date }
+
 
 -- | This allows us to call 'insert_xml' on an 'WeatherForecastXml'
 --   without first converting it to the database representation.
 --
-instance XmlImport WeatherForecastXml
+instance XmlImportFk WeatherForecastXml
+
 
+-- * Weather/Message
 
 -- | The database representation of a weather message.
 --
 data Weather =
   Weather {
+    db_xml_file_id :: Int,
     db_sport :: String,
-    db_title :: String }
+    db_title :: String,
+    db_time_stamp :: UTCTime }
 
 
 -- | The XML representation of a weather message.
@@ -147,76 +206,63 @@ data Message =
     xml_sport :: String,
     xml_title :: String,
     xml_forecasts :: [WeatherForecastXml],
-    xml_time_stamp :: String }
+    xml_time_stamp :: UTCTime }
   deriving (Eq, Show)
 
-
-instance FromXml Message where
+instance ToDb Message where
   -- | The database representation of 'Message' is 'Weather'.
   --
   type Db Message = Weather
 
+instance FromXml Message where
   -- | To get a 'Weather' from a 'Message', we drop a bunch of
   --   unwanted fields.
   --
   from_xml Message{..} =
     Weather {
+      db_xml_file_id = xml_xml_file_id,
       db_sport = xml_sport,
-      db_title = xml_title }
+      db_title = xml_title,
+      db_time_stamp = xml_time_stamp }
 
--- | This allows us to call 'insert_xml' on a 'Message' without first
---   converting it to the database representation.
+-- | This allows us to insert the XML representation 'Message'
+--   directly.
 --
 instance XmlImport Message
 
 
--- | A mapping between 'Weather' objects and their children
---   'WeatherForecast's.
 --
-data Weather_WeatherForecast =
-  Weather_WeatherForecast
-    (DefaultKey Weather)
-    (DefaultKey WeatherForecast)
-
--- | A mapping between 'WeatherForecast' objects and their children
---   'WeatherForecastListing's.
+-- Database stuff
 --
-data WeatherForecast_WeatherForecastListing =
-  WeatherForecast_WeatherForecastListing
-    (DefaultKey WeatherForecast)
-    (DefaultKey WeatherForecastListing)
 
 mkPersist tsn_codegen_config [groundhog|
 - entity: Weather
+  constructors:
+    - name: Weather
+      uniques:
+        - name: unique_weather
+          type: constraint
+          # Prevent multiple imports of the same message.
+          fields: [db_xml_file_id]
 
 - entity: WeatherForecast
   dbName: weather_forecasts
-
-- entity: WeatherForecastListing
-  dbName: weather_forecast_listings
-
-- entity: Weather_WeatherForecast
-  dbName: weather__weather_forecasts
   constructors:
-    - name: Weather_WeatherForecast
+    - name: WeatherForecast
       fields:
-        - name: weather_WeatherForecast0 # Default created by mkNormalFieldName
-          dbName: weather_id
-        - name: weather_WeatherForecast1 # Default created by mkNormalFieldName
-          dbName: weather_forecasts_id
+        - name: db_weather_id
+          reference:
+            onDelete: cascade
 
-- entity: WeatherForecast_WeatherForecastListing
-  dbName: weather_forecasts__weather_forecast_listings
+- entity: WeatherForecastListing
+  dbName: weather_forecast_listings
   constructors:
-    - name: WeatherForecast_WeatherForecastListing
+    - name: WeatherForecastListing
       fields:
-        # Default by mkNormalFieldName
-        - name: weatherForecast_WeatherForecastListing0
-          dbName: weather_forecasts_id
+        - name: db_weather_forecasts_id
+          reference:
+            onDelete: cascade
 
-         # Default by mkNormalFieldName
-        - name: weatherForecast_WeatherForecastListing1
-          dbName: weather_forecast_listings_id
 |]
 
 
@@ -226,35 +272,38 @@ instance DbImport Message where
       migrate (undefined :: Weather)
       migrate (undefined :: WeatherForecast)
       migrate (undefined :: WeatherForecastListing)
-      migrate (undefined :: Weather_WeatherForecast)
-      migrate (undefined :: WeatherForecast_WeatherForecastListing)
 
   dbimport m = do
-    -- The weather database schema has a nice linear structure. First
-    -- we insert the top-level weather record.
+    -- First we insert the top-level weather record.
     weather_id <- insert_xml m
 
     -- Next insert all of the forecasts, one at a time.
     forM_ (xml_forecasts m) $ \forecast -> do
-      forecast_id <- insert_xml forecast
+      forecast_id <- insert_xml_fk weather_id forecast
 
-      -- Map this forecast to its parent weather record.
-      insert_ (Weather_WeatherForecast weather_id forecast_id)
+      -- With the forecast id in hand, loop through this forecast's
+      -- leagues...
+      forM_ (xml_leagues forecast) $ \league -> do
+        -- Construct the function that converts an XML listing to a
+        -- database one.
+        let todb = from_xml_fk_league forecast_id (league_name league)
 
-      -- Insert all of this forecast's listings.
-      forM_ (listings $ xml_league forecast) $ \listing -> do
-        listing_id <- insert_xml listing
+        -- Now use it to convert all of the XML listings.
+        let db_listings = map todb (listings league)
 
-        -- Map this listing to its parent forecast.
-        insert_ $ WeatherForecast_WeatherForecastListing forecast_id listing_id
+        -- And finally, insert those DB listings.
+        mapM_ insert_ db_listings
 
     return ImportSucceeded
 
 
+---
+--- Pickling
+---
 
--- | Pickler to convert a 'WeatherForecastListing' to/from XML.
+-- | Pickler to convert a 'WeatherForecastListingXml' to/from XML.
 --
-pickle_listing :: PU WeatherForecastListing
+pickle_listing :: PU WeatherForecastListingXml
 pickle_listing =
   xpElem "listing" $
     xpWrap (from_pair, to_pair) $
@@ -262,8 +311,8 @@ pickle_listing =
         (xpElem "teams" xpText)
         (xpElem "weather" xpText)
   where
-    from_pair = uncurry WeatherForecastListing
-    to_pair WeatherForecastListing{..} = (db_teams, db_weather)
+    from_pair = uncurry WeatherForecastListingXml
+    to_pair WeatherForecastListingXml{..} = (xml_teams, xml_weather)
 
 
 -- | Pickler to convert a 'WeatherLeague' to/from XML.
@@ -288,11 +337,11 @@ pickle_forecast =
     xpWrap (from_pair, to_pair) $
       xpPair
         (xpAttr "gamedate" xp_gamedate)
-        pickle_league
+        (xpList pickle_league)
   where
     from_pair = uncurry WeatherForecastXml
     to_pair WeatherForecastXml{..} = (xml_game_date,
-                                      xml_league)
+                                      xml_leagues)
 
 
 
@@ -309,7 +358,7 @@ pickle_message =
         (xpElem "sport" xpText)
         (xpElem "title" xpText)
         (xpList pickle_forecast)
-        (xpElem "time_stamp" xpText)
+        (xpElem "time_stamp" xp_time_stamp)
   where
     from_tuple = uncurryN Message
     to_tuple Message{..} = (xml_xml_file_id,
@@ -328,7 +377,8 @@ weather_tests :: TestTree
 weather_tests =
   testGroup
     "Weather tests"
-    [ test_pickle_of_unpickle_is_identity,
+    [ test_on_delete_cascade,
+      test_pickle_of_unpickle_is_identity,
       test_unpickle_succeeds ]
 
 
@@ -349,7 +399,33 @@ test_pickle_of_unpickle_is_identity =
 test_unpickle_succeeds :: TestTree
 test_unpickle_succeeds =
   testCase "unpickling succeeds" $ do
-  let path = "test/xml/weatherxml.xml"
-  actual <- unpickleable path pickle_message
-  let expected = True
-  actual @?= expected
+    let path = "test/xml/weatherxml.xml"
+    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 =
+  testCase "deleting weather deletes its children" $ do
+    let path = "test/xml/weatherxml.xml"
+    weather <- unsafe_unpickle path pickle_message
+    let a = undefined :: Weather
+    let b = undefined :: WeatherForecast
+    let c = undefined :: WeatherForecastListing
+    actual <- withSqliteConn ":memory:" $ runDbConn $ do
+                runMigration silentMigrationLogger $ do
+                  migrate a
+                  migrate b
+                  migrate c
+                _ <- dbimport weather
+                deleteAll a
+                count_a <- countAll a
+                count_b <- countAll b
+                count_c <- countAll c
+                return $ count_a + count_b + count_c
+    let expected = 0
+    actual @?= expected