+
+
+
+--
+-- * 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
+ to_tuple m = (xml_driver_id m,
+ xml_driver m,
+ xml_height m,
+ xml_weight m,
+ xml_date_of_birth m,
+ xml_hometown m,
+ xml_nationality m,
+ xml_car_number m,
+ xml_car m)
+
+-- | 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
+ to_tuple m = (xml_xml_file_id m,
+ xml_heading m,
+ xml_category m,
+ xml_sport m,
+ xml_title m,
+ xml_listings m,
+ xml_time_stamp m)
+
+
+
+--
+-- * 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