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