X-Git-Url: http://gitweb.michael.orlitzky.com/?p=dead%2Fhtsn-import.git;a=blobdiff_plain;f=src%2FTSN%2FXML%2FAutoRacingDriverList.hs;h=327c358bcc1ed305d1b016cc5b462825c3162825;hp=d2c83586608cc1fabc61af0e4c5bfd5ecf2cfc51;hb=c864af7aa8a195cf441904479c416202590e9375;hpb=e88453d996ef8c94d581122309669c5c2aa87c9d 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