ScheduleChanges.hs

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

-- | Parse TSN XML for the DTD \"Schedule_Changes_XML.dtd\". Each
--   \<message\> element contains zero or more \<Schedule_Change\>
--   which are just a wrapper around zero or more \<SC_Listing\>s.
--
--   The teams appear to use the shared "TSN.Team" representation.
--
module TSN.XML.ScheduleChanges (
  dtd,
  pickle_message,
  -- * Tests
  schedule_changes_tests,
  -- * WARNING: these are private but exported to silence warnings
  ScheduleChangesConstructor(..),
  ScheduleChangesListingConstructor(..) )
where

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

-- Local imports.
import TSN.Codegen ( tsn_codegen_config )
import TSN.Database ( insert_or_select )
import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
import TSN.Picklers ( xp_date_padded, xp_tba_time, xp_time_stamp )
import TSN.Team ( Team(..), HTeam(..), VTeam(..) )
import TSN.XmlImport ( XmlImport(..) )
import Xml (
  FromXml(..),
  ToDb(..),
  pickle_unpickle,
  unpickleable,
  unsafe_unpickle )



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


--
-- DB/XML data types
--

-- * ScheduleChanges/Message

-- | Database representation of a 'Message'. Comparatively, it lacks
--   the listings since they are linked via a foreign key.
--
data ScheduleChanges =
  ScheduleChanges {
    db_xml_file_id :: Int,
    db_heading :: String,
    db_category :: String,
    db_sport :: String,
    db_time_stamp :: UTCTime }
  deriving (Eq, Show)


-- | XML representation of a \<Schedule_Change\> within a
--   \<message\>. These are wrappers around a bunch of
--   \<SC_Listing\>s, but they also contain the sport name for all of
--   the contained listings.
--
data ScheduleChangeXml =
  ScheduleChangeXml {
    xml_sc_sport :: String,
    xml_sc_listings :: [ScheduleChangesListingXml] }
  deriving (Eq, GHC.Generic, Show)


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


-- | XML representation of a 'ScheduleChanges'. It has the same
--   fields, but in addition contains the 'xml_listings'.
--
data Message =
  Message {
    xml_xml_file_id :: Int,
    xml_heading :: String,
    xml_category :: String,
    xml_sport :: String,
    xml_schedule_changes :: [ScheduleChangeXml],
    xml_time_stamp :: UTCTime }
  deriving (Eq, GHC.Generic, Show)


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


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


-- | The 'FromXml' instance for 'Message' is required for the
--   'XmlImport' instance.
--
instance FromXml Message where
  -- | To convert a 'Message' to an 'ScheduleChanges', we just drop
  --   the 'xml_schedule_changes'.
  --
  from_xml Message{..} =
    ScheduleChanges {
      db_xml_file_id = xml_xml_file_id,
      db_heading = xml_heading,
      db_category = xml_category,
      db_sport = xml_sport,
      db_time_stamp = xml_time_stamp }


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



-- * ScheduleChangesListing/ScheduleChangesListingXml

-- | An embedded type within 'ScheduleChangesListing'. These look
--   like, \<status numeral=\"4\"\>FINAL\</status\> within the XML,
--   but they're in one-to-one correspondence with the listings.
--
--   The leading underscores prevent unused field warnings.
--
data ScheduleChangesListingStatus =
  ScheduleChangesListingStatus {
    _db_status_numeral :: Int,
    _db_status         :: Maybe String } -- Yes, they can be empty.
  deriving (Eq, GHC.Generic, Show)


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


-- | Database representation of a \<SC_Listing\> contained within a
--   \<Schedule_Change\>, within a \<message\>. During the transition
--   to the database, we drop the intermediate \<Schedule_Change\>
--   leaving the listing keyed to the 'ScheduleChanges' itself.
--
--   The home/away teams reuse the 'Team' representation.
--
--   The sport name (sc_sport) is pulled out of the containing
--   \<Schedule_Change\> and embedded into the listings themselves.
--
data ScheduleChangesListing =
  ScheduleChangesListing {
    db_schedule_changes_id :: DefaultKey ScheduleChanges,
    db_away_team_id :: DefaultKey Team,
    db_home_team_id ::DefaultKey Team,
    db_type :: String,
    db_sc_sport :: String,
    db_schedule_id :: Int,
    db_game_time :: UTCTime,
    db_location :: Maybe String,
    db_vscore :: Int,
    db_hscore :: Int,
    db_listing_status :: ScheduleChangesListingStatus,
    db_notes :: Maybe String }


