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