Update all silent migrations for groundhog-0.7.

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

diff --git a/src/TSN/XML/GameInfo.hs b/src/TSN/XML/GameInfo.hs
index 2b5e1adb9ed3b45ad803a26479811088ab5099e6..3062f5a2b79a1d826a649ccc4c5cba7c9b98fe08 100644 (file)
--- a/src/TSN/XML/GameInfo.hs
+++ b/src/TSN/XML/GameInfo.hs
@@ -26,10 +26,8 @@ import Data.Time.Clock ( UTCTime )
 import Database.Groundhog (
   countAll,
   insert_,
-  migrate,
-  runMigration,
-  silentMigrationLogger )
-import Database.Groundhog.Generic ( runDbConn )
+  migrate )
+import Database.Groundhog.Generic ( runDbConn, runMigrationSilent )
 import Database.Groundhog.Sqlite ( withSqliteConn )
 import Database.Groundhog.TH (
   defaultCodegenConfig,
@@ -46,7 +44,10 @@ import TSN.DbImport (
   ImportResult(..),
   run_dbmigrate )
 import TSN.Parse (
+  ParseError,
+  parse_game_id,
   parse_message,
+  parse_schedule_id,
   parse_xmlfid,
   parse_xml_time_stamp )
 import Xml ( unsafe_read_document )
@@ -84,10 +85,24 @@ dtds =
 -- | This serves as both the database and XML representation of a
 --   GameInfo \<message\>.
 --
+--   The 'game_id' and 'schedule_id' fields are foreign keys, but they
+--   key into multiple tables and key on records which may not exist
+--   when we import the GameInfo document. We therefore don't declare
+--   them as foreign keys; i.e. we don't require them to point
+--   anywhere in particular. But if they do, that's nice.
+--
 data GameInfo =
   GameInfo {
     dtd :: String,
     xml_file_id :: Int,
+    game_id :: Maybe Int, -- ^ These are optional because they are missing
+                          --   from at least the MLB_Matchup_XML.dtd documents.
+                          --   They provide foreign keys into any tables storing
+                          --   games with their IDs.
+
+    schedule_id :: Maybe Int, -- ^ Optional key into any table storing a
+                              --   schedule along with its ID. We've noticed
+                              --   them missing in e.g. recapxml.dtd documents.
     time_stamp :: UTCTime,
     xml :: String }
   deriving (Eq, Show)
@@ -96,15 +111,23 @@ data GameInfo =
 -- | Attempt to parse a 'GameInfo' from an 'XmlTree'. If we cannot,
 --   we fail with an error message.
 --
-parse_xml :: String -> XmlTree -> Either String GameInfo
+parse_xml :: String -> XmlTree -> Either ParseError GameInfo
 parse_xml dtdname xmltree = do
   xmlfid <- parse_xmlfid xmltree
+  game_id <- parse_game_id xmltree
+  schedule_id <- parse_schedule_id xmltree
   timestamp <- parse_xml_time_stamp xmltree
   message <- parse_message xmltree
-  return $ GameInfo dtdname (fromInteger xmlfid) timestamp (xshow [message])
+  return $ GameInfo
+             dtdname
+             xmlfid
+             game_id
+             schedule_id
+             timestamp
+             (xshow [message])
 
 --
--- Database code
+-- * Database code
 --
 
 instance DbImport GameInfo where
@@ -163,10 +186,14 @@ test_accessors = testCase "we can access a parsed game_info" $ do
   let ex2 = 21201550
   let a3  = show $ time_stamp t
   let ex3 = "2014-05-31 15:13:00 UTC"
-  let a4  = take 9 (xml t)
-  let ex4 = "<message>"
-  let actual = (a1,a2,a3,a4)
-  let expected = (ex1,ex2,ex3,ex4)
+  let a4  = game_id t
+  let ex4  = Just 39978
+  let a5  = schedule_id t
+  let ex5  = Just 39978
+  let a6  = take 9 (xml t)
+  let ex6 = "<message>"
+  let actual = (a1,a2,a3,a4,a5,a6)
+  let expected = (ex1,ex2,ex3,ex4,ex5,ex6)
   actual @?= expected
 
 
@@ -205,7 +232,7 @@ test_dbimport_succeeds = testCase "dbimport succeeds" $ do
   xmltrees <- mapM unsafe_read_document game_info_test_files
   let msgs = rights $ map (parse_xml "dummy") xmltrees
   actual <- withSqliteConn ":memory:" $ runDbConn $ do
-                runMigration silentMigrationLogger $
+                runMigrationSilent $
                   migrate (undefined :: GameInfo)
                 mapM_ dbimport msgs
                 countAll (undefined :: GameInfo)