+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
--
module TSN.XML.AutoRacingDriverList (
dtd,
- pickle_message )
+ pickle_message,
+ -- * Tests
+ auto_racing_driver_list_tests,
+ -- * WARNING: these are private but exported to silence warnings
+ AutoRacingDriverListConstructor(..),
+ AutoRacingDriverListListingConstructor(..) )
where
-- System imports.
+import Control.Monad ( forM_ )
import Data.Time ( UTCTime(..) )
+import Data.Tuple.Curry ( uncurryN )
+import Database.Groundhog (
+ countAll,
+ deleteAll,
+ migrate,
+ runMigration,
+ silentMigrationLogger )
import Database.Groundhog.Core ( DefaultKey )
-import Text.XML.HXT.Core ( PU )
+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 (
+ PU,
+ xp7Tuple,
+ xp9Tuple,
+ xpElem,
+ xpInt,
+ xpList,
+ xpOption,
+ xpText,
+ xpWrap )
-- Local imports.
-import TSN.DbImport ( DbImport(..) )
+import Generics ( Generic(..), prepend, to_tuple )
+import TSN.Codegen ( tsn_codegen_config )
+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(..) )
+ ToDb(..),
+ pickle_unpickle,
+ unpickleable,
+ unsafe_unpickle )
-- | The DTD to which this module corresponds. Used to invoke dbimport.
--
dtd = "AutoRacingDriverList.dtd"
--
--- DB/XML data types
+-- * DB/XML data types
--
--- * AutoRacingDriverList/Message
+-- AutoRacingDriverList/Message
-- | Database representation of a 'Message'. Comparatively, it lacks
-- only the listings.
xml_title :: String,
xml_listings :: [AutoRacingDriverListListingXml],
xml_time_stamp :: UTCTime }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+
+-- | For 'Generics.to_tuple'.
+--
+instance Generic Message
instance ToDb Message where
instance XmlImport Message
--- * AutoRacingDriverListListing / AutoRacingDriverListListingXml
+-- AutoRacingDriverListListing / AutoRacingDriverListListingXml
-- | Database representation of a \<Listing\> contained within a
-- \<message\>.
--
data AutoRacingDriverListListing =
AutoRacingDriverListListing {
- db_auto_racing_driver_list_id :: DefaultKey AutoRacingDriverList,
+ db_auto_racing_driver_lists_id :: DefaultKey AutoRacingDriverList,
db_driver_id :: Int,
db_driver :: String,
db_height :: Maybe String,
db_weight :: Int,
db_date_of_birth :: UTCTime,
db_hometown :: String,
- db_nationality :: String,
+ db_nationality :: Maybe String,
db_car_number :: Int,
db_car :: String }
+ deriving ( GHC.Generic )
+
+-- | For 'Generics.prepend'.
+--
+instance Generic AutoRacingDriverListListing
+
-- | XML representation of a \<Listing\> contained within a
-- \<message\>.
xml_weight :: Int,
xml_date_of_birth :: UTCTime,
xml_hometown :: String,
- xml_nationality :: String,
+ xml_nationality :: Maybe String,
xml_car_number :: Int,
xml_car :: String }
- deriving (Eq, Show)
+ deriving (Eq, GHC.Generic, Show)
+-- | For 'Generics.to_tuple'.
+--
+instance Generic AutoRacingDriverListListingXml
instance ToDb AutoRacingDriverListListingXml where
-- | The database analogue of an 'AutoRacingDriverListListingXml' is
-- 'AutoRacingDriverListListing', we add the foreign key and copy
-- everything else verbatim.
--
- from_xml_fk fk AutoRacingDriverListListingXml{..} =
- AutoRacingDriverListListing {
- db_auto_racing_driver_list_id = fk,
- db_driver_id = xml_driver_id,
- db_driver = xml_driver,
- db_height = xml_height,
- db_weight = xml_weight,
- db_date_of_birth = xml_date_of_birth,
- db_hometown = xml_hometown,
- db_nationality = xml_nationality,
- db_car_number = xml_car_number,
- db_car = xml_car }
+ from_xml_fk = prepend
+
-- | This allows us to insert the XML representation
-- 'AutoRacingDriverListListingXml' directly.
--
instance XmlImportFk AutoRacingDriverListListingXml
+
+
+
+--
+-- * Database
+--
+
+instance DbImport Message where
+ dbmigrate _ =
+ run_dbmigrate $ do
+ migrate (undefined :: AutoRacingDriverList)
+ migrate (undefined :: AutoRacingDriverListListing)
+
+ -- | We insert the message, then use its ID to insert the listings.
+ dbimport m = do
+ msg_id <- insert_xml m
+ forM_ (xml_listings m) $ insert_xml_fk_ msg_id
+
+ return ImportSucceeded
+
+
+
+mkPersist tsn_codegen_config [groundhog|
+- entity: AutoRacingDriverList
+ dbName: auto_racing_driver_lists
+ constructors:
+ - name: AutoRacingDriverList
+ uniques:
+ - name: unique_auto_racing_driver_lists
+ type: constraint
+ # Prevent multiple imports of the same message.
+ fields: [db_xml_file_id]
+
+
+- entity: AutoRacingDriverListListing
+ dbName: auto_racing_driver_lists_listings
+ constructors:
+ - name: AutoRacingDriverListListing
+ fields:
+ - name: db_auto_racing_driver_lists_id
+ reference:
+ onDelete: cascade
+
+|]
+
+
+--
+-- * Pickling
+--
+
+-- | Pickler for the \<Listing\>s contained within \<message\>s.
+--
+pickle_listing :: PU AutoRacingDriverListListingXml
+pickle_listing =
+ xpElem "Listing" $
+ xpWrap (from_tuple, to_tuple) $
+ xp9Tuple (xpElem "DriverID" xpInt)
+ (xpElem "Driver" xpText)
+ (xpElem "Height" $ xpOption xpText)
+ (xpElem "Weight" xpInt)
+ (xpElem "DOB" xp_date)
+ (xpElem "Hometown" xpText)
+ (xpElem "Nationality" $ xpOption xpText)
+ (xpElem "Car_Number" xpInt)
+ (xpElem "Car" xpText)
+ where
+ from_tuple = uncurryN AutoRacingDriverListListingXml
+
+-- | Pickler for the top-level 'Message'.
+--
+pickle_message :: PU Message
+pickle_message =
+ xpElem "message" $
+ xpWrap (from_tuple, to_tuple) $
+ xp7Tuple (xpElem "XML_File_ID" xpInt)
+ (xpElem "heading" xpText)
+ (xpElem "category" xpText)
+ (xpElem "sport" xpText)
+ (xpElem "Title" xpText)
+ (xpList pickle_listing)
+ (xpElem "time_stamp" xp_time_stamp)
+ where
+ from_tuple = uncurryN Message
+
+
+
+--
+-- * Tasty Tests
+--
+
+-- | A list of all tests for this module.
+--
+auto_racing_driver_list_tests :: TestTree
+auto_racing_driver_list_tests =
+ testGroup
+ "AutoRacingDriverList tests"
+ [ test_on_delete_cascade,
+ test_pickle_of_unpickle_is_identity,
+ test_unpickle_succeeds ]
+
+
+-- | 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"
+ "test/xml/AutoRacingDriverList.xml" ]
+ where
+ check desc path = testCase desc $ do
+ (expected, actual) <- pickle_unpickle pickle_message path
+ actual @?= expected
+
+
+-- | Make sure we can actually unpickle these things.
+--
+test_unpickle_succeeds :: TestTree
+test_unpickle_succeeds = testGroup "unpickle tests"
+ [ check "unpickling succeeds"
+ "test/xml/AutoRacingDriverList.xml" ]
+ where
+ check desc path = testCase desc $ do
+ 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 "deleting auto_racing_driver_lists deletes its children"
+ "test/xml/AutoRacingDriverList.xml" ]
+ where
+ check desc path = testCase desc $ do
+ results <- unsafe_unpickle path pickle_message
+ let a = undefined :: AutoRacingDriverList
+ let b = undefined :: AutoRacingDriverListListing
+
+ actual <- withSqliteConn ":memory:" $ runDbConn $ do
+ runMigration silentMigrationLogger $ do
+ migrate a
+ migrate b
+ _ <- dbimport results
+ deleteAll a
+ count_a <- countAll a
+ count_b <- countAll b
+ return $ sum [count_a, count_b]
+ let expected = 0
+ actual @?= expected
projects / dead / htsn-import.git / blobdiff