X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FInjuriesDetail.hs;h=4dda8442eca62840a55cc3ed14e51265f6eb48e2;hb=2dd451a3963893ab2d5d6c0dd2902502bb93a05a;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..4dda844 100644 --- a/src/TSN/XML/InjuriesDetail.hs +++ b/src/TSN/XML/InjuriesDetail.hs @@ -1,8 +1,8 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -13,6 +13,7 @@ -- real meat. -- module TSN.XML.InjuriesDetail ( + dtd, pickle_message, -- * Tests injuries_detail_tests, @@ -26,12 +27,21 @@ where import Control.Monad ( forM_ ) import Data.Time ( UTCTime ) import Data.Tuple.Curry ( uncurryN ) +import qualified Data.Vector.HFixed as H ( HVector, cons, convert, tail ) +import qualified Data.Vector.HFixed.Cont as H (ContVec) 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 ) +import qualified GHC.Generics as GHC ( Generic ) import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) import Text.XML.HXT.Core ( @@ -53,11 +63,20 @@ 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(..), pickle_unpickle, - unpickleable ) + unpickleable, + unsafe_unpickle ) + + + +-- | The DTD to which this module corresponds. Used to invoke dbimport. +-- +dtd :: String +dtd = "Injuries_Detail_XML.dtd" -- @@ -79,12 +98,19 @@ data Message = xml_sport :: String, xml_listings :: [InjuriesDetailListingXml], xml_time_stamp :: UTCTime } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + + +-- | For 'H.convert'. +-- +instance H.HVector Message + -- | Database representation of a 'Message'. -- data InjuriesDetail = InjuriesDetail { + db_xml_file_id :: Int, db_sport :: String, db_time_stamp :: UTCTime } deriving (Eq, Show) @@ -92,6 +118,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 +127,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, @@ -130,31 +164,52 @@ data InjuriesDetailListingXml = xml_full_name :: String, -- ^ Team full name xml_player_listings :: [InjuriesDetailListingPlayerListingXml] } - deriving (Eq, Show) + deriving (Eq, GHC.Generic, Show) + + +-- | For 'H.convert'. +-- +instance H.HVector InjuriesDetailListingXml + instance ToDb InjuriesDetailListingXml where + -- | The database analogue of an 'InjuriesDetailListingXml' is a + -- 'InjuriesDetailListing'. type Db InjuriesDetailListingXml = InjuriesDetailListing -instance FromXmlFk InjuriesDetailListingXml where + +instance Child InjuriesDetailListingXml where + -- | Each 'InjuriesDetailListingXml' is contained in an + -- 'InjuriesDetail'. type Parent InjuriesDetailListingXml = InjuriesDetail + +instance FromXmlFk InjuriesDetailListingXml where + -- | 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 -- * InjuriesDetailListingPlayerListing -- | XML representation of a \, the main type of --- element contains in Injuries_Detail_XML messages. +-- element contains in Injuries_Detail_XML messages. The leading +-- underscores prevent unused field warnings. -- data InjuriesDetailListingPlayerListingXml = InjuriesDetailListingPlayerListingXml { - xml_player_team_id :: String, -- ^ TeamIDs are (apparently) three + _xml_player_team_id :: String, -- ^ TeamIDs are (apparently) three -- characters long and not -- necessarily numeric. Postgres -- imposes no performance penalty @@ -163,35 +218,45 @@ data InjuriesDetailListingPlayerListingXml = -- bound of three characters. -- We add the \"player\" to avoid conflict -- with 'InjuriesDetailListingXml'. - xml_player_id :: Int, - xml_date :: UTCTime, - xml_pos :: String, - xml_name :: String, - xml_injury :: String, - xml_status :: String, - xml_fantasy :: Maybe String, -- ^ Nobody knows what this is. - xml_injured :: Bool, - xml_type :: String } - deriving (Eq, Show) - + _xml_player_id :: Int, + _xml_date :: UTCTime, + _xml_pos :: String, + _xml_name :: String, + _xml_injury :: String, + _xml_status :: String, + _xml_fantasy :: Maybe String, -- ^ Nobody knows what this is. + _xml_injured :: Bool, + _xml_type :: String } + deriving (Eq, GHC.Generic, Show) + + +-- | For 'H.convert'. +-- +instance H.HVector InjuriesDetailListingPlayerListingXml -- | Database representation of a -- 'InjuriesDetailListingPlayerListingXml'. We drop the team_id --- because it's redundant. +-- because it's redundant. The leading underscores prevent unused +-- field warnings. -- data InjuriesDetailListingPlayerListing = InjuriesDetailListingPlayerListing { - db_injuries_detail_listings_id :: DefaultKey InjuriesDetailListing, - db_player_id :: Int, - db_date :: UTCTime, - db_pos :: String, - db_name :: String, - db_injury :: String, - db_status :: String, - db_fantasy :: Maybe String, -- ^ Nobody knows what this is. - db_injured :: Bool, - db_type :: String } + _db_injuries_detail_listings_id :: DefaultKey InjuriesDetailListing, + _db_player_id :: Int, + _db_date :: UTCTime, + _db_pos :: String, + _db_name :: String, + _db_injury :: String, + _db_status :: String, + _db_fantasy :: Maybe String, -- ^ Nobody knows what this is. + _db_injured :: Bool, + _db_type :: String } + deriving ( GHC.Generic ) + +-- | For 'H.cons', 'H.tail', etc. +-- +instance H.HVector InjuriesDetailListingPlayerListing instance ToDb InjuriesDetailListingPlayerListingXml where @@ -200,27 +265,28 @@ instance ToDb InjuriesDetailListingPlayerListingXml where type Db InjuriesDetailListingPlayerListingXml = InjuriesDetailListingPlayerListing -instance FromXmlFk InjuriesDetailListingPlayerListingXml where + +instance Child InjuriesDetailListingPlayerListingXml where + -- | Each 'InjuriesDetailListingPlayerListingXml' is contained in an + -- 'InjuriesDetailListing'. + -- type Parent InjuriesDetailListingPlayerListingXml = InjuriesDetailListing - -- | To convert between a 'InjuriesDetailListingPlayerListingXml' - -- and a 'InjuriesDetailListingPlayerListingXml', we do nothing. - from_xml_fk fk InjuriesDetailListingPlayerListingXml{..} = - InjuriesDetailListingPlayerListing { - db_injuries_detail_listings_id = fk, - db_player_id = xml_player_id, - db_date = xml_date, - db_pos = xml_pos, - db_name = xml_name, - db_injury = xml_injury, - db_status = xml_status, - db_fantasy = xml_fantasy, - 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. + +instance FromXmlFk InjuriesDetailListingPlayerListingXml where + -- | To construct a 'InjuriesDetailListingPlayerListing' from a + -- 'InjuriesDetailListingPlayerListingXml' we need to supply a + -- foreign key to an 'InjuriesDetailListing'. + -- + from_xml_fk fk = (H.cons fk) . asCont . H.tail + where + -- Should be in the library soon. + asCont :: H.ContVec a -> H.ContVec a + asCont = id + + +-- | This lets us insert the XML representation +-- 'InjuriesDetailListingPlayerListingXml' directly. -- instance XmlImportFk InjuriesDetailListingPlayerListingXml @@ -230,9 +296,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 +315,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 @@ -267,7 +341,7 @@ mkPersist tsn_codegen_config [groundhog| constructors: - name: InjuriesDetailListingPlayerListing fields: - - name: db_injuries_detail_listings_id + - name: _db_injuries_detail_listings_id reference: onDelete: cascade |] @@ -283,7 +357,7 @@ mkPersist tsn_codegen_config [groundhog| pickle_player_listing :: PU InjuriesDetailListingPlayerListingXml pickle_player_listing = xpElem "PlayerListing" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xp10Tuple (xpElem "TeamID" xpText) (xpElem "PlayerID" xpInt) (xpElem "Date" xp_date) @@ -296,16 +370,6 @@ pickle_player_listing = (xpElem "Type" xpText) where from_tuple = uncurryN InjuriesDetailListingPlayerListingXml - to_tuple pl = (xml_player_team_id pl, - xml_player_id pl, - xml_date pl, - xml_pos pl, - xml_name pl, - xml_injury pl, - xml_status pl, - xml_fantasy pl, - xml_injured pl, - xml_type pl) -- | Convert 'Listing's to/from XML. @@ -313,15 +377,12 @@ pickle_player_listing = pickle_listing :: PU InjuriesDetailListingXml pickle_listing = xpElem "Listing" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xpTriple (xpElem "TeamID" xpText) (xpElem "FullName" xpText) (xpList pickle_player_listing) where from_tuple = uncurryN InjuriesDetailListingXml - to_tuple l = (xml_team_id l, - xml_full_name l, - xml_player_listings l) -- | Convert 'Message's to/from XML. @@ -329,7 +390,7 @@ pickle_listing = pickle_message :: PU Message pickle_message = xpElem "message" $ - xpWrap (from_tuple, to_tuple) $ + xpWrap (from_tuple, H.convert) $ xp6Tuple (xpElem "XML_File_ID" xpInt) (xpElem "heading" xpText) (xpElem "category" xpText) @@ -338,12 +399,6 @@ pickle_message = (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_listings m, - xml_time_stamp m) -- @@ -356,7 +411,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 +447,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