Minor comment fix.

[dead/htsn-import.git] / src / TSN / XML / EarlyLine.hs

diff --git a/src/TSN/XML/EarlyLine.hs b/src/TSN/XML/EarlyLine.hs
index f4a24d89bb0be57473118985227e29df3b36cc5b..3870eb8d139b59a009fcc58c0cceb746cbaa54e7 100644 (file)
--- 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,12 +49,18 @@ import Text.XML.HXT.Core (
 
 -- Local imports.
 import TSN.Codegen ( tsn_codegen_config )
-import TSN.DbImport ( DbImport(..) )
-import TSN.Picklers ( xp_time_stamp )
+import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
+import TSN.Picklers (
+  xp_ambiguous_time,
+  xp_early_line_date,
+  xp_time_stamp )
 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.
@@ -162,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|
@@ -244,7 +293,7 @@ pickle_date :: PU EarlyLineDateXml
 pickle_date =
   xpElem "date" $
     xpWrap (from_tuple, to_tuple) $
-    xpTriple (xpAttr "value" undefined)
+    xpTriple (xpAttr "value" xp_early_line_date)
              (xpElem "note" xpText)
              pickle_game
   where
@@ -256,7 +305,7 @@ pickle_game :: PU EarlyLineGameXml
 pickle_game =
   xpElem "game" $
     xpWrap (from_tuple, to_tuple) $
-    xp4Tuple (xpElem "time" undefined)
+    xp4Tuple (xpElem "time" xp_ambiguous_time)
              pickle_away_team
              pickle_home_team
              (xpElem "over_under" xpText)
@@ -270,10 +319,10 @@ pickle_game =
 
 
 pickle_away_team :: PU EarlyLineGameTeam
-pickle_away_team = xpElem "teamA" $ pickle_team
+pickle_away_team = xpElem "teamA" pickle_team
 
 pickle_home_team :: PU EarlyLineGameTeam
-pickle_home_team = xpElem "teamH" $ pickle_team
+pickle_home_team = xpElem "teamH" pickle_team
 
 pickle_team :: PU EarlyLineGameTeam
 pickle_team =
@@ -284,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