X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FEarlyLine.hs;h=3870eb8d139b59a009fcc58c0cceb746cbaa54e7;hb=6ddadf57fcafa71709c6b8db565f71725b58b3e1;hp=26625e748b2dec6d769ea0be068c5b9b3962b644;hpb=253d9c8dc02a342aaba98459b6b6cc811ddc7724;p=dead%2Fhtsn-import.git

diff --git a/src/TSN/XML/EarlyLine.hs b/src/TSN/XML/EarlyLine.hs
index 26625e7..3870eb8 100644
--- a/src/TSN/XML/EarlyLine.hs
+++ b/src/TSN/XML/EarlyLine.hs
@@ -8,18 +8,32 @@
 module TSN.XML.EarlyLine (
   dtd,
   pickle_message,
+  -- * Tests
+  early_line_tests,
   -- * WARNING: these are private but exported to silence warnings
   EarlyLineConstructor(..),
   EarlyLineGameConstructor(..) )
 where
 
 -- System imports.
+import Control.Monad ( forM_ )
 import Data.Time ( UTCTime(..) )
 import Data.Tuple.Curry ( uncurryN )
+import Database.Groundhog (
+  countAll,
+  deleteAll,
+  insert_,
+  migrate,
+  runMigration,
+  silentMigrationLogger )
 import Database.Groundhog.Core ( DefaultKey )
+import Database.Groundhog.Generic ( runDbConn )
+import Database.Groundhog.Sqlite ( withSqliteConn )
 import Database.Groundhog.TH (
   groundhog,
   mkPersist )
+import Test.Tasty ( TestTree, testGroup )
+import Test.Tasty.HUnit ( (@?=), testCase )
 import Text.XML.HXT.Core (
   PU,
   xp4Tuple,
@@ -35,7 +49,7 @@ import Text.XML.HXT.Core (
 
 -- Local imports.
 import TSN.Codegen ( tsn_codegen_config )
-import TSN.DbImport ( DbImport(..) )
+import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
 import TSN.Picklers (
   xp_ambiguous_time,
   xp_early_line_date,
@@ -43,7 +57,10 @@ import TSN.Picklers (
 import TSN.XmlImport ( XmlImport(..) )
 import Xml (
   FromXml(..),
-  ToDb(..) )
+  ToDb(..),
+  pickle_unpickle,
+  unpickleable,
+  unsafe_unpickle )
 
 
 -- | The DTD to which this module corresponds. Used to invoke dbimport.
@@ -165,13 +182,42 @@ data EarlyLineGameTeam =
   deriving (Eq, Show)
 
 
+date_to_game :: (DefaultKey EarlyLine) -> EarlyLineDateXml -> EarlyLineGame
+date_to_game fk date =
+  EarlyLineGame {
+    db_early_lines_id = fk,
+    db_game_time = combined_date_time,
+    db_note = (xml_note date),
+    db_away_team = xml_away_team (xml_game date),
+    db_home_team = xml_home_team (xml_game date),
+    db_over_under = xml_over_under (xml_game date) }
+  where
+    date_part = xml_date_value date
+    time_part = xml_game_time (xml_game date)
+    combined_date_time = UTCTime (utctDay date_part) (utctDayTime time_part)
+
 --
 -- * Database stuff
 --
 
 instance DbImport Message where
-  dbmigrate = undefined
-  dbimport = undefined
+  dbmigrate _ =
+    run_dbmigrate $ do
+      migrate (undefined :: EarlyLine)
+      migrate (undefined :: EarlyLineGame)
+
+  dbimport m = do
+    -- Insert the message and obtain its ID.
+    msg_id <- insert_xml m
+
+    -- Now loop through the message's <date>s.
+    forM_ (xml_dates m) $ \date -> do
+      -- Each date only contains one game, so we convert the date to a
+      -- game and then insert the game (keyed to the message).
+      let game = date_to_game msg_id date
+      insert_ game
+
+    return ImportSucceeded
 
 
 mkPersist tsn_codegen_config [groundhog|
@@ -287,3 +333,68 @@ pickle_team =
   where
     from_tuple = uncurryN EarlyLineGameTeam
     to_tuple m = (db_rotation_number m, db_line m, db_team_name m)
+
+
+
+--
+-- * Tasty Tests
+--
+
+-- | A list of all tests for this module.
+--
+early_line_tests :: TestTree
+early_line_tests =
+  testGroup
+    "EarlyLine tests"
+    [ test_on_delete_cascade,
+      test_pickle_of_unpickle_is_identity,
+      test_unpickle_succeeds ]
+
+-- | If we unpickle something and then pickle it, we should wind up
+--   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
+test_pickle_of_unpickle_is_identity =
+  testCase "pickle composed with unpickle is the identity" $ do
+    let path = "test/xml/earlylineXML.xml"
+    (expected, actual) <- pickle_unpickle pickle_message path
+    actual @?= expected
+
+
+
+-- | Make sure we can actually unpickle these things.
+--
+test_unpickle_succeeds :: TestTree
+test_unpickle_succeeds =
+  testCase "unpickling succeeds" $ do
+    let path = "test/xml/earlylineXML.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 early_lines deletes its children" $ do
+    let path = "test/xml/earlylineXML.xml"
+    results <- unsafe_unpickle path pickle_message
+    let a = undefined :: EarlyLine
+    let b = undefined :: EarlyLineGame
+
+    actual <- withSqliteConn ":memory:" $ runDbConn $ do
+                runMigration silentMigrationLogger $ do
+                  migrate a
+                  migrate b
+                _ <- dbimport results
+                deleteAll a
+                count_a <- countAll a
+                count_b <- countAll b
+                return $ sum [count_a, count_b]
+    let expected = 0
+    actual @?= expected