{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
-- more \<listing\>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 )
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 \<message\>. This is only
--- used for (un)pickling; 'Message's are not saved to the database.
+
+-- | XML representation of an injuriesxml \<message\>.
--
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
|]
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) $
(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.
(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)
--
projects / dead / htsn-import.git / commitdiff