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