X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FXML%2FInjuries.hs;h=368f8460c1cb95876eec92c2a6ed22dd663eed47;hb=8b7fa6040be218653c0d385134ea895d93f70bf7;hp=8b3f8d1ffc65ebbdfe244246050fb3fb46568036;hpb=3056bdb243254f0302703588213fd3d68d6115c9;p=dead%2Fhtsn-import.git diff --git a/src/TSN/XML/Injuries.hs b/src/TSN/XML/Injuries.hs index 8b3f8d1..368f846 100644 --- a/src/TSN/XML/Injuries.hs +++ b/src/TSN/XML/Injuries.hs @@ -1,9 +1,9 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -11,31 +11,46 @@ -- contains a root element \ that in turn contains zero or -- more \s. -- --- The listings will be mapped to a database table called "injuries" --- automatically. The root message is not retained. +-- The listings will be mapped to a database table called +-- \"injuries_listings\" automatically. The root message is retained +-- so that we can easily delete its associated listings based on its +-- time_stamp. -- module TSN.XML.Injuries ( - Message, - injuries_tests ) + dtd, + pickle_message, + -- * Tests + injuries_tests, + -- * WARNING: these are private but exported to silence warnings + InjuriesConstructor(..), + InjuriesListingConstructor(..) ) where +-- System imports. import Data.Data ( Data ) +import Data.Time ( UTCTime ) import Data.Typeable ( Typeable ) import Database.Groundhog ( - migrate ) + countAll, + deleteAll, + migrate, + runMigration, + silentMigrationLogger ) +import Database.Groundhog.Core ( DefaultKey ) +import Database.Groundhog.Generic ( runDbConn ) import Database.Groundhog.TH ( - defaultCodegenConfig, groundhog, mkPersist ) +import qualified GHC.Generics as GHC ( Generic ) +import Database.Groundhog.Sqlite ( withSqliteConn ) import Data.Tuple.Curry ( uncurryN ) import Test.Tasty ( TestTree, testGroup ) import Test.Tasty.HUnit ( (@?=), testCase ) import Text.XML.HXT.Core ( PU, - XmlPickler(..), xp4Tuple, xp6Tuple, - xpAttr, + xpAttrImplied, xpElem, xpInt, xpList, @@ -45,91 +60,236 @@ import Text.XML.HXT.Core ( xpText, xpWrap ) - +-- Local imports. +import Generics ( Generic(..), to_tuple ) +import TSN.Codegen ( tsn_codegen_config ) import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate ) -import TSN.XmlImport ( XmlImport(..) ) -import Xml ( FromXml(..), pickle_unpickle, unpickleable ) +import TSN.Picklers ( xp_time_stamp ) +import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) ) +import Xml ( + Child(..), + FromXml(..), + FromXmlFk(..), + ToDb(..), + pickle_unpickle, + unpickleable, + unsafe_unpickle ) + + + +-- | The DTD to which this module corresponds. Used to invoke dbimport. +-- +dtd :: String +dtd = "injuriesxml.dtd" + +-- +-- DB/XML Data types +-- + +-- * InjuriesTeam +-- | XML/Database representation of a team as they appear in the +-- injuries documents. +-- data InjuriesTeam = InjuriesTeam { - team_name :: String, - team_league :: Maybe String } + db_team_name :: String, + db_team_league :: Maybe String } deriving (Data, Eq, Show, Typeable) -data Listing = - Listing { - team :: InjuriesTeam, - teamno :: Maybe Int, - injuries :: String, - updated :: Maybe Bool } - deriving (Eq, Show) -instance FromXml Listing where - type Db Listing = Listing - from_xml = id +-- * InjuriesListing/InjuriesListingXml + +-- | XML representation of the injury listings. +-- +data InjuriesListingXml = + InjuriesListingXml { + xml_team :: InjuriesTeam, + xml_teamno :: Maybe String, -- ^ Can contain non-numerics, e.g. \"ZR2\" + xml_injuries :: String, + xml_updated :: Maybe Bool } + deriving (Eq, GHC.Generic, Show) + + +-- | For 'Generics.to_tuple'. +-- +instance Generic InjuriesListingXml + -instance XmlImport Listing +-- | Database representation of a 'InjuriesListing'. It possesses a +-- foreign key to an 'Injuries' object so that we can easily delete +-- 'InjuriesListing's based on the parent message's time_stamp. +-- +data InjuriesListing = + InjuriesListing { + db_injuries_id :: DefaultKey Injuries, + db_team :: InjuriesTeam, + db_teamno :: Maybe String, -- ^ Can contain non-numerics, e.g. \"ZR2\" + db_injuries :: String, + db_updated :: Maybe Bool } +instance ToDb InjuriesListingXml where + -- | The DB analogue of a 'InjuriesListingXml' is a 'InjuriesListing' + type Db InjuriesListingXml = InjuriesListing + +instance Child InjuriesListingXml where + -- | Our foreign key points to an 'Injuries'. + type Parent InjuriesListingXml = Injuries + +instance FromXmlFk InjuriesListingXml where + -- | To convert between a 'InjuriesListingXml' and a + -- 'InjuriesListing', we simply append the foreign key. + from_xml_fk fk InjuriesListingXml{..} = + InjuriesListing { + db_injuries_id = fk, + db_team = xml_team, + db_teamno = xml_teamno, + db_injuries = xml_injuries, + db_updated = xml_updated } + +-- | This allows us to insert the XML representation +-- 'InjuriesListingXml' directly. +-- +instance XmlImportFk InjuriesListingXml + + +-- * Injuries/Message + +-- | XML representation of an injuriesxml \. +-- data Message = Message { - xml_file_id :: Int, - heading :: String, - category :: String, - sport :: String, - listings :: [Listing], - time_stamp :: String } - deriving (Eq, Show) + xml_xml_file_id :: Int, + xml_heading :: String, + xml_category :: String, + xml_sport :: String, + xml_listings :: [InjuriesListingXml], + xml_time_stamp :: UTCTime } + deriving (Eq, GHC.Generic, Show) + + +-- | For 'Generics.to_tuple'. +-- +instance Generic Message + + +-- | Database representation of a 'Message'. +-- +data Injuries = + Injuries { + db_xml_file_id :: Int, + db_sport :: String, + db_time_stamp :: UTCTime } + +instance ToDb Message where + -- | The database analogue of a 'Message' is an 'Injuries'. + type Db Message = Injuries + +instance FromXml Message where + -- | To convert from XML to DB, we simply drop the fields we don't + -- care about. + -- + from_xml Message{..} = + Injuries { + 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 + + +-- +-- Database code +-- instance DbImport Message where - dbimport msg = mapM_ insert_xml (listings msg) >> return ImportSucceeded + dbmigrate _ = + run_dbmigrate $ do + migrate (undefined :: Injuries) + migrate (undefined :: InjuriesListing) + + -- | We import a 'Message' by inserting all of its 'listings', but + -- the listings require a foreign key to the parent 'Message'. + -- + dbimport msg = do + msg_id <- insert_xml msg + + -- Convert each XML listing to a DB one using the message id and + -- insert it (disregarding the result). + mapM_ (insert_xml_fk_ msg_id) (xml_listings msg) + + return ImportSucceeded - dbmigrate _ = run_dbmigrate $ migrate (undefined :: Listing) -mkPersist defaultCodegenConfig [groundhog| -- entity: Listing +mkPersist tsn_codegen_config [groundhog| +- entity: Injuries + constructors: + - name: Injuries + uniques: + - name: unique_injuries + type: constraint + # Prevent multiple imports of the same message. + fields: [db_xml_file_id] + +- entity: InjuriesListing dbName: injuries_listings constructors: - - name: Listing + - name: InjuriesListing fields: - - name: team + - name: db_team embeddedType: - {name: team_name, dbName: team_name} - {name: team_league, dbName: team_league} + - name: db_injuries_id + reference: + onDelete: cascade + - embedded: InjuriesTeam fields: - - name: team_name - - name: team_league + - name: db_team_name + - name: db_team_league |] +-- +-- XML Picklers +-- + + +-- | A pickler for 'InjuriesTeam's that can convert them to/from XML. +-- pickle_injuries_team :: PU InjuriesTeam pickle_injuries_team = xpElem "team" $ - xpWrap (from_tuple, to_tuple) $ - xpPair xpText (xpOption $ xpAttr "league" xpText) + xpWrap (from_tuple, to_tuple') $ + xpPair xpText (xpAttrImplied "league" xpText) where from_tuple = uncurryN InjuriesTeam - to_tuple m = (team_name m, team_league m) -instance XmlPickler InjuriesTeam where - xpickle = pickle_injuries_team + -- Pointless, but silences two unused field warnings. + to_tuple' InjuriesTeam{..} = (db_team_name, db_team_league) -pickle_listing :: PU Listing +-- | A pickler for 'InjuriesListingXml's that can convert them to/from +-- XML. +-- +pickle_listing :: PU InjuriesListingXml pickle_listing = xpElem "listing" $ xpWrap (from_tuple, to_tuple) $ xp4Tuple pickle_injuries_team - (xpOption $ xpElem "teamno" xpInt) + (xpOption $ xpElem "teamno" xpText) (xpElem "injuries" xpText) (xpOption $ xpElem "updated" xpPrim) where - from_tuple = uncurryN Listing - to_tuple l = (team l, teamno l, injuries l, updated l) + from_tuple = uncurryN InjuriesListingXml -instance XmlPickler Listing where - xpickle = pickle_listing +-- | A pickler for 'Message's that can convert them to/from XML. +-- pickle_message :: PU Message pickle_message = xpElem "message" $ @@ -139,44 +299,67 @@ pickle_message = (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) - -instance XmlPickler Message where - xpickle = pickle_message +-- +-- Tasty Tests +-- --- * Tasty Tests +-- | A list of all tests for this module. +-- injuries_tests :: TestTree injuries_tests = testGroup "Injuries 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 = testCase "pickle composed with unpickle is the identity" $ do let path = "test/xml/injuriesxml.xml" - (expected :: [Message], actual) <- pickle_unpickle "message" path + (expected, actual) <- pickle_unpickle pickle_message path actual @?= expected +-- | Make sure we can actually unpickle these things. +-- test_unpickle_succeeds :: TestTree test_unpickle_succeeds = testCase "unpickling succeeds" $ do - let path = "test/xml/injuriesxml.xml" - actual <- unpickleable path pickle_message - let expected = True - actual @?= expected + let path = "test/xml/injuriesxml.xml" + 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 = + testCase "deleting an injuries deletes its children" $ do + let path = "test/xml/injuriesxml.xml" + inj <- unsafe_unpickle path pickle_message + let a = undefined :: Injuries + let b = undefined :: InjuriesListing + actual <- withSqliteConn ":memory:" $ runDbConn $ do + runMigration silentMigrationLogger $ do + migrate a + migrate b + _ <- dbimport inj + deleteAll a + count_a <- countAll a + count_b <- countAll b + return $ count_a + count_b + let expected = 0 + actual @?= expected