{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -- | Parse TSN XML for the DTD \"Schedule_Changes_XML.dtd\". Each -- \ element contains zero or more \ -- which are just a wrapper around zero or more \s. -- -- The teams appear to use the shared "TSN.Team" representation. -- module TSN.XML.ScheduleChanges ( dtd, pickle_message, -- * Tests schedule_changes_tests, -- * WARNING: these are private but exported to silence warnings ScheduleChangesConstructor(..), ScheduleChangesListingConstructor(..) ) where -- System imports. import Control.Monad ( forM_ ) import Data.Time ( UTCTime(..) ) import Data.Tuple.Curry ( uncurryN ) import qualified Data.Vector.HFixed as H ( HVector, convert ) import Database.Groundhog ( countAll, deleteAll, insert_, migrate ) import Database.Groundhog.Core ( DefaultKey ) import Database.Groundhog.Generic ( runDbConn, runMigrationSilent ) import Database.Groundhog.Sqlite ( withSqliteConn ) import Database.Groundhog.TH ( groundhog, mkPersist ) import qualified GHC.Generics as GHC ( Generic ) import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) import Text.XML.HXT.Core ( PU, xp6Tuple, xp11Tuple, xpAttr, xpElem, xpInt, xpList, xpOption, xpPair, xpText, xpWrap ) -- Local imports. import TSN.Codegen ( tsn_codegen_config ) import TSN.Database ( insert_or_select ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) import TSN.Picklers ( xp_date_padded, xp_tba_time, xp_time_stamp ) import TSN.Team ( Team(..), HTeam(..), VTeam(..) ) import TSN.XmlImport ( XmlImport(..) ) import Xml ( FromXml(..), ToDb(..), pickle_unpickle, unpickleable, unsafe_unpickle ) -- | The DTD to which this module corresponds. Used to invoke -- 'dbimport'. -- dtd :: String dtd = "Schedule_Changes_XML.dtd" -- -- DB/XML data types -- -- * ScheduleChanges/Message -- | Database representation of a 'Message'. Comparatively, it lacks -- the listings since they are linked via a foreign key. -- data ScheduleChanges = ScheduleChanges { db_xml_file_id :: Int, db_heading :: String, db_category :: String, db_sport :: String, db_time_stamp :: UTCTime } deriving (Eq, Show) -- | XML representation of a \ within a -- \. These are wrappers around a bunch of -- \s, but they also contain the sport name for all of -- the contained listings. -- data ScheduleChangeXml = ScheduleChangeXml { xml_sc_sport :: String, xml_sc_listings :: [ScheduleChangesListingXml] } deriving (Eq, GHC.Generic, Show) -- | For 'H.convert'. -- instance H.HVector ScheduleChangeXml -- | XML representation of a 'ScheduleChanges'. It has the same -- fields, but in addition contains the 'xml_listings'. -- data Message = Message { xml_xml_file_id :: Int, xml_heading :: String, xml_category :: String, xml_sport :: String, xml_schedule_changes :: [ScheduleChangeXml], xml_time_stamp :: UTCTime } deriving (Eq, GHC.Generic, Show) -- | For 'H.convert'. -- instance H.HVector Message instance ToDb Message where -- | The database analogue of a 'Message' is a 'ScheduleChanges'. -- type Db Message = ScheduleChanges -- | The 'FromXml' instance for 'Message' is required for the -- 'XmlImport' instance. -- instance FromXml Message where -- | To convert a 'Message' to an 'ScheduleChanges', we just drop -- the 'xml_schedule_changes'. -- from_xml Message{..} = ScheduleChanges { db_xml_file_id = xml_xml_file_id, db_heading = xml_heading, db_category = xml_category, db_sport = xml_sport, db_time_stamp = xml_time_stamp } -- | This allows us to insert the XML representation 'Message' -- directly. -- instance XmlImport Message -- * ScheduleChangesListing/ScheduleChangesListingXml -- | An embedded type within 'ScheduleChangesListing'. These look -- like, \FINAL\ within the XML, -- but they're in one-to-one correspondence with the listings. -- -- The leading underscores prevent unused field warnings. -- data ScheduleChangesListingStatus = ScheduleChangesListingStatus { _db_status_numeral :: Int, _db_status :: Maybe String } -- Yes, they can be empty. deriving (Eq, GHC.Generic, Show) -- | For 'H.convert'. -- instance H.HVector ScheduleChangesListingStatus -- | Database representation of a \ contained within a -- \, within a \. During the transition -- to the database, we drop the intermediate \ -- leaving the listing keyed to the 'ScheduleChanges' itself. -- -- The home/away teams reuse the 'Team' representation. -- -- The sport name (sc_sport) is pulled out of the containing -- \ and embedded into the listings themselves. -- data ScheduleChangesListing = ScheduleChangesListing { db_schedule_changes_id :: DefaultKey ScheduleChanges, db_away_team_id :: DefaultKey Team, db_home_team_id ::DefaultKey Team, db_type :: String, db_sc_sport :: String, db_schedule_id :: Int, db_game_time :: UTCTime, db_location :: Maybe String, db_vscore :: Int, db_hscore :: Int, db_listing_status :: ScheduleChangesListingStatus, db_notes :: Maybe String } -- | XML representation of a \ contained within a -- \, within a \. -- data ScheduleChangesListingXml = ScheduleChangesListingXml { xml_type :: String, xml_schedule_id :: Int, xml_game_date :: UTCTime, xml_game_time :: Maybe UTCTime, xml_location :: Maybe String, xml_away_team :: VTeam, xml_home_team :: HTeam, xml_vscore :: Int, xml_hscore :: Int, xml_listing_status :: ScheduleChangesListingStatus, xml_notes :: Maybe String } deriving (Eq, GHC.Generic, Show) -- | For 'H.convert'. -- instance H.HVector ScheduleChangesListingXml instance ToDb ScheduleChangesListingXml where -- | The database analogue of an 'ScheduleChangesListingXml' is -- an 'ScheduleChangesListing'. -- type Db ScheduleChangesListingXml = ScheduleChangesListing -- | We don't make 'ScheduleChangesListingXml' an instance of -- 'FromXmlFkTeams' because it needs some additional information, -- namely the sport name from its containing \. -- But essentially we'll need to do the same thing as -- 'from_xml_fk_teams'. This function accomplishes the same thing, -- with the addition of the sport that's passed in. -- -- The parameter order is for convenience later (see dbimport). -- from_xml_fk_sport :: (DefaultKey ScheduleChanges) -> String -- ^ The sport from our containing schedule change -> (DefaultKey Team) -- ^ Away team FK -> (DefaultKey Team) -- ^ Home team FK -> ScheduleChangesListingXml -> ScheduleChangesListing from_xml_fk_sport fk sport fk_away fk_home ScheduleChangesListingXml{..} = ScheduleChangesListing { db_schedule_changes_id = fk, db_away_team_id = fk_away, db_home_team_id = fk_home, db_type = xml_type, db_sc_sport = sport, db_schedule_id = xml_schedule_id, db_game_time = make_game_time xml_game_date xml_game_time, db_location = xml_location, db_vscore = xml_vscore, db_hscore = xml_hscore, db_listing_status = xml_listing_status, db_notes = xml_notes } where -- | Make the database \"game time\" from the XML -- 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) -- -- * Database stuff. -- instance DbImport Message where dbmigrate _ = run_dbmigrate $ do migrate (undefined :: Team) migrate (undefined :: ScheduleChanges) migrate (undefined :: ScheduleChangesListing) dbimport m = do -- Insert the top-level message msg_id <- insert_xml m -- Now loop through the message's schedule changes forM_ (xml_schedule_changes m) $ \sc -> do -- Construct the function that will turn an XML listing into a DB one. -- This is only partially applied without the away/home team IDs. let listing_xml_to_db = from_xml_fk_sport msg_id (xml_sc_sport sc) -- Now loop through the listings so that we can handle the teams -- one listing at a time. forM_ (xml_sc_listings sc) $ \listing -> do away_team_id <- insert_or_select (vteam $ xml_away_team listing) home_team_id <- insert_or_select (hteam $ xml_home_team listing) -- Finish constructing the xml -> db function. let listing_xml_to_db' = listing_xml_to_db away_team_id home_team_id let db_listing = listing_xml_to_db' listing insert_ db_listing return ImportSucceeded mkPersist tsn_codegen_config [groundhog| - entity: ScheduleChanges dbName: schedule_changes constructors: - name: ScheduleChanges uniques: - name: unique_schedule_changes type: constraint # Prevent multiple imports of the same message. fields: [db_xml_file_id] # Note: we drop the "sc" prefix from the db_sc_sport field. - entity: ScheduleChangesListing dbName: schedule_changes_listings constructors: - name: ScheduleChangesListing fields: - name: db_schedule_changes_id reference: onDelete: cascade - name: db_away_team_id reference: onDelete: cascade - name: db_home_team_id reference: onDelete: cascade - name: db_sc_sport dbName: sport - name: db_listing_status embeddedType: - {name: status_numeral, dbName: status_numeral} - {name: status, dbName: status} - embedded: ScheduleChangesListingStatus fields: - name: _db_status_numeral dbName: status_numeral - name: _db_status dbName: status |] -- -- * Pickling -- -- | An (un)pickler for the \ elements. -- pickle_away_team :: PU VTeam pickle_away_team = xpElem "Away_Team" $ xpWrap (from_tuple, to_tuple') $ xpPair (xpAttr "AT_ID" xpText) (xpOption xpText) where from_tuple (x,y) = VTeam (Team x Nothing y) to_tuple' (VTeam t) = (team_id t, name t) -- | An (un)pickler for the \ elements. -- pickle_home_team :: PU HTeam pickle_home_team = xpElem "Home_Team" $ xpWrap (from_tuple, to_tuple') $ xpPair (xpAttr "HT_ID" xpText) (xpOption xpText) where from_tuple (x,y) = HTeam (Team x Nothing y) to_tuple' (HTeam t) = (team_id t, name t) -- | An (un)pickler for the \ elements. -- pickle_status :: PU ScheduleChangesListingStatus pickle_status = xpElem "status" $ xpWrap (from_tuple, H.convert) $ xpPair (xpAttr "numeral" xpInt) (xpOption xpText) where from_tuple = uncurry ScheduleChangesListingStatus -- | An (un)pickler for the \ elements. -- pickle_listing :: PU ScheduleChangesListingXml pickle_listing = xpElem "SC_Listing" $ xpWrap (from_tuple, H.convert) $ xp11Tuple (xpAttr "type" xpText) (xpElem "Schedule_ID" xpInt) (xpElem "Game_Date" xp_date_padded) (xpElem "Game_Time" xp_tba_time) (xpElem "Location" (xpOption xpText)) pickle_away_team pickle_home_team (xpElem "vscore" xpInt) (xpElem "hscore" xpInt) pickle_status (xpElem "notes" (xpOption xpText)) where from_tuple = uncurryN ScheduleChangesListingXml -- | An (un)pickler for the \ elements. -- pickle_schedule_change :: PU ScheduleChangeXml pickle_schedule_change = xpElem "Schedule_Change" $ xpWrap (from_tuple, H.convert) $ xpPair (xpAttr "Sport" xpText) (xpList pickle_listing) where from_tuple = uncurry ScheduleChangeXml -- | Pickler for the top-level 'Message'. -- pickle_message :: PU Message pickle_message = xpElem "message" $ xpWrap (from_tuple, H.convert) $ xp6Tuple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) (xpElem "category" xpText) (xpElem "sport" xpText) (xpList pickle_schedule_change) (xpElem "time_stamp" xp_time_stamp) where from_tuple = uncurryN Message -- -- * Tests -- -- | A list of all tests for this module. -- schedule_changes_tests :: TestTree schedule_changes_tests = testGroup "ScheduleChanges 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/Schedule_Changes_XML.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/Schedule_Changes_XML.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/Schedule_Changes_XML.xml" results <- unsafe_unpickle path pickle_message let a = undefined :: Team let b = undefined :: ScheduleChanges let c = undefined :: ScheduleChangesListing actual <- withSqliteConn ":memory:" $ runDbConn $ do runMigrationSilent $ do migrate a migrate b migrate c _ <- dbimport results deleteAll b count_a <- countAll a count_b <- countAll b count_c <- countAll c return $ sum [count_a, count_b, count_c] let expected = 12 -- There are 16 team elements, but 4 are dupes, -- so 12 unique teams should be left over. actual @?= expected