X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FInjuriesDetail.hs;h=4dda8442eca62840a55cc3ed14e51265f6eb48e2;hb=2dd451a3963893ab2d5d6c0dd2902502bb93a05a;hp=c06768ed554c2f9aa399afd948f23838f79ace62;hpb=2f0d419104ac1ad108ae1b29d6722ed032286665;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/InjuriesDetail.hs b/src/TSN/XML/InjuriesDetail.hs index c06768e..4dda844 100644 --- a/src/TSN/XML/InjuriesDetail.hs +++ b/src/TSN/XML/InjuriesDetail.hs @@ -1,34 +1,47 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -- | Parse TSN XML for the DTD "Injuries_Detail_XML.dtd". Each -- document contains a root element \ that in turn -- contains zero or more \s (note: capitalization). The --- \s contain \s then contain the real --- meat; everything contained in the parent \ can also be --- found within the \s. --- --- The player listings will be mapped to a database table called --- "injuries_detail" automatically. The root "message" and "listing" --- are not retained. +-- \s contain \s which then contain the +-- real meat. -- module TSN.XML.InjuriesDetail ( + dtd, + pickle_message, + -- * Tests injuries_detail_tests, - pickle_message ) + -- * WARNING: these are private but exported to silence warnings + InjuriesDetailConstructor(..), + InjuriesDetailListingConstructor(..), + InjuriesDetailListingPlayerListingConstructor(..) ) where +-- System imports. +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 ( - migrate ) + DefaultKey, + countAll, + deleteAll, + migrate, + runMigration, + silentMigrationLogger ) +import Database.Groundhog.Generic ( runDbConn ) +import Database.Groundhog.Sqlite ( withSqliteConn ) import Database.Groundhog.TH ( - defaultCodegenConfig, groundhog, mkPersist ) +import qualified GHC.Generics as GHC ( Generic ) import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) import Text.XML.HXT.Core ( @@ -39,148 +52,374 @@ import Text.XML.HXT.Core ( xpElem, xpInt, xpList, + xpOption, xpPrim, xpText, - xpText0, xpWrap ) -import TSN.Picklers( xp_date, xp_team_id ) +-- Local imports. +import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) -import TSN.XmlImport ( XmlImport(..) ) -import Xml ( FromXml(..), pickle_unpickle, unpickleable ) - - -data PlayerListing = - PlayerListing { - team_id :: String, -- ^ TeamIDs are (apparently) three characters long - -- and not necessarily numeric. - player_id :: Int, - date :: UTCTime, - pos :: String, - name :: String, - injury :: String, - status :: String, - fantasy :: String, -- ^ Nobody knows what this is. - injured :: Bool, - injury_type :: String -- ^ "type" is a reserved keyword so we can't use it - } - deriving (Eq, Show) +import TSN.Picklers( xp_date, xp_time_stamp ) +import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) ) +import Xml ( + Child(..), + FromXml(..), + FromXmlFk(..), + ToDb(..), + pickle_unpickle, + unpickleable, + unsafe_unpickle ) -instance FromXml PlayerListing where - type Db PlayerListing = PlayerListing - from_xml = id -instance XmlImport PlayerListing -data Listing = - Listing { - listing_team_id :: String -- ^ Avoid conflict with PlayerListing's team_id. - -- TeamIDs are (apparently) three characters - -- long and not necessarily numeric. - , full_name :: String, -- ^ Team full name - player_listings :: [PlayerListing] } - deriving (Eq, Show) +-- | The DTD to which this module corresponds. Used to invoke dbimport. +-- +dtd :: String +dtd = "Injuries_Detail_XML.dtd" +-- +-- Data types +-- + + +-- * InjuriesDetail/Message + + +-- | XML representation of the top-level \ element. These +-- are not stored; the data type is used only for parsing. +-- data Message = Message { - xml_file_id :: Int, - heading :: String, - category :: String, - sport :: String, - listings :: [Listing], - time_stamp :: String } + xml_xml_file_id :: Int, + xml_heading :: String, + xml_category :: String, + xml_sport :: String, + xml_listings :: [InjuriesDetailListingXml], + xml_time_stamp :: UTCTime } + 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) +instance ToDb Message where + -- | The database representation of a 'Message' is an + -- 'InjuriesDetail'. + -- + type Db Message = InjuriesDetail + +instance FromXml Message where + -- | To convert a 'Message' into an 'InjuriesDetail', we simply drop + -- a few fields. + -- + 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 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, + db_team_id :: String, + db_full_name :: String } + + +-- | XML incarnation of a \ element. We don't store these; +-- the data type is used only for parsing. +-- +data InjuriesDetailListingXml = + InjuriesDetailListingXml { + xml_team_id :: String, -- ^ TeamIDs are (apparently) three + -- characters long and not necessarily + -- numeric. + + xml_full_name :: String, -- ^ Team full name + xml_player_listings :: [InjuriesDetailListingPlayerListingXml] } + 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 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. The leading +-- underscores prevent unused field warnings. +-- +data InjuriesDetailListingPlayerListingXml = + InjuriesDetailListingPlayerListingXml { + _xml_player_team_id :: String, -- ^ TeamIDs are (apparently) three + -- characters long and not + -- necessarily numeric. Postgres + -- imposes no performance penalty + -- on a lengthless text field, so + -- we ignore the likely upper + -- 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, GHC.Generic, Show) + + +-- | For 'H.convert'. +-- +instance H.HVector InjuriesDetailListingPlayerListingXml + + +-- | Database representation of a +-- 'InjuriesDetailListingPlayerListingXml'. We drop the team_id +-- 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 } + deriving ( GHC.Generic ) + +-- | For 'H.cons', 'H.tail', etc. +-- +instance H.HVector InjuriesDetailListingPlayerListing + + +instance ToDb InjuriesDetailListingPlayerListingXml where + -- | The DB analogue of a 'InjuriesDetailListingPlayerListingXml' is + -- 'InjuriesDetailListingPlayerListing'. + type Db InjuriesDetailListingPlayerListingXml = + InjuriesDetailListingPlayerListing + + +instance Child InjuriesDetailListingPlayerListingXml where + -- | Each 'InjuriesDetailListingPlayerListingXml' is contained in an + -- 'InjuriesDetailListing'. + -- + type Parent InjuriesDetailListingPlayerListingXml = InjuriesDetailListing + + +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 + + +-- +-- Database stuff +-- + 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. + -- dbimport msg = do - mapM_ insert_xml (concatMap player_listings $ listings msg) + msg_id <- insert_xml msg + + forM_ (xml_listings msg) $ \listing -> do + l_id <- insert_xml_fk msg_id listing + mapM_ (insert_xml_fk_ l_id) (xml_player_listings listing) + return ImportSucceeded - dbmigrate _ = run_dbmigrate $ migrate (undefined :: PlayerListing) -mkPersist defaultCodegenConfig [groundhog| -- entity: PlayerListing - dbName: injuries_detail_player_listings +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 + constructors: + - name: InjuriesDetailListing + fields: + - name: db_injuries_detail_id + reference: + onDelete: cascade + +- entity: InjuriesDetailListingPlayerListing + dbName: injuries_detail_listings_player_listings constructors: - - name: PlayerListing + - name: InjuriesDetailListingPlayerListing fields: - - name: team_id - type: varchar(3) + - name: _db_injuries_detail_listings_id + reference: + onDelete: cascade |] -pickle_player_listing :: PU PlayerListing + +-- +-- Pickling +-- + +-- | Convert 'InjuriesDetailListingPlayerListingXml's to/from XML. +-- +pickle_player_listing :: PU InjuriesDetailListingPlayerListingXml pickle_player_listing = xpElem "PlayerListing" $ - xpWrap (from_tuple, to_tuple) $ - xp10Tuple (xpElem "TeamID" xp_team_id) + xpWrap (from_tuple, H.convert) $ + xp10Tuple (xpElem "TeamID" xpText) (xpElem "PlayerID" xpInt) (xpElem "Date" xp_date) (xpElem "Pos" xpText) (xpElem "Name" xpText) (xpElem "Injury" xpText) (xpElem "Status" xpText) - (xpElem "Fantasy" xpText0) + (xpElem "Fantasy" $ xpOption xpText) (xpElem "Injured" xpPrim) (xpElem "Type" xpText) where - from_tuple = uncurryN PlayerListing - to_tuple pl = (team_id pl, - player_id pl, - date pl, - pos pl, - name pl, - injury pl, - status pl, - fantasy pl, - injured pl, - injury_type pl) - - -pickle_listing :: PU Listing + from_tuple = uncurryN InjuriesDetailListingPlayerListingXml + + +-- | Convert 'Listing's to/from XML. +-- +pickle_listing :: PU InjuriesDetailListingXml pickle_listing = xpElem "Listing" $ - xpWrap (from_tuple, to_tuple) $ - xpTriple (xpElem "TeamID" xp_team_id) + xpWrap (from_tuple, H.convert) $ + xpTriple (xpElem "TeamID" xpText) (xpElem "FullName" xpText) (xpList pickle_player_listing) where - from_tuple = uncurryN Listing - to_tuple l = (listing_team_id l, full_name l, player_listings l) + from_tuple = uncurryN InjuriesDetailListingXml +-- | Convert 'Message's to/from XML. +-- 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) (xpElem "sport" xpText) (xpList pickle_listing) - (xpElem "time_stamp" xpText) + (xpElem "time_stamp" xp_time_stamp) where from_tuple = uncurryN Message - to_tuple m = (xml_file_id m, - heading m, - category m, - sport m, - listings m, - time_stamp m) --- * Tasty Tests +-- +-- Tasty Tests +-- + +-- | A list of all tests for this module. +-- 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 ] --- | Warning, succeess of this test does not mean that unpickling --- succeeded. +-- | 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" @@ -194,6 +433,8 @@ test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests" actual @?= expected +-- | Make sure we can actually unpickle these things. +-- test_unpickle_succeeds :: TestTree test_unpickle_succeeds = testGroup "unpickle tests" [ check "unpickling succeeds" @@ -206,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