X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FInjuriesDetail.hs;h=9c6ae5daf246ff63cf90a312061f3bf3cda8a1d7;hb=4d6a41c7a9594e10ae004bb2c0ee72bde26ebcda;hp=fee6ce2beb46d09da012a5ae60f9f5f37afd927a;hpb=e207228e7b7b47f4cbe16b578ce16cea009b15f9;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/InjuriesDetail.hs b/src/TSN/XML/InjuriesDetail.hs index fee6ce2..9c6ae5d 100644 --- a/src/TSN/XML/InjuriesDetail.hs +++ b/src/TSN/XML/InjuriesDetail.hs @@ -2,7 +2,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -13,6 +12,7 @@ -- real meat. -- module TSN.XML.InjuriesDetail ( + dtd, pickle_message, -- * Tests injuries_detail_tests, @@ -28,7 +28,13 @@ import Data.Time ( UTCTime ) import Data.Tuple.Curry ( uncurryN ) import Database.Groundhog ( DefaultKey, - migrate ) + countAll, + deleteAll, + migrate, + runMigration, + silentMigrationLogger ) +import Database.Groundhog.Generic ( runDbConn ) +import Database.Groundhog.Sqlite ( withSqliteConn ) import Database.Groundhog.TH ( groundhog, mkPersist ) @@ -57,7 +63,15 @@ import Xml ( FromXmlFk(..), ToDb(..), pickle_unpickle, - unpickleable ) + unpickleable, + unsafe_unpickle ) + + + +-- | The DTD to which this module corresponds. Used to invoke dbimport. +-- +dtd :: String +dtd = "Injuries_Detail_XML.dtd" -- @@ -85,6 +99,7 @@ data Message = -- data InjuriesDetail = InjuriesDetail { + db_xml_file_id :: Int, db_sport :: String, db_time_stamp :: UTCTime } deriving (Eq, Show) @@ -92,6 +107,7 @@ data InjuriesDetail = instance ToDb Message where -- | The database representation of a 'Message' is an -- 'InjuriesDetail'. + -- type Db Message = InjuriesDetail instance FromXml Message where @@ -100,18 +116,25 @@ instance FromXml Message where -- from_xml Message{..} = InjuriesDetail { + db_xml_file_id = xml_xml_file_id, db_sport = xml_sport, db_time_stamp = xml_time_stamp } --- | This allows us to call 'insert_xml' directly on the XML --- representation. +-- | This allows us to insert the XML representation 'Message' +-- directly. +-- instance XmlImport Message -- * InjuriesDetailListing/InjuriesDetailListingXml +-- | Database representation of a \ element. It has a +-- foreign key pointing to its parent 'InjuriesDetail', and does not +-- contain the list of 'xml_player_listings' (which get their own +-- table). +-- data InjuriesDetailListing = InjuriesDetailListing { db_injuries_detail_id :: DefaultKey InjuriesDetail, @@ -133,17 +156,28 @@ data InjuriesDetailListingXml = deriving (Eq, Show) instance ToDb InjuriesDetailListingXml where + -- | The database analogue of an 'InjuriesDetailListingXml' is a + -- 'InjuriesDetailListing'. type Db InjuriesDetailListingXml = InjuriesDetailListing instance FromXmlFk InjuriesDetailListingXml where + -- | Each 'InjuriesDetailListingXml' is contained in an + -- 'InjuriesDetail'. type Parent InjuriesDetailListingXml = InjuriesDetail + -- | Construct a 'InjuriesDetailListing' from a + -- 'InjuriesDetailListingXml' and a foreign key to a + -- 'InjuriesDetail'. + -- from_xml_fk fk InjuriesDetailListingXml{..} = InjuriesDetailListing { db_injuries_detail_id = fk, db_team_id = xml_team_id, db_full_name = xml_full_name } +-- | This allows us to insert the XML representation +-- 'InjuriesDetailListingXml' directly. +-- instance XmlImportFk InjuriesDetailListingXml @@ -201,10 +235,15 @@ instance ToDb InjuriesDetailListingPlayerListingXml where InjuriesDetailListingPlayerListing instance FromXmlFk InjuriesDetailListingPlayerListingXml where + -- | Each 'InjuriesDetailListingPlayerListingXml' is contained in an + -- 'InjuriesDetailListing'. + -- type Parent InjuriesDetailListingPlayerListingXml = InjuriesDetailListing - -- | To convert between a 'InjuriesDetailListingPlayerListingXml' - -- and a 'InjuriesDetailListingPlayerListingXml', we do nothing. + -- | To construct a 'InjuriesDetailListingPlayerListing' from a + -- 'InjuriesDetailListingPlayerListingXml' we need to supply a + -- foreign key to an 'InjuriesDetailListing'. + -- from_xml_fk fk InjuriesDetailListingPlayerListingXml{..} = InjuriesDetailListingPlayerListing { db_injuries_detail_listings_id = fk, @@ -218,9 +257,8 @@ instance FromXmlFk InjuriesDetailListingPlayerListingXml where db_injured = xml_injured, db_type = xml_type } --- | This lets us call 'insert_xml' on a --- 'InjuriesDetailListingPlayerListingXml' without having to --- explicitly convert it to its database analogue first. +-- | This lets us insert the XML representation +-- 'InjuriesDetailListingPlayerListingXml' directly. -- instance XmlImportFk InjuriesDetailListingPlayerListingXml @@ -230,9 +268,16 @@ instance XmlImportFk InjuriesDetailListingPlayerListingXml -- instance DbImport Message where + dbmigrate _ = + run_dbmigrate $ do + migrate (undefined :: InjuriesDetail) + migrate (undefined :: InjuriesDetailListing) + migrate (undefined :: InjuriesDetailListingPlayerListing) + -- | To import a 'Message', we import all of its - -- 'InjuriesDetailListingPlayerListingXml's, which we have to dig out of its - -- 'Listing's. + -- 'InjuriesDetailListingPlayerListingXml's, which we have to dig + -- out of its 'Listing's. + -- dbimport msg = do msg_id <- insert_xml msg @@ -242,16 +287,17 @@ instance DbImport Message where return ImportSucceeded - dbmigrate _ = - run_dbmigrate $ do - migrate (undefined :: InjuriesDetail) - migrate (undefined :: InjuriesDetailListing) - migrate (undefined :: InjuriesDetailListingPlayerListing) - mkPersist tsn_codegen_config [groundhog| - entity: InjuriesDetail dbName: injuries_detail + constructors: + - name: InjuriesDetail + uniques: + - name: unique_injuries_detail + type: constraint + # Prevent multiple imports of the same message. + fields: [db_xml_file_id] - entity: InjuriesDetailListing dbName: injuries_detail_listings @@ -356,7 +402,8 @@ injuries_detail_tests :: TestTree injuries_detail_tests = testGroup "InjuriesDetail tests" - [ test_pickle_of_unpickle_is_identity, + [ test_on_delete_cascade, + test_pickle_of_unpickle_is_identity, test_unpickle_succeeds ] @@ -391,3 +438,34 @@ test_unpickle_succeeds = testGroup "unpickle tests" 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 "delete of injuries_detail deletes its children" + "test/xml/Injuries_Detail_XML.xml", + + check "delete of injuries_detail deletes its children (non-int team_id)" + "test/xml/Injuries_Detail_XML-noninteger-team-id.xml" ] + where + check desc path = testCase desc $ do + inj <- unsafe_unpickle path pickle_message + let a = undefined :: InjuriesDetail + let b = undefined :: InjuriesDetailListing + let c = undefined :: InjuriesDetailListingPlayerListing + actual <- withSqliteConn ":memory:" $ runDbConn $ do + runMigration silentMigrationLogger $ do + migrate a + migrate b + migrate c + _ <- dbimport inj + deleteAll a + count_a <- countAll a + count_b <- countAll b + count_c <- countAll c + return $ count_a + count_b + count_c + let expected = 0 + actual @?= expected