Injuries.hs

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