Injuries.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

-- | Parse TSN XML for the DTD "injuriesxml.dtd". Each document
--   contains a root element \<message\> that in turn contains zero or
--   more \<listing\>s.
--
--   The listings will be mapped to a database table called
--   \"injuries_listings\" automatically. The root message is retained
--   so that we can easily delete its associated listings based on its
--   time_stamp.
--
module TSN.XML.Injuries (
  dtd,
  pickle_message,
  -- * Tests
  injuries_tests,
  -- * WARNING: these are private but exported to silence warnings
  InjuriesConstructor(..),
  InjuriesListingConstructor(..) )
where

-- System imports.
import Data.Data ( Data )
import Data.Time ( UTCTime )
import Data.Typeable ( Typeable )
import qualified Data.Vector.HFixed as H ( HVector, cons, convert )
import Database.Groundhog (
  countAll,
  deleteAll,
  migrate )
import Database.Groundhog.Core ( DefaultKey )
import Database.Groundhog.Generic ( runDbConn, runMigrationSilent )
import Database.Groundhog.TH (
  groundhog,
  mkPersist )
import qualified GHC.Generics as GHC ( Generic )
import Database.Groundhog.Sqlite ( withSqliteConn )
import Data.Tuple.Curry ( uncurryN )
import Test.Tasty ( TestTree, testGroup )
import Test.Tasty.HUnit ( (@?=), testCase )
import Text.XML.HXT.Core (
  PU,
  xp4Tuple,
  xp6Tuple,
  xpAttrImplied,
  xpElem,
  xpInt,
  xpList,
  xpOption,
  xpPair,
  xpPrim,
  xpText,
  xpWrap )

-- Local imports.
import TSN.Codegen ( tsn_codegen_config )
import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
import TSN.Picklers ( xp_time_stamp )
import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
import Xml (
  Child(..),
  FromXml(..),
  FromXmlFk(..),
  ToDb(..),
  pickle_unpickle,
  unpickleable,
  unsafe_unpickle )



-- | The DTD to which this module corresponds. Used to invoke dbimport.
--
dtd :: String
dtd = "injuriesxml.dtd"

--
-- DB/XML Data types
--

-- * InjuriesTeam

-- | XML/Database representation of a team as they appear in the
--   injuries documents.
--
data InjuriesTeam =
  InjuriesTeam {
    db_team_name :: String,
    db_team_league :: Maybe String }
  deriving (Data, Eq, Show, Typeable)


-- * InjuriesListing/InjuriesListingXml

-- | XML representation of the injury listings. The leading
--   underscores prevent unused field warnings.
--
data InjuriesListingXml =
  InjuriesListingXml {
    _xml_team :: InjuriesTeam,
    _xml_teamno :: Maybe String, -- ^ Can contain non-numerics, e.g. \"ZR2\"
    _xml_injuries :: String,
    _xml_updated :: Maybe Bool }
  deriving (Eq, GHC.Generic, Show)


-- | For 'H.convert'.
--
instance H.HVector InjuriesListingXml


-- | Database representation of a 'InjuriesListing'. It possesses a
--   foreign key to an 'Injuries' object so that we can easily delete
--   'InjuriesListing's based on the parent message's time_stamp.
--   The leading underscores prevent unused field warnings.
--
data InjuriesListing =
  InjuriesListing {
    _db_injuries_id :: DefaultKey Injuries,
    _db_team :: InjuriesTeam,
    _db_teamno :: Maybe String, -- ^ Can contain non-numerics, e.g. \"ZR2\"
    _db_injuries :: String,
    _db_updated :: Maybe Bool }
  deriving ( GHC.Generic )

-- | For 'H.cons'.
--
instance H.HVector InjuriesListing

instance ToDb InjuriesListingXml where
  -- | The DB analogue of a 'InjuriesListingXml' is a 'InjuriesListing'
  type Db InjuriesListingXml = InjuriesListing

instance Child InjuriesListingXml where
  -- | Our foreign key points to an 'Injuries'.
  type Parent InjuriesListingXml = Injuries

instance FromXmlFk InjuriesListingXml where
  -- | To convert between a 'InjuriesListingXml' and a
  --   'InjuriesListing', we simply append the foreign key.
  from_xml_fk = H.cons

-- | This allows us to insert the XML representation
--   'InjuriesListingXml' directly.
--
instance XmlImportFk InjuriesListingXml


-- * Injuries/Message

-- | XML representation of an injuriesxml \<message\>.
--
data Message =
  Message {
    xml_xml_file_id :: Int,
    xml_heading :: String,
    xml_category :: String,
    xml_sport :: String,
    xml_listings :: [InjuriesListingXml],
    xml_time_stamp :: UTCTime }
  deriving (Eq, GHC.Generic, Show)


-- | For 'H.HVector'.
--
instance H.HVector Message


-- | Database representation of a 'Message'.
--
data Injuries =
  Injuries {
    db_xml_file_id :: Int,
    db_sport :: String,
    db_time_stamp :: UTCTime }

