From: Michael Orlitzky Date: Fri, 27 Jun 2014 19:54:48 +0000 (-0400) Subject: Write the database code for TSN.XML.JFile. X-Git-Tag: 0.0.6~63 X-Git-Url: http://gitweb.michael.orlitzky.com/?p=dead%2Fhtsn-import.git;a=commitdiff_plain;h=5b051a15402e5ebbe4e388265dbf8cef6c31df6f Write the database code for TSN.XML.JFile. Add tests for TSN.XML.JFile. Enable JFile import in Main. Fixup the shell test expected output. Simplify the big case statement (guard) in Main. --- diff --git a/src/Main.hs b/src/Main.hs index 0b6dce6..38f3930 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -57,6 +57,7 @@ import qualified TSN.XML.Injuries as Injuries ( dtd, pickle_message ) import qualified TSN.XML.InjuriesDetail as InjuriesDetail ( dtd, pickle_message ) +import qualified TSN.XML.JFile as JFile ( dtd, pickle_message ) import qualified TSN.XML.News as News ( dtd, pickle_message ) import qualified TSN.XML.Odds as Odds ( dtd, pickle_message ) import qualified TSN.XML.Scores as Scores ( dtd, pickle_message ) @@ -163,41 +164,41 @@ import_file cfg path = do -- migrate_and_import m = dbmigrate m >> dbimport m + -- | The error message we return if unpickling fails. + -- + errmsg = "Could not unpickle " ++ dtd ++ "." + + -- | Try to migrate and import using the given pickler @f@; + -- if it works, return the result. Otherwise, return an + -- 'ImportFailed' along with our error message. + -- + go f = maybe + (return $ ImportFailed errmsg) + migrate_and_import + (unpickleDoc f xml) + importer - | dtd == AutoRacingResults.dtd = do - let m = unpickleDoc AutoRacingResults.pickle_message xml - maybe (return $ ImportFailed errmsg) migrate_and_import m + | dtd == AutoRacingResults.dtd = + go AutoRacingResults.pickle_message - | dtd == AutoRacingSchedule.dtd = do - let m = unpickleDoc AutoRacingSchedule.pickle_message xml - maybe (return $ ImportFailed errmsg) migrate_and_import m + | dtd == AutoRacingSchedule.dtd = + go AutoRacingSchedule.pickle_message - -- GameInfo and SportInfo appear least in the guards - | dtd == Injuries.dtd = do - let m = unpickleDoc Injuries.pickle_message xml - maybe (return $ ImportFailed errmsg) migrate_and_import m + -- GameInfo and SportInfo appear last in the guards + | dtd == Injuries.dtd = go Injuries.pickle_message - | dtd == InjuriesDetail.dtd = do - let m = unpickleDoc InjuriesDetail.pickle_message xml - maybe (return $ ImportFailed errmsg) migrate_and_import m + | dtd == InjuriesDetail.dtd = go InjuriesDetail.pickle_message + | dtd == JFile.dtd = go JFile.pickle_message - | dtd == News.dtd = do - let m = unpickleDoc News.pickle_message xml - maybe (return $ ImportFailed errmsg) migrate_and_import m + | dtd == News.dtd = go News.pickle_message - | dtd == Odds.dtd = do - let m = unpickleDoc Odds.pickle_message xml - maybe (return $ ImportFailed errmsg) migrate_and_import m + | dtd == Odds.dtd = go Odds.pickle_message - | dtd == Scores.dtd = do - let m = unpickleDoc Scores.pickle_message xml - maybe (return $ ImportFailed errmsg) migrate_and_import m + | dtd == Scores.dtd = go Scores.pickle_message - -- SportInfo and GameInfo appear least in the guards - | dtd == Weather.dtd = do - let m = unpickleDoc Weather.pickle_message xml - maybe (return $ ImportFailed errmsg) migrate_and_import m + -- SportInfo and GameInfo appear last in the guards + | dtd == Weather.dtd = go Weather.pickle_message | dtd `elem` GameInfo.dtds = do let either_m = GameInfo.parse_xml dtd xml @@ -220,8 +221,6 @@ import_file cfg path = do "Unrecognized DTD in " ++ path ++ ": " ++ dtd ++ "." return $ ImportUnsupported infomsg - where - errmsg = "Could not unpickle " ++ dtd ++ "." -- | Entry point of the program. It twiddles some knobs for diff --git a/src/TSN/XML/JFile.hs b/src/TSN/XML/JFile.hs index 2eed37f..5642c89 100644 --- a/src/TSN/XML/JFile.hs +++ b/src/TSN/XML/JFile.hs @@ -12,48 +12,76 @@ -- a message contains a bunch of games. -- module TSN.XML.JFile ( - dtd ) + dtd, + pickle_message, + -- * Tests + jfile_tests, + -- * WARNING: these are private but exported to silence warnings + JFileConstructor(..), + JFileGameConstructor(..), + JFileGame_TeamConstructor(..) ) where -- System imports +import Control.Monad ( forM_ ) +import Data.List ( intercalate ) +import Data.String.Utils ( split ) import Data.Time ( UTCTime(..) ) import Data.Tuple.Curry ( uncurryN ) -import Database.Groundhog ( migrate ) +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, xpTriple, xp6Tuple, - xp7Tuple, - xp8Tuple, - xp10Tuple, xp14Tuple, + xp19Tuple, xpAttr, xpElem, xpInt, xpList, xpOption, xpPair, + xpPrim, xpText, + xpText0, xpWrap ) -- Local imports import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) -import TSN.Picklers ( xp_date_padded, xp_time, xp_time_stamp ) +import TSN.Picklers ( + xp_date, + xp_date_padded, + xp_datetime, + xp_time, + xp_time_dots, + xp_time_stamp ) import TSN.Team ( Team(..) ) import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) ) - import Xml ( FromXml(..), FromXmlFk(..), - ToDb(..) ) + ToDb(..), + pickle_unpickle, + unpickleable, + unsafe_unpickle ) @@ -192,22 +220,25 @@ instance XmlImport JFileGameHomeTeamXml -- measure, but in the conversion to the database type, we can drop -- all of the redundant information. -- +-- All of these are optional because TSN does actually leave the +-- whole thing empty from time to time. +-- data JFileGameOddsInfo = JFileGameOddsInfo { - db_list_date :: UTCTime, - db_home_team_id :: String, -- redundant (Team) - db_away_team_id :: String, -- redundant (Team) - db_home_abbr :: String, -- redundant (Team) - db_away_abbr :: String, -- redundant (Team) - db_home_team_name :: String, -- redundant (Team) - db_away_team_name :: String, -- redundant (Team) - db_home_starter :: String, - db_away_starter :: String, - db_game_date :: UTCTime, -- redundant (JFileGame) - db_home_game_key :: Int, - db_away_game_key :: Int, - db_current_timestamp :: UTCTime, - db_live :: Bool, + db_list_date :: Maybe UTCTime, + db_home_team_id :: Maybe String, -- redundant (Team) + db_away_team_id :: Maybe String, -- redundant (Team) + db_home_abbr :: Maybe String, -- redundant (Team) + db_away_abbr :: Maybe String, -- redundant (Team) + db_home_team_name :: Maybe String, -- redundant (Team) + db_away_team_name :: Maybe String, -- redundant (Team) + db_home_starter :: Maybe String, + db_away_starter :: Maybe String, + db_game_date :: Maybe UTCTime, -- redundant (JFileGame) + db_home_game_key :: Maybe Int, + db_away_game_key :: Maybe Int, + db_current_timestamp :: Maybe UTCTime, + db_live :: Maybe Bool, db_notes :: String } deriving (Eq, Show) @@ -219,7 +250,7 @@ data JFileGameOddsInfo = data JFileGameStatus = JFileGameStatus { db_status_numeral :: Int, - db_status :: String } + db_status :: Maybe String } deriving (Eq, Show) @@ -235,7 +266,7 @@ data JFileGame = db_game_id :: Int, db_schedule_id :: Int, db_odds_info :: JFileGameOddsInfo, - db_season_type :: String, + db_season_type :: Maybe String, db_game_time :: UTCTime, db_vleague :: Maybe String, db_hleague :: Maybe String, @@ -256,7 +287,7 @@ data JFileGameXml = xml_game_id :: Int, xml_schedule_id :: Int, xml_odds_info :: JFileGameOddsInfo, - xml_season_type :: String, + xml_season_type :: Maybe String, xml_game_date :: UTCTime, xml_game_time :: UTCTime, xml_vteam :: JFileGameAwayTeamXml, @@ -306,7 +337,7 @@ instance FromXmlFk JFileGameXml where db_schedule_id = xml_schedule_id, db_odds_info = xml_odds_info, db_season_type = xml_season_type, - db_game_time = xml_game_time, + db_game_time = make_game_time xml_game_date xml_game_time, db_vleague = xml_vleague, db_hleague = xml_hleague, db_vscore = xml_vscore, @@ -318,8 +349,7 @@ instance FromXmlFk JFileGameXml where -- date/time. Simply take the day part from one and the time -- from the other. -- - make_game_time d Nothing = d - make_game_time d (Just t) = UTCTime (utctDay d) (utctDayTime t) + make_game_time d t = UTCTime (utctDay d) (utctDayTime t) -- | This allows us to insert the XML representation @@ -351,7 +381,31 @@ instance DbImport Message where migrate (undefined :: JFileGame) migrate (undefined :: JFileGame_Team) - dbimport m = return ImportSucceeded + dbimport m = do + -- Insert the top-level message + msg_id <- insert_xml m + + -- Now loop through the message's games + forM_ (xml_games $ xml_gamelist m) $ \game -> do + + -- Next, we insert the home and away teams. We do this before + -- inserting the game itself because the game has two foreign keys + -- pointing to "teams". + away_team_id <- insert_xml_or_select (xml_vteam game) + home_team_id <- insert_xml_or_select (xml_hteam game) + + game_id <- insert_xml_fk msg_id game + + -- Insert a record into jfile_games__teams mapping the + -- home/away teams to this game. Use the full record syntax + -- because the types would let us mix up the home/away teams. + insert_ JFileGame_Team { + jgt_jfile_games_id = game_id, + jgt_away_team_id = away_team_id, + jgt_home_team_id = home_team_id } + + + return ImportSucceeded mkPersist tsn_codegen_config [groundhog| @@ -405,7 +459,7 @@ mkPersist tsn_codegen_config [groundhog| - {name: home_starter, dbName: home_starter} - {name: away_starter, dbName: away_starter} - {name: home_game_key, dbName: home_game_key} - - {name: away_game_key, dbName: home_game_key} + - {name: away_game_key, dbName: away_game_key} - {name: current_timestamp, dbName: current_timestamp} - {name: live, dbName: live} - {name: notes, dbName: notes} @@ -475,7 +529,7 @@ pickle_game = xp14Tuple (xpElem "game_id" xpInt) (xpElem "schedule_id" xpInt) pickle_odds_info - (xpElem "seasontype" xpText) + (xpElem "seasontype" (xpOption xpText)) (xpElem "Game_Date" xp_date_padded) (xpElem "Game_Time" xp_time) pickle_away_team @@ -503,8 +557,67 @@ pickle_game = xml_time_remaining m, xml_game_status m) -pickle_odds_info = undefined - +pickle_odds_info :: PU JFileGameOddsInfo +pickle_odds_info = + xpElem "Odds_Info" $ + xpWrap (from_tuple, to_tuple) $ + xp19Tuple (xpElem "ListDate" (xpOption xp_date)) + (xpElem "HomeTeamID" (xpOption xpText)) + (xpElem "AwayTeamID" (xpOption xpText)) + (xpElem "HomeAbbr" (xpOption xpText)) + (xpElem "AwayAbbr" (xpOption xpText)) + (xpElem "HomeTeamName" (xpOption xpText)) + (xpElem "AwayTeamName" (xpOption xpText)) + (xpElem "HStarter" (xpOption xpText)) + (xpElem "AStarter" (xpOption xpText)) + (xpElem "GameDate" (xpOption xp_datetime)) + (xpElem "HGameKey" (xpOption xpInt)) + (xpElem "AGameKey" (xpOption xpInt)) + (xpElem "CurrentTimeStamp" (xpOption xp_time_dots)) + (xpElem "Live" (xpOption xpPrim)) + (xpElem "Notes1" xpText0) + (xpElem "Notes2" xpText0) + (xpElem "Notes3" xpText0) + (xpElem "Notes4" xpText0) + (xpElem "Notes5" xpText0) + where + from_tuple (x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,n1,n2,n3,n4,n5) = + JFileGameOddsInfo x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 notes + where + notes = intercalate "\n" [n1,n2,n3,n4,n5] + + to_tuple o = (db_list_date o, + db_home_team_id o, + db_away_team_id o, + db_home_abbr o, + db_away_abbr o, + db_home_team_name o, + db_away_team_name o, + db_home_starter o, + db_away_starter o, + db_game_date o, + db_home_game_key o, + db_away_game_key o, + db_current_timestamp o, + db_live o, + n1,n2,n3,n4,n5) + where + note_lines = split "\n" (db_notes o) + n1 = case note_lines of + (notes1:_) -> notes1 + _ -> "" + n2 = case note_lines of + (_:notes2:_) -> notes2 + _ -> "" + n3 = case note_lines of + (_:_:notes3:_) -> notes3 + _ -> "" + n4 = case note_lines of + (_:_:_:notes4:_) -> notes4 + _ -> "" + n5 = case note_lines of + (_:_:_:_:notes5:_) -> notes5 + _ -> "" pickle_home_team :: PU JFileGameHomeTeamXml pickle_home_team = @@ -539,8 +652,80 @@ pickle_status = xpElem "status" $ xpWrap (from_tuple, to_tuple) $ xpPair (xpAttr "numeral" xpInt) - xpText + (xpOption xpText) where from_tuple = uncurry JFileGameStatus to_tuple s = (db_status_numeral s, db_status s) + + + +-- +-- Tasty Tests +-- + +-- | A list of all tests for this module. +-- +jfile_tests :: TestTree +jfile_tests = + testGroup + "JFile 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/jfilexml.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/jfilexml.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 auto_racing_results deletes its children" $ do + let path = "test/xml/jfilexml.xml" + results <- unsafe_unpickle path pickle_message + let a = undefined :: Team + let b = undefined :: JFile + let c = undefined :: JFileGame + let d = undefined :: JFileGame_Team + + actual <- withSqliteConn ":memory:" $ runDbConn $ do + runMigration silentMigrationLogger $ do + migrate a + migrate b + migrate c + migrate d + _ <- dbimport results + deleteAll b + count_a <- countAll a + count_b <- countAll b + count_c <- countAll c + count_d <- countAll d + return $ sum [count_a, count_b, count_c, count_d] + let expected = 20 -- Twenty teams should be left over + actual @?= expected diff --git a/test/TestSuite.hs b/test/TestSuite.hs index e0e86a9..a67ee2a 100644 --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -6,6 +6,7 @@ import TSN.XML.GameInfo ( game_info_tests ) import TSN.XML.Heartbeat ( heartbeat_tests ) import TSN.XML.Injuries ( injuries_tests ) import TSN.XML.InjuriesDetail ( injuries_detail_tests ) +import TSN.XML.JFile ( jfile_tests ) import TSN.XML.News ( news_tests ) import TSN.XML.Odds ( odds_tests ) import TSN.XML.Scores ( scores_tests ) @@ -21,6 +22,7 @@ tests = testGroup heartbeat_tests, injuries_tests, injuries_detail_tests, + jfile_tests, news_tests, odds_tests, scores_tests, diff --git a/test/shell/import-duplicates.test b/test/shell/import-duplicates.test index b262b82..7dac44f 100644 --- a/test/shell/import-duplicates.test +++ b/test/shell/import-duplicates.test @@ -15,15 +15,15 @@ rm -f shelltest.sqlite3 # Heartbeat.xml that doesn't really count. find ./test/xml -maxdepth 1 -name '*.xml' | wc -l >>> -17 +18 >>>= 0 # Run the imports again; we should get complaints about the duplicate -# xml_file_ids. There are 2 errors for each violation, so we expect 2*16 +# xml_file_ids. There are 2 errors for each violation, so we expect 2*17 # occurrences of the string 'ERROR'. ./dist/build/htsn-import/htsn-import -c 'shelltest.sqlite3' test/xml/*.xml 2>&1 | grep ERROR | wc -l >>> -32 +34 >>>= 0 # Finally, clean up after ourselves. diff --git a/test/xml/jfilexml.dtd b/test/xml/jfilexml.dtd new file mode 100644 index 0000000..8b841fd --- /dev/null +++ b/test/xml/jfilexml.dtd @@ -0,0 +1,47 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/test/xml/jfilexml.xml b/test/xml/jfilexml.xml new file mode 100644 index 0000000..87c8514 --- /dev/null +++ b/test/xml/jfilexml.xml @@ -0,0 +1 @@ + 21321128 BC-AAJ JFILE MLB 40293 40293 6/23/2014 008 014 PHI MIA Philadelphia Miami R.Hernandez N.Eovaldi 6/23/2014 7:05:00 PM 902 901 11:30 A.M. True Regular 06/23/2014 07:05 PM Miami NL Philadelphia NL 0 0 7:05 PM 40294 40294 6/23/2014 002 003 CHC CIN Chicago Cubs Cincinnati J.Samardzija A.Simon 6/23/2014 8:05:00 PM 904 903 11:30 A.M. True Regular 06/23/2014 08:05 PM Cincinnati NL Chicago Cubs NL 0 0 8:05 PM 40295 40295 6/23/2014 034 006 MIL WAS Milwaukee Washington M.Garza G.Gonzalez 6/23/2014 8:10:00 PM 906 905 11:30 A.M. True Regular 06/23/2014 08:10 PM Washington NL Milwaukee NL 0 0 8:10 PM 40297 40297 6/23/2014 013 012 COL STL Colorado St. Louis J.Chacin L.Lynn 6/23/2014 8:40:00 PM 908 907 11:30 A.M. True Regular 06/23/2014 08:40 PM St. Louis NL Colorado NL 0 0 8:40 PM 40296 40296 6/23/2014 011 010 SFG SDP San Francisco San Diego M.Cain O.Despaigne 6/23/2014 10:15:00 PM 910 909 11:30 A.M. True Regular 06/23/2014 10:15 PM San Diego NL San Francisco NL 0 0 10:15 PM 40287 40287 6/23/2014 027 030 BAL CWS Baltimore Chicago WSox W.Chen C.Sale 6/23/2014 7:05:00 PM 914 913 11:30 A.M. True Regular 06/23/2014 07:05 PM Chicago WSox AL Baltimore AL 0 0 7:05 PM 40289 40289 6/23/2014 040 036 TOR NYY Toronto NY Yankees M.Stroman C.Whitley 6/23/2014 7:07:00 PM 912 911 11:30 A.M. True Regular 06/23/2014 07:07 PM NY Yankees AL Toronto AL 0 0 7:07 PM 40291 40291 6/23/2014 038 028 SEA BOS Seattle Boston F.Hernandez J.Lackey 6/23/2014 10:10:00 PM 916 915 11:30 A.M. True Regular 06/23/2014 10:10 PM Boston AL Seattle AL 0 0 10:10 PM 40288 40288 6/23/2014 056 009 TAM PIT Tampa Bay Pittsburgh A.Cobb E.Volquez 6/23/2014 7:10:00 PM 918 917 11:30 A.M. True Regular 06/23/2014 07:10 PM Pittsburgh NL Tampa Bay AL 0 0 7:10 PM 40292 40292 6/23/2014 033 005 KAN LOS Kansas City Los Angeles J.Guthrie Z.Greinke 6/23/2014 8:10:00 PM 920 919 11:30 A.M. True Regular 06/23/2014 08:10 PM Los Angeles NL Kansas City AL 0 0 8:10 PM June 23, 2014, at 12:10 PM ET \ No newline at end of file