-- | XML representation of a \<SC_Listing\> contained within a
--   \<Schedule_Change\>, within a \<message\>.
--
data ScheduleChangesListingXml =
  ScheduleChangesListingXml {
    xml_type :: String,
    xml_schedule_id :: Int,
    xml_game_date :: UTCTime,
    xml_game_time :: Maybe UTCTime,
    xml_location :: Maybe String,
    xml_away_team :: VTeam,
    xml_home_team :: HTeam,
    xml_vscore :: Int,
    xml_hscore :: Int,
    xml_listing_status :: ScheduleChangesListingStatus,
    xml_notes :: Maybe String }
  deriving (Eq, GHC.Generic, Show)


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


instance ToDb ScheduleChangesListingXml where
  -- | The database analogue of an 'ScheduleChangesListingXml' is
  --   an 'ScheduleChangesListing'.
  --
  type Db ScheduleChangesListingXml = ScheduleChangesListing



-- | We don't make 'ScheduleChangesListingXml' an instance of
--   'FromXmlFkTeams' because it needs some additional information,
--   namely the sport name from its containing \<Schedule_Change\>.
--   But essentially we'll need to do the same thing as
--   'from_xml_fk_teams'. This function accomplishes the same thing,
--   with the addition of the sport that's passed in.
--
--   The parameter order is for convenience later (see dbimport).
--
from_xml_fk_sport :: (DefaultKey ScheduleChanges)
                  -> String -- ^ The sport from our containing schedule change
                  -> (DefaultKey Team) -- ^ Away team FK
                  -> (DefaultKey Team) -- ^ Home team FK
                  -> ScheduleChangesListingXml
                  -> ScheduleChangesListing
from_xml_fk_sport fk sport fk_away fk_home ScheduleChangesListingXml{..} =
  ScheduleChangesListing {
    db_schedule_changes_id = fk,
    db_away_team_id = fk_away,
    db_home_team_id = fk_home,
    db_type = xml_type,
    db_sc_sport = sport,
    db_schedule_id = xml_schedule_id,
    db_game_time = make_game_time xml_game_date xml_game_time,
    db_location = xml_location,
    db_vscore = xml_vscore,
    db_hscore = xml_hscore,
    db_listing_status = xml_listing_status,
    db_notes = xml_notes }
  where
    -- | Make the database \"game time\" from the XML
    --   date/time. Simply take the day part from one and the time
    --   from the other.
    --
    make_game_time d Nothing = d
    make_game_time d (Just t) = UTCTime (utctDay d) (utctDayTime t)



--
-- * Database stuff.
--

instance DbImport Message where
  dbmigrate _ =
    run_dbmigrate $ do
      migrate (undefined :: Team)
      migrate (undefined :: ScheduleChanges)
      migrate (undefined :: ScheduleChangesListing)

  dbimport m = do
    -- Insert the top-level message
    msg_id <- insert_xml m

    -- Now loop through the message's schedule changes
    forM_ (xml_schedule_changes m) $ \sc -> do
      -- Construct the function that will turn an XML listing into a DB one.
      -- This is only partially applied without the away/home team IDs.
      let listing_xml_to_db = from_xml_fk_sport msg_id (xml_sc_sport sc)

      -- Now loop through the listings so that we can handle the teams
      -- one listing at a time.
      forM_ (xml_sc_listings sc) $ \listing -> do
        away_team_id <- insert_or_select (vteam $ xml_away_team listing)
        home_team_id <- insert_or_select (hteam $ xml_home_team listing)

        -- Finish constructing the xml -> db function.
        let listing_xml_to_db' = listing_xml_to_db away_team_id home_team_id
        let db_listing = listing_xml_to_db' listing

        insert_ db_listing

    return ImportSucceeded


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

  # Note: we drop the "sc" prefix from the db_sc_sport field.
