src/TSN/XML/AutoRacingDriverList.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE QuasiQuotes #-}
   4 {-# LANGUAGE RecordWildCards #-}
   5 {-# LANGUAGE TemplateHaskell #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7
   8
   9 -- | Parse TSN XML for the DTD \"AutoRacingDriverList.dtd\". Each
  10 --   \<message\> element contains a bunch of \<Listing\>s, each of
  11 --   which describes a driver/car.
  12 --
  13 module TSN.XML.AutoRacingDriverList (
  14   dtd,
  15   pickle_message,
  16   -- * Tests
  17   auto_racing_driver_list_tests,
  18   -- * WARNING: these are private but exported to silence warnings
  19   AutoRacingDriverListConstructor(..),
  20   AutoRacingDriverListListingConstructor(..) )
  21 where
  22
  23 -- System imports.
  24 import Control.Monad ( forM_ )
  25 import Data.Time ( UTCTime(..) )
  26 import Data.Tuple.Curry ( uncurryN )
  27 import Database.Groundhog (
  28   countAll,
  29   deleteAll,
  30   migrate,
  31   runMigration,
  32   silentMigrationLogger )
  33 import Database.Groundhog.Core ( DefaultKey )
  34 import Database.Groundhog.Generic ( runDbConn )
  35 import Database.Groundhog.Sqlite ( withSqliteConn )
  36 import Database.Groundhog.TH (
  37   groundhog,
  38   mkPersist )
  39 import Test.Tasty ( TestTree, testGroup )
  40 import Test.Tasty.HUnit ( (@?=), testCase )
  41 import Text.XML.HXT.Core (
  42   PU,
  43   xp7Tuple,
  44   xp9Tuple,
  45   xpElem,
  46   xpInt,
  47   xpList,
  48   xpOption,
  49   xpText,
  50   xpWrap )
  51
  52 -- Local imports.
  53 import TSN.Codegen ( tsn_codegen_config )
  54 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  55 import TSN.Picklers ( xp_date, xp_time_stamp )
  56 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
  57 import Xml (
  58   Child(..),
  59   FromXml(..),
  60   FromXmlFk(..),
  61   ToDb(..),
  62   pickle_unpickle,
  63   unpickleable,
  64   unsafe_unpickle )
  65
  66 -- | The DTD to which this module corresponds. Used to invoke dbimport.
  67 --
  68 dtd :: String
  69 dtd = "AutoRacingDriverList.dtd"
  70
  71 --
  72 -- * DB/XML data types
  73 --
  74
  75 -- AutoRacingDriverList/Message
  76
  77 -- | Database representation of a 'Message'. Comparatively, it lacks
  78 --   only the listings.
  79 --
  80 data AutoRacingDriverList =
  81   AutoRacingDriverList {
  82     db_xml_file_id :: Int,
  83     db_heading :: String,
  84     db_category :: String,
  85     db_sport :: String,
  86     db_title :: String,
  87     db_time_stamp :: UTCTime }
  88   deriving (Eq, Show)
  89
  90
  91
  92 -- | XML Representation of an 'AutoRacingDriverList'. It has the same
  93 --   fields, but in addition contains the 'xml_listings'.
  94 --
  95 data Message =
  96   Message {
  97     xml_xml_file_id :: Int,
  98     xml_heading :: String,
  99     xml_category :: String,
 100     xml_sport :: String,
 101     xml_title :: String,
 102     xml_listings :: [AutoRacingDriverListListingXml],
 103     xml_time_stamp :: UTCTime }
 104   deriving (Eq, Show)
 105
 106
 107 instance ToDb Message where
 108   -- | The database analogue of a 'Message' is a 'AutoRacingDriverList'.
 109   --
 110   type Db Message = AutoRacingDriverList
 111
 112
 113 -- | The 'FromXml' instance for 'Message' is required for the
 114 --   'XmlImport' instance.
 115 --
 116 instance FromXml Message where
 117   -- | To convert a 'Message' to an 'AutoRacingDriverList', we just drop
 118   --   the 'xml_listings'.
 119   --
 120   from_xml Message{..} =
 121     AutoRacingDriverList {
 122       db_xml_file_id = xml_xml_file_id,
 123       db_heading = xml_heading,
 124       db_category = xml_category,
 125       db_sport = xml_sport,
 126       db_title = xml_title,
 127       db_time_stamp = xml_time_stamp }
 128
 129
 130 -- | This allows us to insert the XML representation 'Message'
 131 --   directly.
 132 --
 133 instance XmlImport Message
 134
 135
 136 -- AutoRacingDriverListListing / AutoRacingDriverListListingXml
 137
 138 -- | Database representation of a \<Listing\> contained within a
 139 --   \<message\>.
 140 --
 141 data AutoRacingDriverListListing =
 142   AutoRacingDriverListListing {
 143     db_auto_racing_driver_lists_id :: DefaultKey AutoRacingDriverList,
 144     db_driver_id :: Int,
 145     db_driver :: String,
 146     db_height :: Maybe String,
 147     db_weight :: Int,
 148     db_date_of_birth :: UTCTime,
 149     db_hometown :: String,
 150     db_nationality :: Maybe String,
 151     db_car_number :: Int,
 152     db_car :: String }
 153
 154 -- | XML representation of a \<Listing\> contained within a
 155 --   \<message\>.
 156 --
 157 data AutoRacingDriverListListingXml =
 158   AutoRacingDriverListListingXml {
 159     xml_driver_id :: Int,
 160     xml_driver :: String,
 161     xml_height :: Maybe String,
 162     xml_weight :: Int,
 163     xml_date_of_birth :: UTCTime,
 164     xml_hometown :: String,
 165     xml_nationality :: Maybe String,
 166     xml_car_number :: Int,
 167     xml_car :: String }
 168   deriving (Eq, Show)
 169
 170
 171 instance ToDb AutoRacingDriverListListingXml where
 172   -- | The database analogue of an 'AutoRacingDriverListListingXml' is
 173   --   an 'AutoRacingDriverListListing'.
 174   --
 175   type Db AutoRacingDriverListListingXml = AutoRacingDriverListListing
 176
 177
 178 instance Child AutoRacingDriverListListingXml where
 179   -- | Each 'AutoRacingDriverListListingXml' is contained in (i.e. has a
 180   --   foreign key to) a 'AutoRacingDriverList'.
 181   --
 182   type Parent AutoRacingDriverListListingXml = AutoRacingDriverList
 183
 184
 185 instance FromXmlFk AutoRacingDriverListListingXml where
 186   -- | To convert an 'AutoRacingDriverListListingXml' to an
 187   --   'AutoRacingDriverListListing', we add the foreign key and copy
 188   --   everything else verbatim.
 189   --
 190   from_xml_fk fk AutoRacingDriverListListingXml{..} =
 191     AutoRacingDriverListListing {
 192       db_auto_racing_driver_lists_id = fk,
 193       db_driver_id = xml_driver_id,
 194       db_driver = xml_driver,
 195       db_height = xml_height,
 196       db_weight = xml_weight,
 197       db_date_of_birth = xml_date_of_birth,
 198       db_hometown = xml_hometown,
 199       db_nationality = xml_nationality,
 200       db_car_number = xml_car_number,
 201       db_car = xml_car }
 202
 203
 204 -- | This allows us to insert the XML representation
 205 --   'AutoRacingDriverListListingXml' directly.
 206 --
 207 instance XmlImportFk AutoRacingDriverListListingXml
 208
 209
 210
 211 --
 212 -- * Database
 213 --
 214
 215 instance DbImport Message where
 216   dbmigrate _ =
 217     run_dbmigrate $ do
 218       migrate (undefined :: AutoRacingDriverList)
 219       migrate (undefined :: AutoRacingDriverListListing)
 220
 221   -- | We insert the message, then use its ID to insert the listings.
 222   dbimport m = do
 223     msg_id <- insert_xml m
 224     forM_ (xml_listings m) $ insert_xml_fk_ msg_id
 225
 226     return ImportSucceeded
 227
 228
 229
 230 mkPersist tsn_codegen_config [groundhog|
 231 - entity: AutoRacingDriverList
 232   dbName: auto_racing_driver_lists
 233   constructors:
 234     - name: AutoRacingDriverList
 235       uniques:
 236         - name: unique_auto_racing_driver_lists
 237           type: constraint
 238           # Prevent multiple imports of the same message.
 239           fields: [db_xml_file_id]
 240
 241
 242 - entity: AutoRacingDriverListListing
 243   dbName: auto_racing_driver_lists_listings
 244   constructors:
 245     - name: AutoRacingDriverListListing
 246       fields:
 247         - name: db_auto_racing_driver_lists_id
 248           reference:
 249             onDelete: cascade
 250
 251 |]
 252
 253
 254 --
 255 -- * Pickling
 256 --
 257
 258 -- | Pickler for the \<Listing\>s contained within \<message\>s.
 259 --
 260 pickle_listing :: PU AutoRacingDriverListListingXml
 261 pickle_listing =
 262   xpElem "Listing" $
 263     xpWrap (from_tuple, to_tuple) $
 264     xp9Tuple (xpElem "DriverID" xpInt)
 265              (xpElem "Driver" xpText)
 266              (xpElem "Height" $ xpOption xpText)
 267              (xpElem "Weight" xpInt)
 268              (xpElem "DOB" xp_date)
 269              (xpElem "Hometown" xpText)
 270              (xpElem "Nationality" $ xpOption xpText)
 271              (xpElem "Car_Number" xpInt)
 272              (xpElem "Car" xpText)
 273   where
 274     from_tuple = uncurryN AutoRacingDriverListListingXml
 275     to_tuple m = (xml_driver_id m,
 276                   xml_driver m,
 277                   xml_height m,
 278                   xml_weight m,
 279                   xml_date_of_birth m,
 280                   xml_hometown m,
 281                   xml_nationality m,
 282                   xml_car_number m,
 283                   xml_car m)
 284
 285 -- | Pickler for the top-level 'Message'.
 286 --
 287 pickle_message :: PU Message
 288 pickle_message =
 289   xpElem "message" $
 290     xpWrap (from_tuple, to_tuple) $
 291     xp7Tuple (xpElem "XML_File_ID" xpInt)
 292              (xpElem "heading" xpText)
 293              (xpElem "category" xpText)
 294              (xpElem "sport" xpText)
 295              (xpElem "Title" xpText)
 296              (xpList pickle_listing)
 297              (xpElem "time_stamp" xp_time_stamp)
 298   where
 299     from_tuple = uncurryN Message
 300     to_tuple m = (xml_xml_file_id m,
 301                   xml_heading m,
 302                   xml_category m,
 303                   xml_sport m,
 304                   xml_title m,
 305                   xml_listings m,
 306                   xml_time_stamp m)
 307
 308
 309
 310 --
 311 -- * Tasty Tests
 312 --
 313
 314 -- | A list of all tests for this module.
 315 --
 316 auto_racing_driver_list_tests :: TestTree
 317 auto_racing_driver_list_tests =
 318   testGroup
 319     "AutoRacingDriverList tests"
 320     [ test_on_delete_cascade,
 321       test_pickle_of_unpickle_is_identity,
 322       test_unpickle_succeeds ]
 323
 324
 325 -- | If we unpickle something and then pickle it, we should wind up
 326 --   with the same thing we started with. WARNING: success of this
 327 --   test does not mean that unpickling succeeded.
 328 --
 329 test_pickle_of_unpickle_is_identity :: TestTree
 330 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 331   [ check "pickle composed with unpickle is the identity"
 332           "test/xml/AutoRacingDriverList.xml" ]
 333   where
 334     check desc path = testCase desc $ do
 335       (expected, actual) <- pickle_unpickle pickle_message path
 336       actual @?= expected
 337
 338
 339 -- | Make sure we can actually unpickle these things.
 340 --
 341 test_unpickle_succeeds :: TestTree
 342 test_unpickle_succeeds = testGroup "unpickle tests"
 343   [ check "unpickling succeeds"
 344           "test/xml/AutoRacingDriverList.xml" ]
 345   where
 346     check desc path = testCase desc $ do
 347       actual <- unpickleable path pickle_message
 348       let expected = True
 349       actual @?= expected
 350
 351
 352 -- | Make sure everything gets deleted when we delete the top-level
 353 --   record.
 354 --
 355 test_on_delete_cascade :: TestTree
 356 test_on_delete_cascade = testGroup "cascading delete tests"
 357   [ check "deleting auto_racing_driver_lists deletes its children"
 358           "test/xml/AutoRacingDriverList.xml" ]
 359   where
 360     check desc path = testCase desc $ do
 361       results <- unsafe_unpickle path pickle_message
 362       let a = undefined :: AutoRacingDriverList
 363       let b = undefined :: AutoRacingDriverListListing
 364
 365       actual <- withSqliteConn ":memory:" $ runDbConn $ do
 366                   runMigration silentMigrationLogger $ do
 367                     migrate a
 368                     migrate b
 369                   _ <- dbimport results
 370                   deleteAll a
 371                   count_a <- countAll a
 372                   count_b <- countAll b
 373                   return $ sum [count_a, count_b]
 374       let expected = 0
 375       actual @?= expected