From 49d528dc6b0a7b79ae17990872fdd7f58b80abc7 Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Mon, 20 Jan 2014 16:24:35 -0500 Subject: [PATCH] Add a top-level injuries table for TSN.XML.Injuries. --- src/TSN/XML/Injuries.hs | 168 +++++++++++++++++++++++++++------------- 1 file changed, 115 insertions(+), 53 deletions(-) diff --git a/src/TSN/XML/Injuries.hs b/src/TSN/XML/Injuries.hs index 94baa19..d2b4e10 100644 --- a/src/TSN/XML/Injuries.hs +++ b/src/TSN/XML/Injuries.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -11,24 +12,27 @@ -- more \s. -- -- The listings will be mapped to a database table called --- \"injuries_listings\" automatically. The root message is not --- retained. +-- \"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 ( pickle_message, -- * Tests injuries_tests, -- * WARNING: these are private but exported to silence warnings - ListingConstructor(..) ) + InjuriesConstructor(..), + InjuriesListingConstructor(..) ) where -- System imports. +import Control.Monad ( forM_ ) import Data.Data ( Data ) +import Data.Time ( UTCTime ) import Data.Typeable ( Typeable ) -import Database.Groundhog ( - migrate ) +import Database.Groundhog ( insert_, migrate ) +import Database.Groundhog.Core ( DefaultKey ) import Database.Groundhog.TH ( - defaultCodegenConfig, groundhog, mkPersist ) import Data.Tuple.Curry ( uncurryN ) @@ -49,79 +53,137 @@ import Text.XML.HXT.Core ( 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(..) ) -import Xml ( FromXml(..), pickle_unpickle, unpickleable ) +import Xml ( FromXml(..), FromXmlFk(..), pickle_unpickle, unpickleable ) -- | XML/Database representation of a team as they appear in the -- injuries documents. -- data InjuriesTeam = InjuriesTeam { - team_name :: String, - team_league :: Maybe String } + db_team_name :: String, + db_team_league :: Maybe String } deriving (Data, Eq, Show, Typeable) -- | XML/Database representation of the injury listings. -- -data Listing = - Listing { - team :: InjuriesTeam, - teamno :: Maybe Int, - injuries :: String, - updated :: Maybe Bool } +data InjuriesListingXml = + InjuriesListingXml { + xml_team :: InjuriesTeam, + xml_teamno :: Maybe Int, + xml_injuries :: String, + xml_updated :: Maybe Bool } deriving (Eq, Show) +-- | 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. +-- +data InjuriesListing = + InjuriesListing { + db_injuries_id :: DefaultKey Injuries, + db_team :: InjuriesTeam, + db_teamno :: Maybe Int, + db_injuries :: String, + db_updated :: Maybe Bool } -instance FromXml Listing where - -- | The DB analogue of a 'Listing' is... itself! - type Db Listing = Listing - -- | To convert between a 'Listing' and a 'Listing', we do nothing. - from_xml = id +instance FromXmlFk InjuriesListingXml where + -- | The DB analogue of a 'InjuriesListingXml' is a 'InjuriesListing' + type DbFk InjuriesListingXml = InjuriesListing --- | This lets us call 'insert_xml' on a 'Listing' without having to --- explicitly convert it to its database analogue first. --- -instance XmlImport Listing + -- | Our foreign key points to an 'Injuries'. + type Parent InjuriesListingXml = Injuries + -- | To convert between a 'InjuriesListingXml' and a + -- 'InjuriesListing', we simply append the foreign key. + from_xml_fk InjuriesListingXml{..} fk = + InjuriesListing { + db_injuries_id = fk, + db_team = xml_team, + db_teamno = xml_teamno, + db_injuries = xml_injuries, + db_updated = xml_updated } --- | XML representation of an injuriesxml \. This is only --- used for (un)pickling; 'Message's are not saved to the database. + +-- | XML representation of an injuriesxml \. -- data Message = Message { - xml_file_id :: Int, - heading :: String, - category :: String, - sport :: String, - listings :: [Listing], - time_stamp :: String -- ^ Slightly lax, but we don't save it, so who cares. - } + xml_xml_file_id :: Int, + xml_heading :: String, + xml_category :: String, + xml_sport :: String, + xml_listings :: [InjuriesListingXml], + xml_time_stamp :: UTCTime } deriving (Eq, Show) +-- | Database representation of a 'Message'. We really only care about +-- the time stamp. +-- +data Injuries = + Injuries { + db_sport :: String, + db_time_stamp :: UTCTime } + +instance FromXml Message where + -- | The database analogue of a 'Message' is an 'Injuries'. + type Db Message = Injuries + + -- | To convert from XML to DB, we simply drop the fields we don't + -- care about. + -- + from_xml Message{..} = + Injuries { + db_sport = xml_sport, + db_time_stamp = xml_time_stamp } + +instance XmlImport Message + + instance DbImport Message where + dbmigrate _ = + run_dbmigrate $ do + migrate (undefined :: Injuries) + migrate (undefined :: InjuriesListing) + -- | We import a 'Message' by inserting all of its 'listings'. -- - dbimport msg = mapM_ insert_xml (listings msg) >> return ImportSucceeded + dbimport msg = do + msg_id <- insert_xml msg + + forM_ (xml_listings msg) $ \listing -> + -- Convert the XML listing to a DB one using the message id and + -- insert it (disregarding the result). + insert_ $ from_xml_fk listing msg_id - dbmigrate _ = run_dbmigrate $ migrate (undefined :: Listing) + return ImportSucceeded -mkPersist defaultCodegenConfig [groundhog| -- entity: Listing + +mkPersist tsn_codegen_config [groundhog| +- entity: Injuries + +- entity: InjuriesListing dbName: injuries_listings constructors: - - name: Listing + - name: InjuriesListing fields: - - name: team + - 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: team_name - - name: team_league + - name: db_team_name + - name: db_team_league |] @@ -134,12 +196,12 @@ pickle_injuries_team = xpPair xpText (xpAttrImplied "league" xpText) where from_tuple = uncurryN InjuriesTeam - to_tuple m = (team_name m, team_league m) + to_tuple m = (db_team_name m, db_team_league m) --- | A pickler for 'Listings's that can convert them to/from XML. +-- | A pickler for 'InjuriesListingXml's that can convert them to/from XML. -- -pickle_listing :: PU Listing +pickle_listing :: PU InjuriesListingXml pickle_listing = xpElem "listing" $ xpWrap (from_tuple, to_tuple) $ @@ -148,8 +210,8 @@ pickle_listing = (xpElem "injuries" xpText) (xpOption $ xpElem "updated" xpPrim) where - from_tuple = uncurryN Listing - to_tuple l = (team l, teamno l, injuries l, updated l) + from_tuple = uncurryN InjuriesListingXml + to_tuple l = (xml_team l, xml_teamno l, xml_injuries l, xml_updated l) -- | A pickler for 'Message's that can convert them to/from XML. @@ -163,15 +225,15 @@ pickle_message = (xpElem "category" xpText) (xpElem "sport" xpText) (xpList pickle_listing) - (xpElem "time_stamp" xpText) + (xpElem "time_stamp" xp_time_stamp) where from_tuple = uncurryN Message - to_tuple m = (xml_file_id m, - heading m, - category m, - sport m, - listings m, - time_stamp m) + to_tuple m = (xml_xml_file_id m, + xml_heading m, + xml_category m, + xml_sport m, + xml_listings m, + xml_time_stamp m) -- -- 2.43.2