src/TSN/XML/AutoRacingDriverList.hs

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