instance ToDb Message where
  -- | The database analogue of a 'Message' is an 'Injuries'.
  type Db Message = Injuries

instance FromXml Message where
  -- | To convert from XML to DB, we simply drop the fields we don't
  --   care about.
  --
  from_xml Message{..} =
    Injuries {
      db_xml_file_id = xml_xml_file_id,
      db_sport = xml_sport,
      db_time_stamp = xml_time_stamp }

-- | This allows us to insert the XML representation 'Message'
--   directly.
--
instance XmlImport Message


--
-- Database code
--

instance DbImport Message where
  dbmigrate _ =
    run_dbmigrate $ do
      migrate (undefined :: Injuries)
      migrate (undefined :: InjuriesListing)

  -- | We import a 'Message' by inserting all of its 'listings', but
  --   the listings require a foreign key to the parent 'Message'.
  --
  dbimport msg = do
    msg_id <- insert_xml msg

    -- Convert each XML listing to a DB one using the message id and
    -- insert it (disregarding the result).
    mapM_ (insert_xml_fk_ msg_id) (xml_listings msg)

    return ImportSucceeded


mkPersist tsn_codegen_config [groundhog|
- entity: Injuries
  constructors:
    - name: Injuries
      uniques:
        - name: unique_injuries
          type: constraint
          # Prevent multiple imports of the same message.
          fields: [db_xml_file_id]

- entity: InjuriesListing
  dbName: injuries_listings
  constructors:
    - name: InjuriesListing
      fields:
        - name: _db_team
          embeddedType:
            - {name: team_name, dbName: team_name}
            - {name: team_league, dbName: team_league}
        - name: _db_injuries_id
          reference:
            onDelete: cascade

- embedded: InjuriesTeam
  fields:
    - name: db_team_name
    - name: db_team_league
|]


--
-- XML Picklers
--


-- | A pickler for 'InjuriesTeam's that can convert them to/from XML.
--
pickle_injuries_team :: PU InjuriesTeam
pickle_injuries_team =
  xpElem "team" $
    xpWrap (from_tuple, to_tuple') $
    xpPair xpText (xpAttrImplied "league" xpText)
  where
    from_tuple = uncurryN InjuriesTeam

    -- Pointless, but silences two unused field warnings.
    to_tuple' InjuriesTeam{..} = (db_team_name, db_team_league)

-- | A pickler for 'InjuriesListingXml's that can convert them to/from
--   XML.
--
pickle_listing :: PU InjuriesListingXml
pickle_listing =
  xpElem "listing" $
    xpWrap (from_tuple, H.convert) $
    xp4Tuple pickle_injuries_team
             (xpOption $ xpElem "teamno" xpText)
             (xpElem "injuries" xpText)
             (xpOption $ xpElem "updated" xpPrim)
  where
    from_tuple = uncurryN InjuriesListingXml



-- | A pickler for 'Message's that can convert them to/from XML.
--
pickle_message :: PU Message
pickle_message =
  xpElem "message" $
    xpWrap (from_tuple, H.convert) $
    xp6Tuple (xpElem "XML_File_ID" xpInt)
             (xpElem "heading" xpText)
             (xpElem "category" xpText)
             (xpElem "sport" xpText)
             (xpList pickle_listing)
             (xpElem "time_stamp" xp_time_stamp)
  where
    from_tuple = uncurryN Message


--
-- Tasty Tests
--

-- | A list of all tests for this module.
--
injuries_tests :: TestTree
injuries_tests =
  testGroup
    "Injuries tests"
    [ test_on_delete_cascade,
      test_pickle_of_unpickle_is_identity,
      test_unpickle_succeeds ]


-- | If we unpickle something and then pickle it, we should wind up
--   with the same thing we started with. WARNING: success of this
--   test does not mean that unpickling succeeded.
--
test_pickle_of_unpickle_is_identity :: TestTree
test_pickle_of_unpickle_is_identity =
  testCase "pickle composed with unpickle is the identity" $ do
    let path = "test/xml/injuriesxml.xml"
    (expected, actual) <- pickle_unpickle pickle_message path
    actual @?= expected


-- | Make sure we can actually unpickle these things.
--
test_unpickle_succeeds :: TestTree
test_unpickle_succeeds =
  testCase "unpickling succeeds" $ do
    let path = "test/xml/injuriesxml.xml"
    actual <- unpickleable path pickle_message
    let expected = True
    actual @?= expected


-- | Make sure everything gets deleted when we delete the top-level
--   record.
--
test_on_delete_cascade :: TestTree
test_on_delete_cascade =
  testCase "deleting an injuries deletes its children" $ do
    let path = "test/xml/injuriesxml.xml"
    inj <- unsafe_unpickle path pickle_message
    let a = undefined :: Injuries
    let b = undefined :: InjuriesListing
    actual <- withSqliteConn ":memory:" $ runDbConn $ do
                runMigrationSilent $ do
                  migrate a
                  migrate b
                _ <- dbimport inj
                deleteAll a
                count_a <- countAll a
                count_b <- countAll b
                return $ count_a + count_b
    let expected = 0
    actual @?= expected