-- 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 )
-- 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)
data JFileGameStatus =
JFileGameStatus {
db_status_numeral :: Int,
- db_status :: String }
+ db_status :: Maybe String }
deriving (Eq, Show)
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,
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,
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,
-- 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
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|
- {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}
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
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 =
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
projects / dead / htsn-import.git / blobdiff