From b3a3f27b592e389d69babaca741e8553bb05fa92 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Wed, 11 Jun 2014 19:26:23 -0400 Subject: [PATCH] Add TSN.XML.AutoRacingResults, unimplemented. Tests currently broken. --- htsn-import.cabal | 1 + src/Main.hs | 4 + src/TSN/XML/AutoRacingResults.hs | 263 ++++++++++++++++++++++++++++++ test/xml/AutoRacingResultsXML.dtd | 41 +++++ test/xml/AutoRacingResultsXML.xml | 1 + 5 files changed, 310 insertions(+) create mode 100644 src/TSN/XML/AutoRacingResults.hs create mode 100644 test/xml/AutoRacingResultsXML.dtd create mode 100644 test/xml/AutoRacingResultsXML.xml diff --git a/htsn-import.cabal b/htsn-import.cabal index 0a9f285..b5b1517 100644 --- a/htsn-import.cabal +++ b/htsn-import.cabal @@ -112,6 +112,7 @@ executable htsn-import TSN.Parse TSN.Picklers TSN.XmlImport + TSN.XML.AutoRacingResults TSN.XML.AutoRacingSchedule TSN.XML.GameInfo TSN.XML.Heartbeat diff --git a/src/Main.hs b/src/Main.hs index 88d1cfa..d5f6612 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -45,6 +45,8 @@ import Network.Services.TSN.Report ( report_info, report_error ) import TSN.DbImport ( DbImport(..), ImportResult(..) ) +import qualified TSN.XML.AutoRacingResults as AutoRacingResults ( + dtd ) import qualified TSN.XML.AutoRacingSchedule as AutoRacingSchedule ( dtd, pickle_message ) @@ -161,6 +163,8 @@ import_file cfg path = do migrate_and_import m = dbmigrate m >> dbimport m importer + | dtd == AutoRacingResults.dtd = undefined + | dtd == AutoRacingSchedule.dtd = do let m = unpickleDoc AutoRacingSchedule.pickle_message xml maybe (return $ ImportFailed errmsg) migrate_and_import m diff --git a/src/TSN/XML/AutoRacingResults.hs b/src/TSN/XML/AutoRacingResults.hs new file mode 100644 index 0000000..f8221bb --- /dev/null +++ b/src/TSN/XML/AutoRacingResults.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Parse TSN XML for the DTD \"AutoRacingResultsXML.dtd\". +-- +module TSN.XML.AutoRacingResults ( + dtd, +-- pickle_message, + -- * Tests +-- auto_racing_results_tests, + -- * WARNING: these are private but exported to silence warnings + AutoRacingResultsConstructor(..), + AutoRacingResultsListingConstructor(..) ) +-- AutoRacingResultsRaceInformationConstructor(..) ) +where + +-- System imports. +import Control.Monad ( forM_ ) +import Data.Time ( UTCTime(..) ) +import Data.Tuple.Curry ( uncurryN ) +import Database.Groundhog ( + countAll, + deleteAll, + 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, + xp7Tuple, + xp8Tuple, + xp10Tuple, + xpElem, + xpInt, + xpList, + xpOption, + xpText, + xpWrap ) + +-- Local imports. +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.XmlImport ( XmlImport(..), XmlImportFk(..) ) +import Xml ( + FromXml(..), + FromXmlFk(..), + ToDb(..), + pickle_unpickle, + unpickleable, + unsafe_unpickle ) + + +-- | The DTD to which this module corresponds. Used to invoke dbimport. +-- +dtd :: String +dtd = "AutoRacingResultsXML.dtd" + +-- +-- DB/XML data types +-- + +-- * AutoRacingResults/Message + +-- | Database representation of a 'Message'. +-- +data AutoRacingResults = + AutoRacingResults { + db_xml_file_id :: Int, + db_heading :: String, + db_category :: String, + db_sport :: String, + db_title :: String, + db_race_id :: Int, + db_race_date :: UTCTime, + db_track_location :: String, + db_laps_remaining :: Int, + db_checkered_flag :: Bool, + db_time_stamp :: UTCTime } + deriving (Eq, Show) + + + +-- | XML Representation of an 'AutoRacingResults'. +-- +data Message = + Message { + xml_xml_file_id :: Int, + xml_heading :: String, + xml_category :: String, + xml_sport :: String, + xml_title :: String, + xml_race_id :: Int, + xml_race_date :: UTCTime, + xml_track_location :: String, + xml_laps_remaining :: Int, + xml_checkered_flag :: Bool, + xml_listings :: [AutoRacingResultsListingXml], +-- xml_race_information :: AutoRacingResultsRaceInformation, + xml_time_stamp :: UTCTime } + deriving (Eq, Show) + + +instance ToDb Message where + -- | The database analogue of a 'Message' is a 'AutoRacingResults'. + -- + type Db Message = AutoRacingResults + + +-- | The 'FromXml' instance for 'Message' is required for the +-- 'XmlImport' instance. +-- +instance FromXml Message where + -- | To convert a 'Message' to an 'AutoRacingResults', we just drop + -- the 'xml_listings' and 'xml_race_information'. + -- + from_xml Message{..} = + AutoRacingResults { + db_xml_file_id = xml_xml_file_id, + 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_track_location = xml_track_location, + db_laps_remaining = xml_laps_remaining, + db_checkered_flag = xml_checkered_flag, + db_time_stamp = xml_time_stamp } + + +-- | This allows us to insert the XML representation 'Message' +-- directly. +-- +instance XmlImport Message + + +-- * AutoRacingResultsListing/AutoRacingResultsListingXml + +-- | Database representation of a \ contained within a +-- \. +-- +data AutoRacingResultsListing = + AutoRacingResultsListing { + db_auto_racing_results_id :: DefaultKey AutoRacingResults, + db_finish_position :: Int, + db_starting_position :: Int, + db_car_number :: Int, + db_driver_id :: Int, + db_driver :: String, + db_car_make :: String, + db_points :: Int, + db_laps_completed :: Int, + db_laps_leading :: Int, + db_status :: Int, + db_dnf :: Maybe Bool, + db_nc :: Maybe Bool, + db_earnings :: Maybe Int } + + +-- | XML representation of a \ contained within a +-- \. +-- +data AutoRacingResultsListingXml = + AutoRacingResultsListingXml { + xml_finish_position :: Int, + xml_starting_position :: Int, + xml_car_number :: Int, + xml_driver_id :: Int, + xml_driver :: String, + xml_car_make :: String, + xml_points :: Int, + xml_laps_completed :: Int, + xml_laps_leading :: Int, + xml_status :: Int, + xml_dnf :: Maybe Bool, + xml_nc :: Maybe Bool, + xml_earnings :: Maybe Int } + deriving (Eq, Show) + + +instance ToDb AutoRacingResultsListingXml where + -- | The database analogue of an 'AutoRacingResultsListingXml' is + -- an 'AutoRacingResultsListing'. + -- + type Db AutoRacingResultsListingXml = AutoRacingResultsListing + +instance FromXmlFk AutoRacingResultsListingXml where + -- | Each 'AutoRacingResultsListingXml' is contained in (i.e. has a + -- foreign key to) a 'AutoRacingResults'. + -- + type Parent AutoRacingResultsListingXml = AutoRacingResults + + -- | To convert an 'AutoRacingResultsListingXml' to an + -- 'AutoRacingResultsListing', we add the foreign key and copy + -- everything else verbatim. + -- + from_xml_fk fk AutoRacingResultsListingXml{..} = + AutoRacingResultsListing { + db_auto_racing_results_id = fk, + db_finish_position = xml_finish_position, + db_starting_position = xml_starting_position, + db_car_number = xml_car_number, + db_driver_id = xml_driver_id, + db_driver = xml_driver, + db_car_make = xml_car_make, + db_points = xml_points, + db_laps_completed = xml_laps_completed, + db_laps_leading = xml_laps_leading, + db_status = xml_status, + db_dnf = xml_dnf, + db_nc = xml_nc, + db_earnings = xml_earnings } + + +-- | This allows us to insert the XML representation +-- 'AutoRacingResultsListingXml' directly. +-- +instance XmlImportFk AutoRacingResultsListingXml + + + + +--- +--- Database stuff. +--- + + +mkPersist tsn_codegen_config [groundhog| +- entity: AutoRacingResults + dbName: auto_racing_results + constructors: + - name: AutoRacingResults + uniques: + - name: unique_auto_racing_schedule + type: constraint + # Prevent multiple imports of the same message. + fields: [db_xml_file_id] + + +- entity: AutoRacingResultsListing + dbName: auto_racing_results_listings + constructors: + - name: AutoRacingResultsListing + fields: + - name: db_auto_racing_results_id + reference: + onDelete: cascade +|] diff --git a/test/xml/AutoRacingResultsXML.dtd b/test/xml/AutoRacingResultsXML.dtd new file mode 100644 index 0000000..3eba627 --- /dev/null +++ b/test/xml/AutoRacingResultsXML.dtd @@ -0,0 +1,41 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/test/xml/AutoRacingResultsXML.xml b/test/xml/AutoRacingResultsXML.xml new file mode 100644 index 0000000..0046b44 --- /dev/null +++ b/test/xml/AutoRacingResultsXML.xml @@ -0,0 +1 @@ + 21162271 ASX%BUSCH-FINAL-RESULTS Statistics NASCAR-B 1716 5/24/2014 2:45:00 PM NASCAR - Nationwide - History 300 - Final Results Charlotte Motor Speedway - Concord, NC 80 False 1 3 42 965 Kyle Larson Chevrolet 0 120 0 False TBA 2 2 22 433 Brad Keselowski Ford 0 120 0 False TBA 3 6 2 1269 Brian Scott Chevrolet 0 120 0 False TBA 4 5 5 25 Kevin Harvick Chevrolet 0 120 0 False TBA 5 7 20 28 Matt Kenseth Toyota 0 120 0 False TBA 6 1 54 304 Kyle Busch Toyota 0 120 0 False TBA 7 8 7 207 Regan Smith Chevrolet 0 120 0 False TBA 8 16 6 1343 Trevor Bayne Ford 0 120 0 False TBA 9 13 60 653 Chris Buescher Ford 0 120 0 False TBA 10 11 3 1061 Ty Dillon Chevrolet 0 120 0 False TBA 1.5 200 965 Kyle Larson 0 May 24, 2014, at 04:18 PM ET \ No newline at end of file -- 2.44.2