X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FGameInfo.hs;h=b7c4c5b4562a0ed57ba4118840ad6c60b631beb8;hb=a6e096bbac16cc51dbf2d5417e90b7efd03a3b7d;hp=e9c1899a71d044d96907423d1c42fa2d03d2db69;hpb=42ec3c34b0b041d4bd5a529264a1f3f0758c1776;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/GameInfo.hs b/src/TSN/XML/GameInfo.hs index e9c1899..b7c4c5b 100644 --- a/src/TSN/XML/GameInfo.hs +++ b/src/TSN/XML/GameInfo.hs @@ -13,33 +13,46 @@ -- module TSN.XML.GameInfo ( dtds, + game_info_tests, parse_xml, -- * WARNING: these are private but exported to silence warnings GameInfoConstructor(..) ) where -- System imports. +import Data.Either ( rights ) +import Data.String.Utils ( replace ) import Data.Time.Clock ( UTCTime ) -import Database.Groundhog ( migrate ) +import Database.Groundhog ( + countAll, + insert_, + migrate, + runMigration, + silentMigrationLogger ) +import Database.Groundhog.Generic ( runDbConn ) +import Database.Groundhog.Sqlite ( withSqliteConn ) import Database.Groundhog.TH ( + defaultCodegenConfig, groundhog, mkPersist ) +import Test.Tasty ( TestTree, testGroup ) +import Test.Tasty.HUnit ( (@?=), testCase ) import Text.XML.HXT.Core ( XmlTree ) import Text.XML.HXT.DOM.ShowXml ( xshow ) -- Local imports. -import TSN.Codegen ( tsn_codegen_config ) -import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) +import TSN.DbImport ( + DbImport(..), + ImportResult(..), + run_dbmigrate ) import TSN.Parse ( parse_message, parse_xmlfid, parse_xml_time_stamp ) -import TSN.XmlImport ( XmlImport(..) ) -import Xml ( - FromXml(..), - ToDb(..) ) +import Xml ( unsafe_read_document ) --- | The DTDs for everything that we consider "Game Info." + +-- | The DTDs for everything that we consider \"Game Info.\" -- -- TODO: This is the list from the old implementation. We need to -- make sure that we are really receiving XML for these DTDs @@ -47,103 +60,156 @@ import Xml ( -- dtds :: [String] dtds = - [ "CBASK_Lineup_XML.dtd", -- missing DTD - "cbaskpreviewxml.dtd", -- missing DTD - "cflpreviewxml.dtd", -- missing DTD - "Matchup_NBA_NHL_XML.dtd", -- missing DTD + [ "CBASK_Lineup_XML.dtd", + "cbaskpreviewxml.dtd", + "cflpreviewxml.dtd", + "Matchup_NBA_NHL_XML.dtd", "mlbpreviewxml.dtd", "MLB_Gaming_Matchup_XML.dtd", - "MLB.dtd", -- missing DTD "MLB_Lineup_XML.dtd", "MLB_Matchup_XML.dtd", "MLS_Preview_XML.dtd", "NBA_Gaming_Matchup_XML.dtd", - "NBA.dtd", -- missing DTD "NBA_Playoff_Matchup_XML.dtd", "NBALineupXML.dtd", "nbapreviewxml.dtd", - "NCAA_FB_Preview_XML.dtd", -- missing DTD - "nflpreviewxml.dtd", -- missing DTD - "NFL_NCAA_FB_Matchup_XML.dtd", -- missing DTD + "NCAA_FB_Preview_XML.dtd", + "nflpreviewxml.dtd", + "NFL_NCAA_FB_Matchup_XML.dtd", "nhlpreviewxml.dtd", "recapxml.dtd", - "WorldBaseballPreviewXML.dtd" -- missing DTD - ] + "WorldBaseballPreviewXML.dtd" ] --- | XML representation of a GameInfo \. +-- | This serves as both the database and XML representation of a +-- GameInfo \. -- -data Message = - Message { - xml_dtd :: String, - xml_xml_file_id :: Int, - xml_time_stamp :: UTCTime, - xml_xml :: String } +data GameInfo = + GameInfo { + dtd :: String, + xml_file_id :: Int, + time_stamp :: UTCTime, + xml :: String } deriving (Eq, Show) --- | Attempt to parse a 'Message' from an 'XmlTree'. If we cannot, +-- | Attempt to parse a 'GameInfo' from an 'XmlTree'. If we cannot, -- we fail with an error message. -- -parse_xml :: String -> XmlTree -> Either String Message +parse_xml :: String -> XmlTree -> Either String GameInfo parse_xml dtdname xmltree = do xmlfid <- parse_xmlfid xmltree timestamp <- parse_xml_time_stamp xmltree message <- parse_message xmltree - return $ Message dtdname (fromInteger xmlfid) timestamp (xshow [message]) - - --- | Database representation of a 'Message'. --- -data GameInfo = - GameInfo { - db_dtd :: String, - db_xml_file_id :: Int, - db_time_stamp :: UTCTime, - db_xml :: String } - - -instance ToDb Message where - -- | The database analogue of a 'Message' is an 'GameInfo'. - type Db Message = GameInfo - -instance FromXml Message where - -- | The XML to DB conversion is trivial here. - -- - from_xml Message{..} = GameInfo { - db_dtd = xml_dtd, - db_xml_file_id = xml_xml_file_id, - db_time_stamp = xml_time_stamp, - db_xml = xml_xml } - - --- | This allows us to insert the XML representation 'Message' --- directly. --- -instance XmlImport Message - + return $ GameInfo dtdname (fromInteger xmlfid) timestamp (xshow [message]) -- -- Database code -- -instance DbImport Message where +instance DbImport GameInfo where dbmigrate _ = run_dbmigrate $ migrate (undefined :: GameInfo) - -- | We import a 'Message' by inserting the whole thing at + -- | We import a 'GameInfo' by inserting the whole thing at -- once. Nothing fancy going on here. dbimport msg = do - insert_xml_ msg + insert_ msg return ImportSucceeded -mkPersist tsn_codegen_config [groundhog| + +-- | The database schema for GameInfo is trivial; all we need is for +-- the XML_File_ID to be unique. +-- +mkPersist defaultCodegenConfig [groundhog| - entity: GameInfo + dbName: game_info constructors: - name: GameInfo uniques: - name: unique_game_info type: constraint # Prevent multiple imports of the same message. - fields: [db_xml_file_id] + fields: [xml_file_id] |] + + +-- +-- Tasty Tests +-- + +-- | A list of all tests for this module. +-- +game_info_tests :: TestTree +game_info_tests = + testGroup + "GameInfo tests" + [ test_accessors, + test_parse_xml_succeeds, + test_dbimport_succeeds ] + + +-- | Make sure the accessors work and that we can parse one file. Ok, +-- so the real point of this is to make the unused fields (dtd, xml, +-- ...) warning go away without having to mangle the groundhog code. +-- +test_accessors :: TestTree +test_accessors = testCase "we can access a parsed game_info" $ do + xmltree <- unsafe_read_document "test/xml/gameinfo/recapxml.xml" + let Right t = parse_xml "recapxml.dtd" xmltree + let a1 = dtd t + let ex1 = "recapxml.dtd" + let a2 = xml_file_id t + let ex2 = 21201550 + let a3 = show $ time_stamp t + let ex3 = "2014-05-31 20:13:00 UTC" + let a4 = take 9 (xml t) + let ex4 = "" + let actual = (a1,a2,a3,a4) + let expected = (ex1,ex2,ex3,ex4) + actual @?= expected + + +-- | Sample XML documents for GameInfo types. +-- +game_info_test_files :: [FilePath] +game_info_test_files = + map (change_suffix . add_path) dtds + where + add_path = ("test/xml/gameinfo/" ++ ) + change_suffix = replace ".dtd" ".xml" + +-- | Make sure we can parse every element of 'game_info_test_files'. +-- +test_parse_xml_succeeds :: TestTree +test_parse_xml_succeeds = + testGroup "parse_xml" $ map check game_info_test_files + where + check t = testCase t $ do + x <- unsafe_read_document t + let result = parse_xml "dummy" x + let actual = case result of -- isRight appears in base-4.7 + Left _ -> False + Right _ -> True + let expected = True + actual @?= expected + + +-- | Ensure that each element of 'game_info_test_files' can be imported +-- by counting the total number of database records (after +-- importing) and comparing it against the length of +-- 'game_info_test_files'. +-- +test_dbimport_succeeds :: TestTree +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 $ + migrate (undefined :: GameInfo) + mapM_ dbimport msgs + countAll (undefined :: GameInfo) + + actual @?= expected + where + expected = length game_info_test_files