X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FAutoRacingResults.hs;h=539c4380dfa68bc9d8fdf763b2e043fd0129a1f8;hb=4ce681700509beedf38026568ea20102801e6516;hp=f8221bbaebbaa89d89df4238a1a390ed3eebaea4;hpb=b3a3f27b592e389d69babaca741e8553bb05fa92;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/AutoRacingResults.hs b/src/TSN/XML/AutoRacingResults.hs index f8221bb..539c438 100644 --- a/src/TSN/XML/AutoRacingResults.hs +++ b/src/TSN/XML/AutoRacingResults.hs @@ -3,27 +3,30 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} --- | Parse TSN XML for the DTD \"AutoRacingResultsXML.dtd\". +-- | Parse TSN XML for the DTD \"AutoRacingResultsXML.dtd\". Each +-- \ element contains a \ and a bunch of +-- \s. -- module TSN.XML.AutoRacingResults ( dtd, --- pickle_message, + pickle_message, -- * Tests --- auto_racing_results_tests, + auto_racing_results_tests, -- * WARNING: these are private but exported to silence warnings AutoRacingResultsConstructor(..), - AutoRacingResultsListingConstructor(..) ) --- AutoRacingResultsRaceInformationConstructor(..) ) + AutoRacingResultsListingConstructor(..), + AutoRacingResultsRaceInformationConstructor(..) ) where -- System imports. import Control.Monad ( forM_ ) +import Data.Data ( Data ) import Data.Time ( UTCTime(..) ) import Data.Tuple.Curry ( uncurryN ) +import Data.Typeable ( Typeable ) import Database.Groundhog ( countAll, deleteAll, @@ -40,23 +43,30 @@ import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) import Text.XML.HXT.Core ( PU, - xp7Tuple, - xp8Tuple, - xp10Tuple, + xp11Tuple, + xp13Tuple, + xpAttr, xpElem, xpInt, xpList, xpOption, + xpPair, + xpPrim, xpText, + xpTriple, xpWrap ) -- Local imports. -import TSN.Codegen ( - tsn_codegen_config ) +import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) -import TSN.Picklers ( xp_date, xp_tba_time, xp_time_stamp ) +import TSN.Picklers ( + xp_earnings, + xp_fracpart_only_double, + xp_datetime, + xp_time_stamp ) import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) ) import Xml ( + Child(..), FromXml(..), FromXmlFk(..), ToDb(..), @@ -76,7 +86,9 @@ dtd = "AutoRacingResultsXML.dtd" -- * AutoRacingResults/Message --- | Database representation of a 'Message'. +-- | Database representation of a 'Message'. Comparatively, it lacks +-- the listings and race information since they are linked via a +-- foreign key. -- data AutoRacingResults = AutoRacingResults { @@ -84,9 +96,9 @@ data AutoRacingResults = db_heading :: String, db_category :: String, db_sport :: String, - db_title :: String, db_race_id :: Int, db_race_date :: UTCTime, + db_title :: String, db_track_location :: String, db_laps_remaining :: Int, db_checkered_flag :: Bool, @@ -95,7 +107,9 @@ data AutoRacingResults = --- | XML Representation of an 'AutoRacingResults'. +-- | XML Representation of an 'AutoRacingResults'. It has the same +-- fields, but in addition contains the 'xml_listings' and +-- 'xml_race_information'. -- data Message = Message { @@ -103,14 +117,14 @@ data Message = xml_heading :: String, xml_category :: String, xml_sport :: String, - xml_title :: String, xml_race_id :: Int, xml_race_date :: UTCTime, + xml_title :: String, xml_track_location :: String, xml_laps_remaining :: Int, xml_checkered_flag :: Bool, xml_listings :: [AutoRacingResultsListingXml], --- xml_race_information :: AutoRacingResultsRaceInformation, + xml_race_information :: AutoRacingResultsRaceInformationXml, xml_time_stamp :: UTCTime } deriving (Eq, Show) @@ -134,9 +148,9 @@ instance FromXml Message where db_heading = xml_heading, db_category = xml_category, db_sport = xml_sport, - db_title = xml_title, db_race_id = xml_race_id, db_race_date = xml_race_date, + db_title = xml_title, db_track_location = xml_track_location, db_laps_remaining = xml_laps_remaining, db_checkered_flag = xml_checkered_flag, @@ -152,7 +166,7 @@ instance XmlImport Message -- * AutoRacingResultsListing/AutoRacingResultsListingXml -- | Database representation of a \ contained within a --- \. +-- \. -- data AutoRacingResultsListing = AutoRacingResultsListing { @@ -166,7 +180,7 @@ data AutoRacingResultsListing = db_points :: Int, db_laps_completed :: Int, db_laps_leading :: Int, - db_status :: Int, + db_status :: Maybe String, db_dnf :: Maybe Bool, db_nc :: Maybe Bool, db_earnings :: Maybe Int } @@ -186,7 +200,7 @@ data AutoRacingResultsListingXml = xml_points :: Int, xml_laps_completed :: Int, xml_laps_leading :: Int, - xml_status :: Int, + xml_status :: Maybe String, xml_dnf :: Maybe Bool, xml_nc :: Maybe Bool, xml_earnings :: Maybe Int } @@ -199,12 +213,15 @@ instance ToDb AutoRacingResultsListingXml where -- type Db AutoRacingResultsListingXml = AutoRacingResultsListing -instance FromXmlFk AutoRacingResultsListingXml where + +instance Child AutoRacingResultsListingXml where -- | Each 'AutoRacingResultsListingXml' is contained in (i.e. has a -- foreign key to) a 'AutoRacingResults'. -- type Parent AutoRacingResultsListingXml = AutoRacingResults + +instance FromXmlFk AutoRacingResultsListingXml where -- | To convert an 'AutoRacingResultsListingXml' to an -- 'AutoRacingResultsListing', we add the foreign key and copy -- everything else verbatim. @@ -234,10 +251,132 @@ instance XmlImportFk AutoRacingResultsListingXml +-- * AutoRacingResultsRaceInformation / AutoRacingResultsRaceInformationXml + +-- | The \ child of \ always +-- contains exactly three fields, so we just embed those three into +-- the 'AutoRacingResultsRaceInformation' type. We (pointlessly) use +-- the \"db_\" prefix since our field namer is going to strip of +-- everything before the first underscore. +-- +data MostLapsLeading = + MostLapsLeading { + db_most_laps_leading_driver_id :: Int, + db_most_laps_leading_driver :: String, + db_most_laps_leading_number_of_laps :: Int } + deriving (Data, Eq, Show, Typeable) + + +-- | Database representation of a \ contained +-- within a \. +-- +data AutoRacingResultsRaceInformation = + AutoRacingResultsRaceInformation { + -- Note the apostrophe to disambiguate it from the + -- AutoRacingResultsListing field. + db_auto_racing_results_id' :: DefaultKey AutoRacingResults, + db_track_length :: String, -- ^ Usually a Double, but sometimes a String, + -- like \"1.25 miles\". + db_track_length_kph :: Double, + db_laps :: Int, + db_average_speed_mph :: Maybe Double, + db_average_speed_kph :: Maybe Double, + db_average_speed :: Maybe Double, + db_time_of_race :: Maybe String, + db_margin_of_victory :: Maybe String, + db_cautions :: Maybe String, + db_lead_changes :: Maybe String, + db_lap_leaders :: Maybe String, + db_most_laps_leading :: MostLapsLeading } + + +-- | XML representation of a \ contained within a +-- \. +-- +data AutoRacingResultsRaceInformationXml = + AutoRacingResultsRaceInformationXml { + xml_track_length :: String, + xml_track_length_kph :: Double, + xml_laps :: Int, + xml_average_speed_mph :: Maybe Double, + xml_average_speed_kph :: Maybe Double, + xml_average_speed :: Maybe Double, + xml_time_of_race :: Maybe String, + xml_margin_of_victory :: Maybe String, + xml_cautions :: Maybe String, + xml_lead_changes :: Maybe String, + xml_lap_leaders :: Maybe String, + xml_most_laps_leading :: MostLapsLeading } + deriving (Eq,Show) + + +instance ToDb AutoRacingResultsRaceInformationXml where + -- | The database analogue of an + -- 'AutoRacingResultsRaceInformationXml' is an + -- 'AutoRacingResultsRaceInformation'. + -- + type Db AutoRacingResultsRaceInformationXml = + AutoRacingResultsRaceInformation + + +instance Child AutoRacingResultsRaceInformationXml where + -- | Each 'AutoRacingResultsRaceInformationXml' is contained in + -- (i.e. has a foreign key to) a 'AutoRacingResults'. + -- + type Parent AutoRacingResultsRaceInformationXml = AutoRacingResults + + +instance FromXmlFk AutoRacingResultsRaceInformationXml where + -- | To convert an 'AutoRacingResultsRaceInformationXml' to an + -- 'AutoRacingResultsRaceInformartion', we add the foreign key and + -- copy everything else verbatim. + -- + from_xml_fk fk AutoRacingResultsRaceInformationXml{..} = + AutoRacingResultsRaceInformation { + db_auto_racing_results_id' = fk, + db_track_length = xml_track_length, + db_track_length_kph = xml_track_length_kph, + db_laps = xml_laps, + db_average_speed_mph = xml_average_speed_mph, + db_average_speed_kph = xml_average_speed_kph, + db_average_speed = xml_average_speed, + db_time_of_race = xml_time_of_race, + db_margin_of_victory = xml_margin_of_victory, + db_cautions = xml_cautions, + db_lead_changes = xml_lead_changes, + db_lap_leaders = xml_lap_leaders, + db_most_laps_leading = xml_most_laps_leading } + + +-- | This allows us to insert the XML representation +-- 'AutoRacingResultsRaceInformationXml' directly. +-- +instance XmlImportFk AutoRacingResultsRaceInformationXml + + + +-- +-- * Database stuff. +-- + +instance DbImport Message where + dbmigrate _ = + run_dbmigrate $ do + migrate (undefined :: AutoRacingResults) + migrate (undefined :: AutoRacingResultsListing) + migrate (undefined :: AutoRacingResultsRaceInformation) + + -- | We insert the message, then use its ID to insert the listings + -- and race information. + dbimport m = do + msg_id <- insert_xml m + + insert_xml_fk_ msg_id (xml_race_information m) + + forM_ (xml_listings m) $ insert_xml_fk_ msg_id + + return ImportSucceeded ---- ---- Database stuff. ---- mkPersist tsn_codegen_config [groundhog| @@ -246,7 +385,7 @@ mkPersist tsn_codegen_config [groundhog| constructors: - name: AutoRacingResults uniques: - - name: unique_auto_racing_schedule + - name: unique_auto_racing_results type: constraint # Prevent multiple imports of the same message. fields: [db_xml_file_id] @@ -260,4 +399,248 @@ mkPersist tsn_codegen_config [groundhog| - name: db_auto_racing_results_id reference: onDelete: cascade + + # Note the apostrophe in the foreign key. This is to disambiguate + # it from the AutoRacingResultsListing foreign key of the same name. + # We strip it out of the dbName. +- entity: AutoRacingResultsRaceInformation + dbName: auto_racing_results_race_information + constructors: + - name: AutoRacingResultsRaceInformation + fields: + - name: db_auto_racing_results_id' + dbName: auto_racing_results_id + reference: + onDelete: cascade + - name: db_most_laps_leading + embeddedType: + - {name: most_laps_leading_driver_id, + dbName: most_laps_leading_driver_id} + - {name: most_laps_leading_driver, + dbName: most_laps_leading_driver} + +- embedded: MostLapsLeading + fields: + - name: db_most_laps_leading_driver_id + dbName: most_laps_leading_driver_id + - name: db_most_laps_leading_driver + dbName: most_laps_leading_driver + - name: db_most_laps_leading_number_of_laps + dbName: most_laps_leading_number_of_laps |] + + +--- +--- Pickling +--- + +-- | Pickler for the \s contained within \s. +-- +pickle_listing :: PU AutoRacingResultsListingXml +pickle_listing = + xpElem "Listing" $ + xpWrap (from_tuple, to_tuple) $ + xp13Tuple (xpElem "FinishPosition" xpInt) + (xpElem "StartingPosition" xpInt) + (xpElem "CarNumber" xpInt) + (xpElem "DriverID" xpInt) + (xpElem "Driver" xpText) + (xpElem "CarMake" xpText) + (xpElem "Points" xpInt) + (xpElem "Laps_Completed" xpInt) + (xpElem "Laps_Leading" xpInt) + (xpElem "Status" $ xpOption xpText) + (xpOption $ xpElem "DNF" xpPrim) + (xpOption $ xpElem "NC" xpPrim) + (xpElem "Earnings" xp_earnings) + where + from_tuple = uncurryN AutoRacingResultsListingXml + to_tuple m = (xml_finish_position m, + xml_starting_position m, + xml_car_number m, + xml_driver_id m, + xml_driver m, + xml_car_make m, + xml_points m, + xml_laps_completed m, + xml_laps_leading m, + xml_status m, + xml_dnf m, + xml_nc m, + xml_earnings m) + + +-- | Pickler for the top-level 'Message'. +-- +pickle_message :: PU Message +pickle_message = + xpElem "message" $ + xpWrap (from_tuple, to_tuple) $ + xp13Tuple (xpElem "XML_File_ID" xpInt) + (xpElem "heading" xpText) + (xpElem "category" xpText) + (xpElem "sport" xpText) + (xpElem "RaceID" xpInt) + (xpElem "RaceDate" xp_datetime) + (xpElem "Title" xpText) + (xpElem "Track_Location" xpText) + (xpElem "Laps_Remaining" xpInt) + (xpElem "Checkered_Flag" xpPrim) + (xpList pickle_listing) + pickle_race_information + (xpElem "time_stamp" xp_time_stamp) + where + from_tuple = uncurryN Message + to_tuple m = (xml_xml_file_id m, + xml_heading m, + xml_category m, + xml_sport m, + xml_race_id m, + xml_race_date m, + xml_title m, + xml_track_location m, + xml_laps_remaining m, + xml_checkered_flag m, + xml_listings m, + xml_race_information m, + xml_time_stamp m) + + +-- | Pickler for the \ child of a +-- \. +-- +pickle_most_laps_leading :: PU MostLapsLeading +pickle_most_laps_leading = + xpElem "Most_Laps_Leading" $ + xpWrap (from_tuple, to_tuple) $ + xpTriple (xpElem "DriverID" xpInt) + (xpElem "Driver" xpText) + (xpElem "NumberOfLaps" xpInt) + where + from_tuple = uncurryN MostLapsLeading + to_tuple m = (db_most_laps_leading_driver_id m, + db_most_laps_leading_driver m, + db_most_laps_leading_number_of_laps m) + + +-- | Pickler for the \ child of \. +-- +pickle_race_information :: PU AutoRacingResultsRaceInformationXml +pickle_race_information = + xpElem "Race_Information" $ + xpWrap (from_tuple, to_tuple) $ + xp11Tuple (-- I can't think of another way to get both the + -- TrackLength and its KPH attribute. So we shove them + -- both in a 2-tuple. This should probably be an embedded type! + xpElem "TrackLength" $ + xpPair xpText + (xpAttr "KPH" xp_fracpart_only_double) ) + (xpElem "Laps" xpInt) + (xpOption $ xpElem "AverageSpeedMPH" xpPrim) + (xpOption $ xpElem "AverageSpeedKPH" xpPrim) + (xpOption $ xpElem "AverageSpeed" xpPrim) + (xpOption $ xpElem "TimeOfRace" xpText) + (xpOption $ xpElem "MarginOfVictory" xpText) + (xpOption $ xpElem "Cautions" xpText) + (xpOption $ xpElem "LeadChanges" xpText) + (xpOption $ xpElem "LapLeaders" xpText) + pickle_most_laps_leading + where + -- Derp. Since the first two are paired, we have to + -- manually unpack the bazillion arguments. + from_tuple ((x1,x2),x3,x4,x5,x6,x7,x8,x9,x10,x11,x12) = + AutoRacingResultsRaceInformationXml + x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 + + -- And here we have to re-pair the first two. + to_tuple m = ((xml_track_length m, xml_track_length_kph m), + xml_laps m, + xml_average_speed_mph m, + xml_average_speed_kph m, + xml_average_speed m, + xml_time_of_race m, + xml_margin_of_victory m, + xml_cautions m, + xml_lead_changes m, + xml_lap_leaders m, + xml_most_laps_leading m) + +-- +-- * Tasty Tests +-- + +-- | A list of all tests for this module. +-- +auto_racing_results_tests :: TestTree +auto_racing_results_tests = + testGroup + "AutoRacingResults 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 = testGroup "pickle-unpickle tests" + [ check "pickle composed with unpickle is the identity" + "test/xml/AutoRacingResultsXML.xml", + + check "pickle composed with unpickle is the identity (fractional KPH)" + "test/xml/AutoRacingResultsXML-fractional-kph.xml" ] + where + check desc path = testCase desc $ do + (expected, actual) <- pickle_unpickle pickle_message path + actual @?= expected + + + +-- | Make sure we can actually unpickle these things. +-- +test_unpickle_succeeds :: TestTree +test_unpickle_succeeds = testGroup "unpickle tests" + [ check "unpickling succeeds" + "test/xml/AutoRacingResultsXML.xml", + + check "unpickling succeeds (fractional KPH)" + "test/xml/AutoRacingResultsXML-fractional-kph.xml" ] + where + check desc path = testCase desc $ do + 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 = testGroup "cascading delete tests" + [ check "deleting auto_racing_results deletes its children" + "test/xml/AutoRacingResultsXML.xml", + + check "deleting auto_racing_results deletes its children (fractional KPH)" + "test/xml/AutoRacingResultsXML-fractional-kph.xml" ] + where + check desc path = testCase desc $ do + results <- unsafe_unpickle path pickle_message + let a = undefined :: AutoRacingResults + let b = undefined :: AutoRacingResultsListing + let c = undefined :: AutoRacingResultsRaceInformation + + actual <- withSqliteConn ":memory:" $ runDbConn $ do + runMigration silentMigrationLogger $ do + migrate a + migrate b + migrate c + _ <- dbimport results + deleteAll a + count_a <- countAll a + count_b <- countAll b + count_c <- countAll c + return $ sum [count_a, count_b, count_c] + let expected = 0 + actual @?= expected