src/TSN/XML/Injuries.hs

   1 {-# LANGUAGE DeriveGeneric #-}
   2 {-# LANGUAGE DeriveDataTypeable #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE GADTs #-}
   5 {-# LANGUAGE QuasiQuotes #-}
   6 {-# LANGUAGE RecordWildCards #-}
   7 {-# LANGUAGE TemplateHaskell #-}
   8 {-# LANGUAGE TypeFamilies #-}
   9
  10 -- | Parse TSN XML for the DTD "injuriesxml.dtd". Each document
  11 --   contains a root element \<message\> that in turn contains zero or
  12 --   more \<listing\>s.
  13 --
  14 --   The listings will be mapped to a database table called
  15 --   \"injuries_listings\" automatically. The root message is retained
  16 --   so that we can easily delete its associated listings based on its
  17 --   time_stamp.
  18 --
  19 module TSN.XML.Injuries (
  20   dtd,
  21   pickle_message,
  22   -- * Tests
  23   injuries_tests,
  24   -- * WARNING: these are private but exported to silence warnings
  25   InjuriesConstructor(..),
  26   InjuriesListingConstructor(..) )
  27 where
  28
  29 -- System imports.
  30 import Data.Data ( Data )
  31 import Data.Time ( UTCTime )
  32 import Data.Typeable ( Typeable )
  33 import qualified Data.Vector.HFixed as H ( HVector, cons, convert )
  34 import Database.Groundhog (
  35   countAll,
  36   deleteAll,
  37   migrate )
  38 import Database.Groundhog.Core ( DefaultKey )
  39 import Database.Groundhog.Generic ( runDbConn, runMigrationSilent )
  40 import Database.Groundhog.TH (
  41   groundhog,
  42   mkPersist )
  43 import qualified GHC.Generics as GHC ( Generic )
  44 import Database.Groundhog.Sqlite ( withSqliteConn )
  45 import Data.Tuple.Curry ( uncurryN )
  46 import Test.Tasty ( TestTree, testGroup )
  47 import Test.Tasty.HUnit ( (@?=), testCase )
  48 import Text.XML.HXT.Core (
  49   PU,
  50   xp4Tuple,
  51   xp6Tuple,
  52   xpAttrImplied,
  53   xpElem,
  54   xpInt,
  55   xpList,
  56   xpOption,
  57   xpPair,
  58   xpPrim,
  59   xpText,
  60   xpWrap )
  61
  62 -- Local imports.
  63 import TSN.Codegen ( tsn_codegen_config )
  64 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  65 import TSN.Picklers ( xp_time_stamp )
  66 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
  67 import Xml (
  68   Child(..),
  69   FromXml(..),
  70   FromXmlFk(..),
  71   ToDb(..),
  72   pickle_unpickle,
  73   unpickleable,
  74   unsafe_unpickle )
  75
  76
  77
  78 -- | The DTD to which this module corresponds. Used to invoke dbimport.
  79 --
  80 dtd :: String
  81 dtd = "injuriesxml.dtd"
  82
  83 --
  84 -- DB/XML Data types
  85 --
  86
  87 -- * InjuriesTeam
  88
  89 -- | XML/Database representation of a team as they appear in the
  90 --   injuries documents.
  91 --
  92 data InjuriesTeam =
  93   InjuriesTeam {
  94     db_team_name :: String,
  95     db_team_league :: Maybe String }
  96   deriving (Data, Eq, Show, Typeable)
  97
  98
  99 -- * InjuriesListing/InjuriesListingXml
 100
 101 -- | XML representation of the injury listings. The leading
 102 --   underscores prevent unused field warnings.
 103 --
 104 data InjuriesListingXml =
 105   InjuriesListingXml {
 106     _xml_team :: InjuriesTeam,
 107     _xml_teamno :: Maybe String, -- ^ Can contain non-numerics, e.g. \"ZR2\"
 108     _xml_injuries :: String,
 109     _xml_updated :: Maybe Bool }
 110   deriving (Eq, GHC.Generic, Show)
 111
 112
 113 -- | For 'H.convert'.
 114 --
 115 instance H.HVector InjuriesListingXml
 116
 117
 118 -- | Database representation of a 'InjuriesListing'. It possesses a
 119 --   foreign key to an 'Injuries' object so that we can easily delete
 120 --   'InjuriesListing's based on the parent message's time_stamp.
 121 --   The leading underscores prevent unused field warnings.
 122 --
 123 data InjuriesListing =
 124   InjuriesListing {
 125     _db_injuries_id :: DefaultKey Injuries,
 126     _db_team :: InjuriesTeam,
 127     _db_teamno :: Maybe String, -- ^ Can contain non-numerics, e.g. \"ZR2\"
 128     _db_injuries :: String,
 129     _db_updated :: Maybe Bool }
 130   deriving ( GHC.Generic )
 131
 132 -- | For 'H.cons'.
 133 --
 134 instance H.HVector InjuriesListing
 135
 136 instance ToDb InjuriesListingXml where
 137   -- | The DB analogue of a 'InjuriesListingXml' is a 'InjuriesListing'
 138   type Db InjuriesListingXml = InjuriesListing
 139
 140 instance Child InjuriesListingXml where
 141   -- | Our foreign key points to an 'Injuries'.
 142   type Parent InjuriesListingXml = Injuries
 143
 144 instance FromXmlFk InjuriesListingXml where
 145   -- | To convert between a 'InjuriesListingXml' and a
 146   --   'InjuriesListing', we simply append the foreign key.
 147   from_xml_fk = H.cons
 148
 149 -- | This allows us to insert the XML representation
 150 --   'InjuriesListingXml' directly.
 151 --
 152 instance XmlImportFk InjuriesListingXml
 153
 154
 155 -- * Injuries/Message
 156
 157 -- | XML representation of an injuriesxml \<message\>.
 158 --
 159 data Message =
 160   Message {
 161     xml_xml_file_id :: Int,
 162     xml_heading :: String,
 163     xml_category :: String,
 164     xml_sport :: String,
 165     xml_listings :: [InjuriesListingXml],
 166     xml_time_stamp :: UTCTime }
 167   deriving (Eq, GHC.Generic, Show)
 168
 169
 170 -- | For 'H.HVector'.
 171 --
 172 instance H.HVector Message
 173
 174
 175 -- | Database representation of a 'Message'.
 176 --
 177 data Injuries =
 178   Injuries {
 179     db_xml_file_id :: Int,
 180     db_sport :: String,
 181     db_time_stamp :: UTCTime }
 182
 183 instance ToDb Message where
 184   -- | The database analogue of a 'Message' is an 'Injuries'.
 185   type Db Message = Injuries
 186
 187 instance FromXml Message where
 188   -- | To convert from XML to DB, we simply drop the fields we don't
 189   --   care about.
 190   --
 191   from_xml Message{..} =
 192     Injuries {
 193       db_xml_file_id = xml_xml_file_id,
 194       db_sport = xml_sport,
 195       db_time_stamp = xml_time_stamp }
 196
 197 -- | This allows us to insert the XML representation 'Message'
 198 --   directly.
 199 --
 200 instance XmlImport Message
 201
 202
 203 --
 204 -- Database code
 205 --
 206
 207 instance DbImport Message where
 208   dbmigrate _ =
 209     run_dbmigrate $ do
 210       migrate (undefined :: Injuries)
 211       migrate (undefined :: InjuriesListing)
 212
 213   -- | We import a 'Message' by inserting all of its 'listings', but
 214   --   the listings require a foreign key to the parent 'Message'.
 215   --
 216   dbimport msg = do
 217     msg_id <- insert_xml msg
 218
 219     -- Convert each XML listing to a DB one using the message id and
 220     -- insert it (disregarding the result).
 221     mapM_ (insert_xml_fk_ msg_id) (xml_listings msg)
 222
 223     return ImportSucceeded
 224
 225
 226 mkPersist tsn_codegen_config [groundhog|
 227 - entity: Injuries
 228   constructors:
 229     - name: Injuries
 230       uniques:
 231         - name: unique_injuries
 232           type: constraint
 233           # Prevent multiple imports of the same message.
 234           fields: [db_xml_file_id]
 235
 236 - entity: InjuriesListing
 237   dbName: injuries_listings
 238   constructors:
 239     - name: InjuriesListing
 240       fields:
 241         - name: _db_team
 242           embeddedType:
 243             - {name: team_name, dbName: team_name}
 244             - {name: team_league, dbName: team_league}
 245         - name: _db_injuries_id
 246           reference:
 247             onDelete: cascade
 248
 249 - embedded: InjuriesTeam
 250   fields:
 251     - name: db_team_name
 252     - name: db_team_league
 253 |]
 254
 255
 256 --
 257 -- XML Picklers
 258 --
 259
 260
 261 -- | A pickler for 'InjuriesTeam's that can convert them to/from XML.
 262 --
 263 pickle_injuries_team :: PU InjuriesTeam
 264 pickle_injuries_team =
 265   xpElem "team" $
 266     xpWrap (from_tuple, to_tuple') $
 267     xpPair xpText (xpAttrImplied "league" xpText)
 268   where
 269     from_tuple = uncurryN InjuriesTeam
 270
 271     -- Pointless, but silences two unused field warnings.
 272     to_tuple' InjuriesTeam{..} = (db_team_name, db_team_league)
 273
 274 -- | A pickler for 'InjuriesListingXml's that can convert them to/from
 275 --   XML.
 276 --
 277 pickle_listing :: PU InjuriesListingXml
 278 pickle_listing =
 279   xpElem "listing" $
 280     xpWrap (from_tuple, H.convert) $
 281     xp4Tuple pickle_injuries_team
 282              (xpOption $ xpElem "teamno" xpText)
 283              (xpElem "injuries" xpText)
 284              (xpOption $ xpElem "updated" xpPrim)
 285   where
 286     from_tuple = uncurryN InjuriesListingXml
 287
 288
 289
 290 -- | A pickler for 'Message's that can convert them to/from XML.
 291 --
 292 pickle_message :: PU Message
 293 pickle_message =
 294   xpElem "message" $
 295     xpWrap (from_tuple, H.convert) $
 296     xp6Tuple (xpElem "XML_File_ID" xpInt)
 297              (xpElem "heading" xpText)
 298              (xpElem "category" xpText)
 299              (xpElem "sport" xpText)
 300              (xpList pickle_listing)
 301              (xpElem "time_stamp" xp_time_stamp)
 302   where
 303     from_tuple = uncurryN Message
 304
 305
 306 --
 307 -- Tasty Tests
 308 --
 309
 310 -- | A list of all tests for this module.
 311 --
 312 injuries_tests :: TestTree
 313 injuries_tests =
 314   testGroup
 315     "Injuries tests"
 316     [ test_on_delete_cascade,
 317       test_pickle_of_unpickle_is_identity,
 318       test_unpickle_succeeds ]
 319
 320
 321 -- | If we unpickle something and then pickle it, we should wind up
 322 --   with the same thing we started with. WARNING: success of this
 323 --   test does not mean that unpickling succeeded.
 324 --
 325 test_pickle_of_unpickle_is_identity :: TestTree
 326 test_pickle_of_unpickle_is_identity =
 327   testCase "pickle composed with unpickle is the identity" $ do
 328     let path = "test/xml/injuriesxml.xml"
 329     (expected, actual) <- pickle_unpickle pickle_message path
 330     actual @?= expected
 331
 332
 333 -- | Make sure we can actually unpickle these things.
 334 --
 335 test_unpickle_succeeds :: TestTree
 336 test_unpickle_succeeds =
 337   testCase "unpickling succeeds" $ do
 338     let path = "test/xml/injuriesxml.xml"
 339     actual <- unpickleable path pickle_message
 340     let expected = True
 341     actual @?= expected
 342
 343
 344 -- | Make sure everything gets deleted when we delete the top-level
 345 --   record.
 346 --
 347 test_on_delete_cascade :: TestTree
 348 test_on_delete_cascade =
 349   testCase "deleting an injuries deletes its children" $ do
 350     let path = "test/xml/injuriesxml.xml"
 351     inj <- unsafe_unpickle path pickle_message
 352     let a = undefined :: Injuries
 353     let b = undefined :: InjuriesListing
 354     actual <- withSqliteConn ":memory:" $ runDbConn $ do
 355                 runMigrationSilent $ do
 356                   migrate a
 357                   migrate b
 358                 _ <- dbimport inj
 359                 deleteAll a
 360                 count_a <- countAll a
 361                 count_b <- countAll b
 362                 return $ count_a + count_b
 363     let expected = 0
 364     actual @?= expected