+{-# 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 \<message\> that in turn
-- contains zero or more \<Listing\>s (note: capitalization). The
--- \<Listing\>s contain \<PlayerListing\>s then contain the real
--- meat; everything contained in the parent \<Listing\> can also be
--- found within the \<PlayerListing\>s.
---
--- The player listings will be mapped to a database table called
--- "injuries_detail" automatically. The root "message" and "listing"
--- are not retained.
+-- \<Listing\>s contain \<PlayerListing\>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 (
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 \<message\> 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 \<Listing\> 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 \<Listing\> 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 \<PlayerListing\>, 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"
actual @?= expected
+-- | Make sure we can actually unpickle these things.
+--
test_unpickle_succeeds :: TestTree
test_unpickle_succeeds = testGroup "unpickle tests"
[ check "unpickling succeeds"
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
projects / dead / htsn-import.git / blobdiff