- entity: ScheduleChangesListing
  dbName: schedule_changes_listings
  constructors:
    - name: ScheduleChangesListing
      fields:
        - name: db_schedule_changes_id
          reference:
            onDelete: cascade
        - name: db_away_team_id
          reference:
            onDelete: cascade
        - name: db_home_team_id
          reference:
            onDelete: cascade
        - name: db_sc_sport
          dbName: sport
        - name: db_listing_status
          embeddedType:
            - {name: status_numeral, dbName: status_numeral}
            - {name: status, dbName: status}

- embedded: ScheduleChangesListingStatus
  fields:
    - name: _db_status_numeral
      dbName: status_numeral
    - name: _db_status
      dbName: status

|]



--
-- * Pickling
--

-- | An (un)pickler for the \<Away_Team\> elements.
--
pickle_away_team :: PU VTeam
pickle_away_team =
  xpElem "Away_Team" $
    xpWrap (from_tuple, to_tuple') $
    xpPair (xpAttr "AT_ID" xpText)
           (xpOption xpText)
  where
    from_tuple (x,y) = VTeam (Team x Nothing y)
    to_tuple' (VTeam t) = (team_id t, name t)


-- | An (un)pickler for the \<Away_Team\> elements.
--
pickle_home_team :: PU HTeam
pickle_home_team =
  xpElem "Home_Team" $
    xpWrap (from_tuple, to_tuple') $
    xpPair (xpAttr "HT_ID" xpText)
           (xpOption xpText)
  where
    from_tuple (x,y) = HTeam (Team x Nothing y)
    to_tuple' (HTeam t) = (team_id t, name t)


-- | An (un)pickler for the \<status\> elements.
--
pickle_status :: PU ScheduleChangesListingStatus
pickle_status =
  xpElem "status" $
    xpWrap (from_tuple, H.convert) $
    xpPair (xpAttr "numeral" xpInt)
           (xpOption xpText)
  where
    from_tuple = uncurry ScheduleChangesListingStatus


-- | An (un)pickler for the \<SC_Listing\> elements.
--
pickle_listing :: PU ScheduleChangesListingXml
pickle_listing =
  xpElem "SC_Listing" $
    xpWrap (from_tuple, H.convert) $
    xp11Tuple (xpAttr "type" xpText)
              (xpElem "Schedule_ID" xpInt)
              (xpElem "Game_Date" xp_date_padded)
              (xpElem "Game_Time" xp_tba_time)
              (xpElem "Location" (xpOption xpText))
              pickle_away_team
              pickle_home_team
              (xpElem "vscore" xpInt)
              (xpElem "hscore" xpInt)
              pickle_status
              (xpElem "notes" (xpOption xpText))
  where
    from_tuple = uncurryN ScheduleChangesListingXml


-- | An (un)pickler for the \<Schedule_Change\> elements.
--
pickle_schedule_change :: PU ScheduleChangeXml
pickle_schedule_change =
  xpElem "Schedule_Change" $
    xpWrap (from_tuple, H.convert) $
    xpPair (xpAttr "Sport" xpText)
           (xpList pickle_listing)
  where
    from_tuple = uncurry ScheduleChangeXml


-- | Pickler for the top-level 'Message'.
--
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_schedule_change)
             (xpElem "time_stamp" xp_time_stamp)
  where
    from_tuple = uncurryN Message



--
-- * Tests
--
-- | A list of all tests for this module.
--
schedule_changes_tests :: TestTree
schedule_changes_tests =
  testGroup
    "ScheduleChanges 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/Schedule_Changes_XML.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/Schedule_Changes_XML.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 auto_racing_results deletes its children" $ do
    let path = "test/xml/Schedule_Changes_XML.xml"
    results <- unsafe_unpickle path pickle_message
    let a = undefined :: Team
    let b = undefined :: ScheduleChanges
    let c = undefined :: ScheduleChangesListing

    actual <- withSqliteConn ":memory:" $ runDbConn $ do
                runMigrationSilent $ do
                  migrate a
                  migrate b
                  migrate c
                _ <- dbimport results
                deleteAll b
                count_a <- countAll a
                count_b <- countAll b
                count_c <- countAll c
                return $ sum [count_a, count_b, count_c]
    let expected = 12 -- There are 16 team elements, but 4 are dupes,
                      -- so 12 unique teams should be left over.
    actual @?= expected