--- /dev/null
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- | Parse TSN XML for the DTD
+-- \"Auto_Racing_Schedule_XML.dtd\". There's a top-level
+-- \<message\>, containing \<Listing\>s, containing \<RaceResults\>,
+-- containing \<RaceResultsListing\>s.
+--
+module TSN.XML.AutoRacingSchedule (
+ pickle_message,
+ -- * Tests
+ auto_racing_schedule_tests,
+ -- * WARNING: these are private but exported to silence warnings
+ AutoRacingScheduleConstructor(..),
+ AutoRacingScheduleListingConstructor(..),
+ AutoRacingScheduleListingRaceResultRaceResultListingConstructor(..) )
+where
+
+-- System imports.
+import Control.Monad ( forM_ )
+import Data.Time ( UTCTime(..) )
+import Data.Tuple.Curry ( uncurryN )
+import Database.Groundhog (
+ countAll,
+ executeRaw,
+ migrate,
+ runMigration,
+ silentMigrationLogger )
+import Database.Groundhog.Core ( DefaultKey )
+import Database.Groundhog.Generic ( runDbConn )
+import Database.Groundhog.Sqlite ( withSqliteConn )
+import Database.Groundhog.TH (
+ groundhog,
+ mkPersist )
+import Test.Tasty ( TestTree, testGroup )
+import Test.Tasty.HUnit ( (@?=), testCase )
+import Text.XML.HXT.Core (
+ PU,
+ xp7Tuple,
+ xp8Tuple,
+ xp10Tuple,
+ xpElem,
+ xpInt,
+ xpList,
+ xpOption,
+ xpText,
+ xpWrap )
+
+-- Local imports.
+import TSN.Codegen (
+ tsn_codegen_config )
+import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
+import TSN.Picklers ( xp_date, xp_tba_time, xp_time_stamp )
+import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
+import Xml (
+ FromXml(..),
+ FromXmlFk(..),
+ ToDb(..),
+ pickle_unpickle,
+ unpickleable,
+ unsafe_unpickle )
+
+
+--
+-- DB/XML data types
+--
+
+-- * AutoRacingSchedule/Message
+
+-- | Database representation of a 'Message'.
+--
+data AutoRacingSchedule =
+ AutoRacingSchedule {
+ db_xml_file_id :: Int,
+ db_heading :: String,
+ db_category :: String,
+ db_sport :: String,
+ db_title :: String,
+ db_complete_through :: String,
+ db_time_stamp :: UTCTime }
+ deriving (Eq, Show)
+
+
+-- | XML Representation of an 'AutoRacingSchedule'.
+--
+data Message =
+ Message {
+ xml_xml_file_id :: Int,
+ xml_heading :: String,
+ xml_category :: String,
+ xml_sport :: String,
+ xml_title :: String,
+ xml_complete_through :: String,
+ xml_listings :: [AutoRacingScheduleListingXml],
+ xml_time_stamp :: UTCTime }
+ deriving (Eq, Show)
+
+instance ToDb Message where
+ type Db Message = AutoRacingSchedule
+
+instance FromXml Message where
+ from_xml Message{..} =
+ AutoRacingSchedule {
+ db_xml_file_id = xml_xml_file_id,
+ db_heading = xml_heading,
+ db_category = xml_category,
+ db_sport = xml_sport,
+ db_title = xml_title,
+ db_complete_through = xml_complete_through,
+ db_time_stamp = xml_time_stamp }
+
+instance XmlImport Message
+
+
+-- * AutoRacingScheduleListing/AutoRacingScheduleListingXml
+
+-- | Database representation of a \<Listing\> contained within a
+-- \<Message\>. We combine the race date/time into a single
+-- race_time, drop the race results list, and add a foreign key to
+-- our parent.
+data AutoRacingScheduleListing =
+ AutoRacingScheduleListing {
+ db_auto_racing_schedules_id :: DefaultKey AutoRacingSchedule,
+ db_race_id :: Int,
+ db_race_time :: UTCTime,
+ db_race_name :: String,
+ db_track_name :: String,
+ db_location :: String,
+ db_tv_listing :: Maybe String,
+ db_laps :: Int,
+ db_track_length :: String -- ^ Sometimes the word "miles" shows up.
+ }
+
+-- | XML representation of a \<Listing\> contained within a
+-- \<message\>.
+--
+data AutoRacingScheduleListingXml =
+ AutoRacingScheduleListingXml {
+ xml_race_id :: Int,
+ xml_race_date :: UTCTime,
+ xml_race_time :: Maybe UTCTime,
+ xml_race_name :: String,
+ xml_track_name :: String,
+ xml_location :: String,
+ xml_tv_listing :: Maybe String,
+ xml_laps :: Int,
+ xml_track_length :: String, -- ^ Sometimes the word \"miles\" shows up.
+ xml_race_results :: [AutoRacingScheduleListingRaceResult] }
+ deriving (Eq, Show)
+
+-- | Pseudo-accessor to get the race result listings out of a
+-- 'AutoRacingScheduleListingXml'.
+result_listings :: AutoRacingScheduleListingXml
+ -> [AutoRacingScheduleListingRaceResultRaceResultListingXml]
+result_listings = (concatMap xml_race_result_listing) . xml_race_results
+
+
+instance ToDb AutoRacingScheduleListingXml where
+ type Db AutoRacingScheduleListingXml = AutoRacingScheduleListing
+
+instance FromXmlFk AutoRacingScheduleListingXml where
+ type Parent AutoRacingScheduleListingXml = AutoRacingSchedule
+
+ from_xml_fk fk AutoRacingScheduleListingXml{..} =
+ AutoRacingScheduleListing {
+ db_auto_racing_schedules_id = fk,
+ db_race_id = xml_race_id,
+ db_race_time = make_race_time xml_race_date xml_race_time,
+ db_race_name = xml_race_name,
+ db_track_name = xml_track_name,
+ db_location = xml_location,
+ db_tv_listing = xml_tv_listing,
+ db_laps = xml_laps,
+ db_track_length = xml_track_length }
+ where
+ -- Take the day part from one, the time from the other.
+ make_race_time d Nothing = d
+ make_race_time d (Just t) = UTCTime (utctDay d) (utctDayTime t)
+
+instance XmlImportFk AutoRacingScheduleListingXml
+
+-- * AutoRacingScheduleListingRaceResult
+
+-- | The XML representation of \<message\> -> \<Listing\> ->
+-- \<RaceResults\>. This element serves only to contain
+-- \<RaceResultsListing\>s, so we don't store the intermediate table
+-- in the database.
+--
+newtype AutoRacingScheduleListingRaceResult =
+ AutoRacingScheduleListingRaceResult {
+ xml_race_result_listing ::
+ [AutoRacingScheduleListingRaceResultRaceResultListingXml] }
+ deriving (Eq, Show)
+
+-- * AutoRacingScheduleListingRaceResultRaceResultListing /
+-- AutoRacingScheduleListingRaceResultRaceResultListingXml
+
+data AutoRacingScheduleListingRaceResultRaceResultListing =
+ AutoRacingScheduleListingRaceResultRaceResultListing {
+ db_auto_racing_schedules_listings_id ::
+ DefaultKey AutoRacingScheduleListing,
+ db_finish_position :: Int,
+ db_driver_id :: Int,
+ db_name :: String,
+ db_leading_laps :: Int,
+ db_listing_laps :: Int, -- Avoid clash with race's "laps" field.
+ db_earnings :: String, -- Should be an int, but they use commas.
+ db_status :: String }
+
+data AutoRacingScheduleListingRaceResultRaceResultListingXml =
+ AutoRacingScheduleListingRaceResultRaceResultListingXml {
+ xml_finish_position :: Int,
+ xml_driver_id :: Int,
+ xml_name :: String,
+ xml_leading_laps :: Int,
+ xml_listing_laps :: Int, -- Avoid clash with race's "laps" field.
+ xml_earnings :: String, -- Should be an int, but they use commas.
+ xml_status :: String }
+ deriving (Eq, Show)
+
+instance ToDb AutoRacingScheduleListingRaceResultRaceResultListingXml where
+ type Db AutoRacingScheduleListingRaceResultRaceResultListingXml =
+ AutoRacingScheduleListingRaceResultRaceResultListing
+
+instance FromXmlFk AutoRacingScheduleListingRaceResultRaceResultListingXml where
+ type Parent AutoRacingScheduleListingRaceResultRaceResultListingXml =
+ AutoRacingScheduleListing
+
+ from_xml_fk fk AutoRacingScheduleListingRaceResultRaceResultListingXml{..} =
+ AutoRacingScheduleListingRaceResultRaceResultListing {
+ db_auto_racing_schedules_listings_id = fk,
+ db_finish_position = xml_finish_position,
+ db_driver_id = xml_driver_id,
+ db_name = xml_name,
+ db_leading_laps = xml_leading_laps,
+ db_listing_laps = xml_listing_laps,
+ db_earnings = xml_earnings,
+ db_status = xml_earnings }
+
+instance XmlImportFk AutoRacingScheduleListingRaceResultRaceResultListingXml
+
+---
+--- Database stuff.
+---
+
+instance DbImport Message where
+ dbmigrate _ =
+ run_dbmigrate $ do
+ migrate (undefined :: AutoRacingSchedule)
+ migrate (undefined :: AutoRacingScheduleListing)
+ migrate (undefined
+ :: AutoRacingScheduleListingRaceResultRaceResultListing)
+
+ dbimport m = do
+ msg_id <- insert_xml m
+
+ forM_ (xml_listings m) $ \listing -> do
+ listing_id <- insert_xml_fk msg_id listing
+
+ mapM_ (insert_xml_fk_ listing_id) (result_listings listing)
+
+ return ImportSucceeded
+
+
+mkPersist tsn_codegen_config [groundhog|
+- entity: AutoRacingSchedule
+ dbName: auto_racing_schedules
+ constructors:
+ - name: AutoRacingSchedule
+ uniques:
+ - name: unique_auto_racing_schedule
+ type: constraint
+ # Prevent multiple imports of the same message.
+ fields: [db_xml_file_id]
+
+- entity: AutoRacingScheduleListing
+ dbName: auto_racing_schedules_listings
+ constructors:
+ - name: AutoRacingScheduleListing
+ fields:
+ - name: db_auto_racing_schedules_id
+ reference:
+ onDelete: cascade
+
+- entity: AutoRacingScheduleListingRaceResultRaceResultListing
+ dbName: auto_racing_schedules_listings_race_result_listings
+ constructors:
+ - name: AutoRacingScheduleListingRaceResultRaceResultListing
+ fields:
+ - name: db_auto_racing_schedules_listings_id
+ reference:
+ onDelete: cascade
+|]
+
+
+
+---
+--- Pickling
+---
+
+-- | Pickler for the top-level 'Message'.
+--
+pickle_message :: PU Message
+pickle_message =
+ xpElem "message" $
+ xpWrap (from_tuple, to_tuple) $
+ xp8Tuple (xpElem "XML_File_ID" xpInt)
+ (xpElem "heading" xpText)
+ (xpElem "category" xpText)
+ (xpElem "sport" xpText)
+ (xpElem "Title" xpText)
+ (xpElem "Complete_Through" xpText)
+ (xpList pickle_listing)
+ (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_title m,
+ xml_complete_through m,
+ xml_listings m,
+ xml_time_stamp m)
+
+
+pickle_listing :: PU AutoRacingScheduleListingXml
+pickle_listing =
+ xpElem "Listing" $
+ xpWrap (from_tuple, to_tuple) $
+ xp10Tuple (xpElem "RaceID" xpInt)
+ (xpElem "Race_Date" xp_date)
+ (xpElem "Race_Time" xp_tba_time)
+ (xpElem "RaceName" xpText)
+ (xpElem "TrackName" xpText)
+ (xpElem "Location" xpText)
+ (xpElem "TV_Listing" $ xpOption xpText)
+ (xpElem "Laps" xpInt)
+ (xpElem "TrackLength" xpText)
+ (xpList pickle_race_results)
+ where
+ from_tuple = uncurryN AutoRacingScheduleListingXml
+ to_tuple m = (xml_race_id m,
+ xml_race_date m,
+ xml_race_time m,
+ xml_race_name m,
+ xml_track_name m,
+ xml_location m,
+ xml_tv_listing m,
+ xml_laps m,
+ xml_track_length m,
+ xml_race_results m)
+
+pickle_race_results :: PU AutoRacingScheduleListingRaceResult
+pickle_race_results =
+ xpElem "RaceResults" $
+ xpWrap (to_result, from_result) $
+ xpList pickle_race_results_listing
+ where
+ to_result = AutoRacingScheduleListingRaceResult
+ from_result = xml_race_result_listing
+
+pickle_race_results_listing ::
+ PU AutoRacingScheduleListingRaceResultRaceResultListingXml
+pickle_race_results_listing =
+ xpElem "RaceResultsListing" $
+ xpWrap (from_tuple, to_tuple) $
+ xp7Tuple (xpElem "FinishPosition" xpInt)
+ (xpElem "DriverID" xpInt)
+ (xpElem "Name" xpText)
+ (xpElem "LeadingLaps" xpInt)
+ (xpElem "Laps" xpInt)
+ (xpElem "Earnings" xpText)
+ (xpElem "Status" xpText)
+ where
+ from_tuple =
+ uncurryN AutoRacingScheduleListingRaceResultRaceResultListingXml
+
+ to_tuple m = (xml_finish_position m,
+ xml_driver_id m,
+ xml_name m,
+ xml_leading_laps m,
+ xml_listing_laps m,
+ xml_earnings m,
+ xml_status m)
+
+
+--
+-- Tasty Tests
+--
+
+-- | A list of all tests for this module.
+--
+auto_racing_schedule_tests :: TestTree
+auto_racing_schedule_tests =
+ testGroup
+ "AutoRacingSchedule 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/Auto_Racing_Schedule_XML.xml",
+
+ check "pickle composed with unpickle is the identity (miles track length)"
+ "test/xml/Auto_Racing_Schedule_XML-miles-track-length.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/Auto_Racing_Schedule_XML.xml",
+
+ check "unpickling succeeds (non-int team_id)"
+ "test/xml/Auto_Racing_Schedule_XML-miles-track-length.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_schedules deletes its children"
+ "test/xml/Auto_Racing_Schedule_XML.xml" ,
+
+ check ("deleting auto_racing_schedules deletes its children " ++
+ "(miles track length)")
+ "test/xml/Auto_Racing_Schedule_XML-miles-track-length.xml" ]
+ where
+ check desc path = testCase desc $ do
+ sched <- unsafe_unpickle path pickle_message
+ let a = undefined :: AutoRacingSchedule
+ let b = undefined :: AutoRacingScheduleListing
+ let c = undefined :: AutoRacingScheduleListingRaceResultRaceResultListing
+
+ actual <- withSqliteConn ":memory:" $ runDbConn $ do
+ runMigration silentMigrationLogger $ do
+ migrate a
+ migrate b
+ migrate c
+ _ <- dbimport sched
+ -- No idea how 'delete' works, so do this instead.
+ executeRaw False "DELETE FROM auto_racing_schedules;" []
+ count_a <- countAll a
+ count_b <- countAll b
+ count_c <- countAll c
+ return $ sum [count_a, count_b, count_c]
+ let expected = 0
+ actual @?= expected
projects / dead / htsn-import.git / blobdiff