src/TSN/XML/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 Control.Monad ( forM_ )
  30 import Data.Data ( Data )
  31 import Data.Time ( UTCTime )
  32 import Data.Typeable ( Typeable )
  33 import Database.Groundhog ( insert_, migrate )
  34 import Database.Groundhog.Core ( DefaultKey )
  35 import Database.Groundhog.TH (
  36   groundhog,
  37   mkPersist )
  38 import Data.Tuple.Curry ( uncurryN )
  39 import Test.Tasty ( TestTree, testGroup )
  40 import Test.Tasty.HUnit ( (@?=), testCase )
  41 import Text.XML.HXT.Core (
  42   PU,
  43   xp4Tuple,
  44   xp6Tuple,
  45   xpAttrImplied,
  46   xpElem,
  47   xpInt,
  48   xpList,
  49   xpOption,
  50   xpPair,
  51   xpPrim,
  52   xpText,
  53   xpWrap )
  54
  55 -- Local imports.
  56 import TSN.Codegen ( tsn_codegen_config )
  57 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  58 import TSN.Picklers ( xp_time_stamp )
  59 import TSN.XmlImport ( XmlImport(..) )
  60 import Xml ( FromXml(..), FromXmlFk(..), pickle_unpickle, unpickleable )
  61
  62 -- | XML/Database representation of a team as they appear in the
  63 --   injuries documents.
  64 --
  65 data InjuriesTeam =
  66   InjuriesTeam {
  67     db_team_name :: String,
  68     db_team_league :: Maybe String }
  69   deriving (Data, Eq, Show, Typeable)
  70
  71
  72 -- | XML/Database representation of the injury listings.
  73 --
  74 data InjuriesListingXml =
  75   InjuriesListingXml {
  76     xml_team :: InjuriesTeam,
  77     xml_teamno :: Maybe Int,
  78     xml_injuries :: String,
  79     xml_updated :: Maybe Bool }
  80   deriving (Eq, Show)
  81
  82 -- | Database representation of a 'InjuriesListing'. It possesses a
  83 -- foreign key to an 'Injuries' object so that we can easily delete
  84 -- 'InjuriesListing's based on the parent message's time_stamp.
  85 --
  86 data InjuriesListing =
  87   InjuriesListing {
  88     db_injuries_id :: DefaultKey Injuries,
  89     db_team :: InjuriesTeam,
  90     db_teamno :: Maybe Int,
  91     db_injuries :: String,
  92     db_updated :: Maybe Bool }
  93
  94
  95 instance FromXmlFk InjuriesListingXml where
  96   -- | The DB analogue of a 'InjuriesListingXml' is a 'InjuriesListing'
  97   type DbFk InjuriesListingXml = InjuriesListing
  98
  99   -- | Our foreign key points to an 'Injuries'.
 100   type Parent InjuriesListingXml = Injuries
 101
 102   -- | To convert between a 'InjuriesListingXml' and a
 103   --   'InjuriesListing', we simply append the foreign key.
 104   from_xml_fk InjuriesListingXml{..} fk =
 105     InjuriesListing {
 106       db_injuries_id = fk,
 107       db_team = xml_team,
 108       db_teamno = xml_teamno,
 109       db_injuries = xml_injuries,
 110       db_updated = xml_updated }
 111
 112
 113 -- | XML representation of an injuriesxml \<message\>.
 114 --
 115 data Message =
 116   Message {
 117     xml_xml_file_id :: Int,
 118     xml_heading :: String,
 119     xml_category :: String,
 120     xml_sport :: String,
 121     xml_listings :: [InjuriesListingXml],
 122     xml_time_stamp :: UTCTime }
 123   deriving (Eq, Show)
 124
 125 -- | Database representation of a 'Message'. We really only care about
 126 --   the time stamp.
 127 --
 128 data Injuries =
 129   Injuries {
 130     db_sport :: String,
 131     db_time_stamp :: UTCTime }
 132
 133 instance FromXml Message where
 134   -- | The database analogue of a 'Message' is an 'Injuries'.
 135   type Db Message = Injuries
 136
 137   -- | To convert from XML to DB, we simply drop the fields we don't
 138   --   care about.
 139   --
 140   from_xml Message{..} =
 141     Injuries {
 142       db_sport = xml_sport,
 143       db_time_stamp = xml_time_stamp }
 144
 145 instance XmlImport Message
 146
 147
 148 instance DbImport Message where
 149   dbmigrate _ =
 150     run_dbmigrate $ do
 151       migrate (undefined :: Injuries)
 152       migrate (undefined :: InjuriesListing)
 153
 154   -- | We import a 'Message' by inserting all of its 'listings'.
 155   --
 156   dbimport msg = do
 157     msg_id <- insert_xml msg
 158
 159     forM_ (xml_listings msg) $ \listing ->
 160       -- Convert the XML listing to a DB one using the message id and
 161       -- insert it (disregarding the result).
 162       insert_ $ from_xml_fk listing msg_id
 163
 164     return ImportSucceeded
 165
 166
 167 mkPersist tsn_codegen_config [groundhog|
 168 - entity: Injuries
 169
 170 - entity: InjuriesListing
 171   dbName: injuries_listings
 172   constructors:
 173     - name: InjuriesListing
 174       fields:
 175         - name: db_team
 176           embeddedType:
 177             - {name: team_name, dbName: team_name}
 178             - {name: team_league, dbName: team_league}
 179         - name: db_injuries_id
 180           reference:
 181             onDelete: cascade
 182
 183 - embedded: InjuriesTeam
 184   fields:
 185     - name: db_team_name
 186     - name: db_team_league
 187 |]
 188
 189
 190 -- | A pickler for 'InjuriesTeam's that can convert them to/from XML.
 191 --
 192 pickle_injuries_team :: PU InjuriesTeam
 193 pickle_injuries_team =
 194   xpElem "team" $
 195     xpWrap (from_tuple, to_tuple) $
 196     xpPair xpText (xpAttrImplied "league" xpText)
 197   where
 198     from_tuple = uncurryN InjuriesTeam
 199     to_tuple m = (db_team_name m, db_team_league m)
 200
 201
 202 -- | A pickler for 'InjuriesListingXml's that can convert them to/from XML.
 203 --
 204 pickle_listing :: PU InjuriesListingXml
 205 pickle_listing =
 206   xpElem "listing" $
 207     xpWrap (from_tuple, to_tuple) $
 208     xp4Tuple pickle_injuries_team
 209              (xpOption $ xpElem "teamno" xpInt)
 210              (xpElem "injuries" xpText)
 211              (xpOption $ xpElem "updated" xpPrim)
 212   where
 213     from_tuple = uncurryN InjuriesListingXml
 214     to_tuple l = (xml_team l, xml_teamno l, xml_injuries l, xml_updated l)
 215
 216
 217 -- | A pickler for 'Message's that can convert them to/from XML.
 218 --
 219 pickle_message :: PU Message
 220 pickle_message =
 221   xpElem "message" $
 222     xpWrap (from_tuple, to_tuple) $
 223     xp6Tuple (xpElem "XML_File_ID" xpInt)
 224              (xpElem "heading" xpText)
 225              (xpElem "category" xpText)
 226              (xpElem "sport" xpText)
 227              (xpList pickle_listing)
 228              (xpElem "time_stamp" xp_time_stamp)
 229   where
 230     from_tuple = uncurryN Message
 231     to_tuple m = (xml_xml_file_id m,
 232                   xml_heading m,
 233                   xml_category m,
 234                   xml_sport m,
 235                   xml_listings m,
 236                   xml_time_stamp m)
 237
 238
 239 --
 240 -- Tasty Tests
 241 --
 242
 243 -- | A list of all tests for this module.
 244 --
 245 injuries_tests :: TestTree
 246 injuries_tests =
 247   testGroup
 248     "Injuries tests"
 249     [ test_pickle_of_unpickle_is_identity,
 250       test_unpickle_succeeds ]
 251
 252
 253 -- | If we unpickle something and then pickle it, we should wind up
 254 --   with the same thing we started with. WARNING: success of this
 255 --   test does not mean that unpickling succeeded.
 256 --
 257 test_pickle_of_unpickle_is_identity :: TestTree
 258 test_pickle_of_unpickle_is_identity =
 259   testCase "pickle composed with unpickle is the identity" $ do
 260     let path = "test/xml/injuriesxml.xml"
 261     (expected, actual) <- pickle_unpickle pickle_message path
 262     actual @?= expected
 263
 264
 265 -- | Make sure we can actually unpickle these things.
 266 --
 267 test_unpickle_succeeds :: TestTree
 268 test_unpickle_succeeds =
 269   testCase "unpickling succeeds" $ do
 270   let path = "test/xml/injuriesxml.xml"
 271   actual <- unpickleable path pickle_message
 272   let expected = True
 273   actual @?= expected