From: Michael Orlitzky Date: Fri, 7 Nov 2014 01:29:15 +0000 (-0500) Subject: Complete TSN.XML.AutoRacingDriverList. X-Git-Tag: 0.2.1~65 X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;h=c864af7aa8a195cf441904479c416202590e9375;p=dead%2Fhtsn-import.git Complete TSN.XML.AutoRacingDriverList. Remove AutoRacingDriverList.dtd from the TODO. Add a dbschema diagram for AutoRacingDriverList.dtd. Update the cabal/.ghci files with the new module name. Add tests for the new module. --- diff --git a/.ghci b/.ghci index be99942..dfeb6df 100644 --- a/.ghci +++ b/.ghci @@ -17,6 +17,7 @@ src/TSN/Picklers.hs src/TSN/Team.hs src/TSN/XmlImport.hs + src/TSN/XML/AutoRacingDriverList.hs src/TSN/XML/AutoRacingResults.hs src/TSN/XML/AutoRacingSchedule.hs src/TSN/XML/EarlyLine.hs @@ -49,6 +50,7 @@ import TSN.Parse import TSN.Picklers import TSN.Team import TSN.XmlImport +import TSN.XML.AutoRacingDriverList import TSN.XML.AutoRacingResults import TSN.XML.AutoRacingSchedule import TSN.XML.EarlyLine diff --git a/doc/TODO b/doc/TODO index 2f1143d..92290ae 100644 --- a/doc/TODO +++ b/doc/TODO @@ -18,7 +18,6 @@ FeedGrabber. They are not yet handled by htsn-import (some may not be valid): - * AutoRacingDriverList * AutoRacingGridXML * CBASK_Individual_Stats_XML * Cbask_Roster_XML diff --git a/doc/dbschema/AutoRacingDriverList.png b/doc/dbschema/AutoRacingDriverList.png new file mode 100644 index 0000000..430e017 Binary files /dev/null and b/doc/dbschema/AutoRacingDriverList.png differ diff --git a/htsn-import.cabal b/htsn-import.cabal index afa02df..203f1cd 100644 --- a/htsn-import.cabal +++ b/htsn-import.cabal @@ -284,6 +284,7 @@ executable htsn-import TSN.Picklers TSN.Team TSN.XmlImport + TSN.XML.AutoRacingDriverList TSN.XML.AutoRacingResults TSN.XML.AutoRacingSchedule TSN.XML.EarlyLine diff --git a/src/TSN/XML/AutoRacingDriverList.hs b/src/TSN/XML/AutoRacingDriverList.hs index d2c8358..327c358 100644 --- a/src/TSN/XML/AutoRacingDriverList.hs +++ b/src/TSN/XML/AutoRacingDriverList.hs @@ -1,4 +1,8 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -8,22 +12,56 @@ -- module TSN.XML.AutoRacingDriverList ( dtd, - pickle_message ) + pickle_message, + -- * Tests + auto_racing_driver_list_tests, + -- * WARNING: these are private but exported to silence warnings + AutoRacingDriverListConstructor(..), + AutoRacingDriverListListingConstructor(..) ) 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 Text.XML.HXT.Core ( PU ) +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, + xp9Tuple, + xpElem, + xpInt, + xpList, + xpOption, + xpText, + xpWrap ) -- Local imports. -import TSN.DbImport ( DbImport(..) ) +import TSN.Codegen ( tsn_codegen_config ) +import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) +import TSN.Picklers ( xp_date, xp_time_stamp ) import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) ) import Xml ( Child(..), FromXml(..), FromXmlFk(..), - ToDb(..) ) + ToDb(..), + pickle_unpickle, + unpickleable, + unsafe_unpickle ) -- | The DTD to which this module corresponds. Used to invoke dbimport. -- @@ -31,10 +69,10 @@ dtd :: String dtd = "AutoRacingDriverList.dtd" -- --- DB/XML data types +-- * DB/XML data types -- --- * AutoRacingDriverList/Message +-- AutoRacingDriverList/Message -- | Database representation of a 'Message'. Comparatively, it lacks -- only the listings. @@ -95,21 +133,21 @@ instance FromXml Message where instance XmlImport Message --- * AutoRacingDriverListListing / AutoRacingDriverListListingXml +-- AutoRacingDriverListListing / AutoRacingDriverListListingXml -- | Database representation of a \ contained within a -- \. -- data AutoRacingDriverListListing = AutoRacingDriverListListing { - db_auto_racing_driver_list_id :: DefaultKey AutoRacingDriverList, + db_auto_racing_driver_lists_id :: DefaultKey AutoRacingDriverList, db_driver_id :: Int, db_driver :: String, db_height :: Maybe String, db_weight :: Int, db_date_of_birth :: UTCTime, db_hometown :: String, - db_nationality :: String, + db_nationality :: Maybe String, db_car_number :: Int, db_car :: String } @@ -124,7 +162,7 @@ data AutoRacingDriverListListingXml = xml_weight :: Int, xml_date_of_birth :: UTCTime, xml_hometown :: String, - xml_nationality :: String, + xml_nationality :: Maybe String, xml_car_number :: Int, xml_car :: String } deriving (Eq, Show) @@ -151,7 +189,7 @@ instance FromXmlFk AutoRacingDriverListListingXml where -- from_xml_fk fk AutoRacingDriverListListingXml{..} = AutoRacingDriverListListing { - db_auto_racing_driver_list_id = fk, + db_auto_racing_driver_lists_id = fk, db_driver_id = xml_driver_id, db_driver = xml_driver, db_height = xml_height, @@ -167,3 +205,171 @@ instance FromXmlFk AutoRacingDriverListListingXml where -- 'AutoRacingDriverListListingXml' directly. -- instance XmlImportFk AutoRacingDriverListListingXml + + + +-- +-- * Database +-- + +instance DbImport Message where + dbmigrate _ = + run_dbmigrate $ do + migrate (undefined :: AutoRacingDriverList) + migrate (undefined :: AutoRacingDriverListListing) + + -- | We insert the message, then use its ID to insert the listings. + dbimport m = do + msg_id <- insert_xml m + forM_ (xml_listings m) $ insert_xml_fk_ msg_id + + return ImportSucceeded + + + +mkPersist tsn_codegen_config [groundhog| +- entity: AutoRacingDriverList + dbName: auto_racing_driver_lists + constructors: + - name: AutoRacingDriverList + uniques: + - name: unique_auto_racing_driver_lists + type: constraint + # Prevent multiple imports of the same message. + fields: [db_xml_file_id] + + +- entity: AutoRacingDriverListListing + dbName: auto_racing_driver_lists_listings + constructors: + - name: AutoRacingDriverListListing + fields: + - name: db_auto_racing_driver_lists_id + reference: + onDelete: cascade + +|] + + +-- +-- * Pickling +-- + +-- | Pickler for the \s contained within \s. +-- +pickle_listing :: PU AutoRacingDriverListListingXml +pickle_listing = + xpElem "Listing" $ + xpWrap (from_tuple, to_tuple) $ + xp9Tuple (xpElem "DriverID" xpInt) + (xpElem "Driver" xpText) + (xpElem "Height" $ xpOption xpText) + (xpElem "Weight" xpInt) + (xpElem "DOB" xp_date) + (xpElem "Hometown" xpText) + (xpElem "Nationality" $ xpOption xpText) + (xpElem "Car_Number" xpInt) + (xpElem "Car" xpText) + where + from_tuple = uncurryN AutoRacingDriverListListingXml + to_tuple m = (xml_driver_id m, + xml_driver m, + xml_height m, + xml_weight m, + xml_date_of_birth m, + xml_hometown m, + xml_nationality m, + xml_car_number m, + xml_car m) + +-- | Pickler for the top-level 'Message'. +-- +pickle_message :: PU Message +pickle_message = + xpElem "message" $ + xpWrap (from_tuple, to_tuple) $ + xp7Tuple (xpElem "XML_File_ID" xpInt) + (xpElem "heading" xpText) + (xpElem "category" xpText) + (xpElem "sport" xpText) + (xpElem "Title" xpText) + (xpList pickle_listing) + (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_title m, + xml_listings m, + xml_time_stamp m) + + + +-- +-- * Tasty Tests +-- + +-- | A list of all tests for this module. +-- +auto_racing_driver_list_tests :: TestTree +auto_racing_driver_list_tests = + testGroup + "AutoRacingDriverList 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/AutoRacingDriverList.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/AutoRacingDriverList.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_driver_lists deletes its children" + "test/xml/AutoRacingDriverList.xml" ] + where + check desc path = testCase desc $ do + results <- unsafe_unpickle path pickle_message + let a = undefined :: AutoRacingDriverList + let b = undefined :: AutoRacingDriverListListing + + 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 diff --git a/test/TestSuite.hs b/test/TestSuite.hs index b64d2d6..56cc7dd 100644 --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -2,6 +2,7 @@ import Test.Tasty ( TestTree, defaultMain, testGroup ) import TSN.Parse ( parse_tests ) import TSN.Picklers ( pickler_tests ) +import TSN.XML.AutoRacingDriverList ( auto_racing_driver_list_tests ) import TSN.XML.AutoRacingResults ( auto_racing_results_tests ) import TSN.XML.AutoRacingSchedule ( auto_racing_schedule_tests ) import TSN.XML.EarlyLine ( early_line_tests ) @@ -21,7 +22,8 @@ import TSN.XML.Weather ( weather_tests ) tests :: TestTree tests = testGroup "All tests" - [ auto_racing_results_tests, + [ auto_racing_driver_list_tests, + auto_racing_results_tests, auto_racing_schedule_tests, early_line_tests, game_info_tests, diff --git a/test/shell/import-duplicates.test b/test/shell/import-duplicates.test index 1cc7bd6..a8b3561 100644 --- a/test/shell/import-duplicates.test +++ b/test/shell/import-duplicates.test @@ -16,7 +16,7 @@ rm -f shelltest.sqlite3 # and a newsxml that aren't really supposed to import. find ./test/xml -maxdepth 1 -name '*.xml' | wc -l >>> -39 +40 >>>= 0 # Run the imports again; we should get complaints about the duplicate @@ -26,7 +26,7 @@ find ./test/xml -maxdepth 1 -name '*.xml' | wc -l # know, sorry. ./dist/build/htsn-import/htsn-import -c 'shelltest.sqlite3' test/xml/*.xml 2>&1 | grep ERROR | wc -l >>> -70 +72 >>>= 0 # Finally, clean up after ourselves.