{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
+-- | Parse TSN XML for the DTD \"earlylineXML.dtd\". Each \<message\>
+-- element contains a bunch of \<date\>s, and those \<date\>s
+-- contain a single \<game\>. 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,
-- Local imports.
import TSN.Codegen ( tsn_codegen_config )
-import TSN.DbImport ( DbImport(..) )
+import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
import TSN.Picklers (
xp_ambiguous_time,
xp_early_line_date,
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.
xml_category :: String,
xml_sport :: String,
xml_title :: String,
- xml_dates :: [EarlyLineDateXml],
+ xml_dates :: [EarlyLineDate],
xml_time_stamp :: UTCTime }
deriving (Eq, Show)
--- * EarlyLineDateXml
+-- * EarlyLineDate
-- | XML representation of a \<date\>. 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)
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 <date>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|
--
-- * Pickling
--
+
+
+-- | Pickler for the top-level 'Message'.
+--
pickle_message :: PU Message
pickle_message =
xpElem "message" $
xml_dates m,
xml_time_stamp m)
-pickle_date :: PU EarlyLineDateXml
+
+-- | Pickler for the \<date\> elements within each \<message\>.
+--
+pickle_date :: PU EarlyLineDate
pickle_date =
xpElem "date" $
xpWrap (from_tuple, to_tuple) $
(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 \<game\> element within each \<date\>.
+--
pickle_game :: PU EarlyLineGameXml
pickle_game =
xpElem "game" $
+-- | Pickle an away team (\<teamA\>) element within a \<game\>. 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 (\<teamH\>) element within a \<game\>. 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 \<teamA\> and
+-- \<teamH\> elements.
+--
pickle_team :: PU EarlyLineGameTeam
pickle_team =
xpWrap (from_tuple, to_tuple) $
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
projects / dead / htsn-import.git / blobdiff