X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FEarlyLine.hs;h=4ad9ae2ca0a5f1bc59c9d0b3bb60b71f13f8fa5d;hb=16d86e7a3c1eda08b91752f92510a1de0b952a17;hp=627238f92bfbf280eb02b764be45f20c6b0fff5d;hpb=1c101735be50ddbef397bcb67882562ab2c506e4;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/EarlyLine.hs b/src/TSN/XML/EarlyLine.hs index 627238f..4ad9ae2 100644 --- a/src/TSN/XML/EarlyLine.hs +++ b/src/TSN/XML/EarlyLine.hs @@ -5,21 +5,40 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +-- | Parse TSN XML for the DTD \"earlylineXML.dtd\". Each \ +-- element contains a bunch of \s, and those \s +-- contain a single \. In the database, we merge the date +-- info into the games, and key the games to the messages. +-- 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 +54,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. @@ -80,7 +105,7 @@ data Message = xml_category :: String, xml_sport :: String, xml_title :: String, - xml_dates :: [EarlyLineDateXml], + xml_dates :: [EarlyLineDate], xml_time_stamp :: UTCTime } deriving (Eq, Show) @@ -115,18 +140,18 @@ instance XmlImport Message --- * EarlyLineDateXml +-- * EarlyLineDate -- | XML representation of a \. It has a \"value\" attribute -- containing the actual date string. As children it contains a -- (non-optional) note, and a game. The note and date value are -- properties of the game as far as I can tell. -- -data EarlyLineDateXml = - EarlyLineDateXml { - xml_date_value :: UTCTime, - xml_note :: String, - xml_game :: EarlyLineGameXml } +data EarlyLineDate = + EarlyLineDate { + date_value :: UTCTime, + date_note :: String, + date_game :: EarlyLineGameXml } deriving (Eq, Show) @@ -162,13 +187,51 @@ data EarlyLineGameTeam = deriving (Eq, Show) +-- | Convert an 'EarlyLineDate' into an 'EarlyLineGame'. Each date has +-- exactly one game, and the fields that belong to the date should +-- really be in the game anyway. So the database representation of a +-- game has the combined fields of the XML date/game. +-- +-- This function gets the game out of a date, and then sticks the +-- date value and note inside the game. It also adds the foreign key +-- reference to the game's parent message, and returns the result. +-- +date_to_game :: (DefaultKey EarlyLine) -> EarlyLineDate -> EarlyLineGame +date_to_game fk date = + EarlyLineGame { + db_early_lines_id = fk, + db_game_time = combined_date_time, + db_note = (date_note date), + db_away_team = xml_away_team (date_game date), + db_home_team = xml_home_team (date_game date), + db_over_under = xml_over_under (date_game date) } + where + date_part = date_value date + time_part = xml_game_time (date_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 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| @@ -219,6 +282,10 @@ mkPersist tsn_codegen_config [groundhog| -- -- * Pickling -- + + +-- | Pickler for the top-level 'Message'. +-- pickle_message :: PU Message pickle_message = xpElem "message" $ @@ -240,23 +307,29 @@ pickle_message = xml_dates m, xml_time_stamp m) -pickle_date :: PU EarlyLineDateXml + +-- | Pickler for the \ elements within each \. +-- +pickle_date :: PU EarlyLineDate 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 - from_tuple = uncurryN EarlyLineDateXml - to_tuple m = (xml_date_value m, xml_note m, xml_game m) + from_tuple = uncurryN EarlyLineDate + to_tuple m = (date_value m, date_note m, date_game m) + +-- | Pickler for the \ element within each \. +-- 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) @@ -269,12 +342,26 @@ pickle_game = +-- | Pickle an away team (\) element within a \. Most +-- of the work (common with the home team pickler) is done by +-- 'pickle_team'. +-- pickle_away_team :: PU EarlyLineGameTeam pickle_away_team = xpElem "teamA" pickle_team + +-- | Pickle a home team (\) element within a \. Most +-- of the work (common with theaway team pickler) is done by +-- 'pickle_team'. +-- pickle_home_team :: PU EarlyLineGameTeam pickle_home_team = xpElem "teamH" pickle_team + +-- | Team pickling common to both 'pickle_away_team' and +-- 'pickle_home_team'. Handles everything inside the \ and +-- \ elements. +-- pickle_team :: PU EarlyLineGameTeam pickle_team = xpWrap (from_tuple, to_tuple) $ @@ -284,3 +371,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