Write import_injuries, import_injuries_detail, and import_news for the new type class.
Move DbImport instances into the module where the type is defined.
Get the News import working (temporarily) via unsafeCoerce.
import Control.Arrow ( (&&&), arr, returnA )
import Control.Monad ( when )
import Control.Monad.IO.Class ( MonadIO, liftIO )
-import Database.Groundhog (
- defaultMigrationLogger,
- insert,
- migrate,
- runMigration )
-import Database.Groundhog.Core ( PersistBackend, PersistEntity )
import Database.Groundhog.Generic ( runDbConn )
import Database.Groundhog.Sqlite (
withSqliteConn )
import Database.Groundhog.Postgresql (
withPostgresqlConn )
import Data.Monoid ( (<>) )
+import Network.Services.TSN.Logging ( init_logging )
import System.Console.CmdArgs ( def )
import System.Exit ( exitWith, ExitCode (ExitFailure) )
import System.IO.Error ( catchIOError )
import Text.XML.HXT.Core (
ArrowXml,
IOStateArrow,
- XmlPickler,
XmlTree,
(>>>),
(/>),
getText,
hasName,
readDocument,
- runX,
- unpickleDoc,
- xpickle )
+ runX )
import Backend ( Backend(..) )
import CommandLine ( get_args )
import Configuration ( Configuration(..), merge_optional )
import ConnectionString ( ConnectionString(..) )
import ExitCodes ( exit_no_xml_files )
-import Network.Services.TSN.Logging ( init_logging )
import qualified OptionalConfiguration as OC (
OptionalConfiguration ( xml_files ),
from_rc )
import Network.Services.TSN.Report (
report_info,
report_error )
-import qualified TSN.Injuries as Injuries (
- Listing,
- Message ( listings ) )
-import qualified TSN.InjuriesDetail as InjuriesDetail (
- Listing ( player_listings ),
- Message ( listings ),
- PlayerListing )
+import TSN.DbImport
+import qualified TSN.Injuries as Injuries ( Listing )
+import qualified TSN.InjuriesDetail as InjuriesDetail ( PlayerListing )
import qualified TSN.News as News ( Message )
import Xml ( parse_opts )
--- | We put the 'Configuration' and 'XmlTree' arguments last so that
--- it's easy to eta reduce all of the import_foo functions that call
--- this.
---
-import_generic :: (XmlPickler a, MonadIO m, PersistEntity b, PersistBackend m)
- => b -- ^ Dummy Listing instance needed for 'migrate'
- -> (a -> [b]) -- ^ listings getter
- -> XmlTree
- -> m (Maybe Int) -- ^ Return the number of records inserted.
-import_generic dummy g xml = do
- -- Needs NoMonomorphismRestriction to be allowed to return
- -- different types in the two cases above.
- runMigration defaultMigrationLogger $ migrate dummy
- let root_element = unpickleDoc xpickle xml
- case root_element of
- Nothing -> do
- let msg = "Could not unpickle document in import_generic."
- liftIO $ report_error msg
- return Nothing
- Just elt -> do
- ids <- mapM insert (g elt)
- return $ Just (length ids)
-
-
-
--- | Import TSN.News from an 'XmlTree'.
-import_news :: (MonadIO m, PersistBackend m)
- => XmlTree
- -> m (Maybe Int)
-import_news = -- This implementation is wrroooonnnnngggg.
- import_generic
- (undefined :: News.Message)
- (\m -> [m] :: [News.Message]) -- Turn a Message into a [Message]
-
--- | Import TSN.Injuries from an 'XmlTree'.
-import_injuries :: (MonadIO m, PersistBackend m)
- => XmlTree
- -> m (Maybe Int)
-import_injuries =
- import_generic
- (undefined :: Injuries.Listing)
- Injuries.listings
-
--- | Import TSN.InjuriesDetail from an 'XmlTree'.
-import_injuries_detail :: (MonadIO m, PersistBackend m)
- => XmlTree
- -> m (Maybe Int)
-import_injuries_detail =
- import_generic
- (undefined :: InjuriesDetail.PlayerListing)
- ( (concatMap InjuriesDetail.player_listings) . InjuriesDetail.listings)
import_file :: Configuration -> FilePath -> IO ()
import_file cfg path = do
-- determine which function to call on the 'XmlTree'.
import_with_dtd :: (String, XmlTree) -> IO (Maybe Int)
import_with_dtd (dtd,xml) =
+ -- We need NoMonomorphismRestriction here.
if backend cfg == Postgres
then withPostgresqlConn cs $ runDbConn $ importer xml
else withSqliteConn cs $ runDbConn $ importer xml
cs = get_connection_string $ connection_string cfg
importer
- | dtd == "injuriesxml.dtd" = import_injuries
- | dtd == "Injuries_Detail_XML.dtd" = import_injuries_detail
- | dtd == "newsxml.dtd" = import_news
+ | dtd == "injuriesxml.dtd" =
+ dbimport (undefined :: Injuries.Listing)
+
+ | dtd == "Injuries_Detail_XML.dtd" =
+ dbimport (undefined :: InjuriesDetail.PlayerListing)
+
+ | dtd == "newsxml.dtd" =
+ dbimport (undefined :: News.Message)
+
| otherwise = \_ -> do -- Dummy arg simplifies the other cases.
let errmsg = "Unrecognized DTD in " ++ path ++ ": " ++ dtd ++ "."
liftIO $ report_info errmsg
--- /dev/null
+-- | Definition of the DbImport typeclass.
+module TSN.DbImport
+where
+
+import Control.Monad.IO.Class ( MonadIO, liftIO )
+import Database.Groundhog (
+ defaultMigrationLogger,
+ insert,
+ migrate,
+ runMigration )
+import Database.Groundhog.Core ( PersistBackend, PersistEntity )
+import Network.Services.TSN.Report ( report_error )
+import Text.XML.HXT.Core (
+ XmlPickler,
+ XmlTree,
+ unpickleDoc,
+ xpickle )
+
+-- | Instances of this type know how to insert themselves into a
+-- Groundhog database.
+class DbImport a where
+ dbimport :: (MonadIO m, PersistBackend m)
+ => a
+ -> XmlTree
+ -> m (Maybe Int)
+
+
+-- | We put the 'Configuration' and 'XmlTree' arguments last so that
+-- it's easy to eta reduce all of the import_foo functions that call
+-- this.
+--
+import_generic :: (XmlPickler a, MonadIO m, PersistEntity b, PersistBackend m)
+ => (a -> [b]) -- ^ listings getter
+ -> b -- ^ Dummy Listing instance needed for 'migrate'
+ -> XmlTree
+ -> m (Maybe Int) -- ^ Return the number of records inserted.
+import_generic g dummy xml = do
+ runMigration defaultMigrationLogger $ migrate dummy
+ let root_element = unpickleDoc xpickle xml
+ case root_element of
+ Nothing -> do
+ let msg = "Could not unpickle document in import_generic."
+ liftIO $ report_error msg
+ return Nothing
+ Just elt -> do
+ ids <- mapM insert (g elt)
+ return $ Just (length ids)
import Data.Tuple.Curry ( uncurryN )
import Database.Groundhog()
-import Database.Groundhog.TH
+import Database.Groundhog.TH (
+ defaultCodegenConfig,
+ groundhog,
+ mkPersist )
import Test.Tasty ( TestTree, testGroup )
import Test.Tasty.HUnit ( (@?=), testCase )
import Text.XML.HXT.Core (
xpWrap )
+import TSN.DbImport ( DbImport(..), import_generic )
import Xml ( pickle_unpickle )
+instance DbImport Listing where
+ dbimport = import_generic listings
+
-- * Tasty Tests
injuries_tests :: TestTree
injuries_tests =
import Data.Time ( UTCTime )
import Data.Tuple.Curry ( uncurryN )
import Database.Groundhog()
-import Database.Groundhog.TH
+import Database.Groundhog.TH (
+ defaultCodegenConfig,
+ groundhog,
+ mkPersist )
import Test.Tasty ( TestTree, testGroup )
import Test.Tasty.HUnit ( (@?=), testCase )
import Text.XML.HXT.Core (
xpText0,
xpWrap )
+import TSN.DbImport ( DbImport(..), import_generic )
import TSN.Picklers( xp_date, xp_team_id )
import Xml ( pickle_unpickle )
instance XmlPickler Message where
xpickle = pickle_message
+instance DbImport PlayerListing where
+ dbimport = import_generic ( (concatMap player_listings) . listings)
+
-- * Tasty Tests
injuries_detail_tests :: TestTree
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
news_tests )
where
+import Control.Monad.IO.Class ( MonadIO, liftIO )
+import Data.Int ( Int64 )
import Data.List.Utils ( join, split )
import Data.Tuple.Curry ( uncurryN )
-import Database.Groundhog()
-import Database.Groundhog.TH
+import Database.Groundhog (
+ defaultMigrationLogger,
+ insert,
+ migrate,
+ runMigration )
+import Database.Groundhog.Core ( DefaultKey, PersistBackend )
+import Database.Groundhog.TH (
+ defaultCodegenConfig,
+ groundhog,
+ mkPersist )
import Test.Tasty ( TestTree, testGroup )
import Test.Tasty.HUnit ( (@?=), testCase )
import Text.XML.HXT.Core (
PU,
XmlPickler(..),
+ XmlTree,
+ unpickleDoc,
xp12Tuple,
xpAttr,
xpElem,
xpText0,
xpTriple,
xpWrap )
+import Unsafe.Coerce ( unsafeCoerce )
-
+import Network.Services.TSN.Report ( report_error )
+import TSN.DbImport ( DbImport(..) )
import Xml ( pickle_unpickle )
--- Can't use a newtype with groundhog.
+-- Can't use a newtype with Groundhog.
data NewsTeam =
- NewsTeam { team_name :: String }
- deriving (Eq, Show)
+ NewsTeam {
+ nt_news_id :: Int64, -- Foreign key.
+ team_name :: String }
+deriving instance Eq NewsTeam
+deriving instance Show NewsTeam
data MsgId =
MsgId {
- msg_id :: Int,
- event_id :: String }
+ msg_id :: Int,
+ event_id :: String } -- TODO: make optional
deriving (Eq, Show)
data NewsLocation =
NewsLocation {
+ loc_news_id :: Int64, -- Foreign key.
city :: String,
state :: String,
country :: String }
- deriving (Eq, Show)
+deriving instance Eq NewsLocation
+deriving instance Show NewsLocation
data Message =
Message {
mkPersist defaultCodegenConfig [groundhog|
- entity: NewsTeam
dbName: news_teams
+ constructors:
+ - name: NewsTeam
+ fields:
+ - name: nt_news_id
+ reference:
+ - table: news
+ - columns: [id]
- entity: NewsLocation
dbName: news_locations
to_string = team_name
from_string :: String -> NewsTeam
- from_string = NewsTeam
+ from_string = NewsTeam 0
instance XmlPickler NewsTeam where
xpickle = pickle_news_team
(xpElem "state" xpText)
(xpElem "country" xpText)
where
- from_tuple = uncurryN NewsLocation
- to_tuple l = (city l, state l, country l)
+ from_tuple =
+ uncurryN (NewsLocation 0)
+ to_tuple l = (city l, state l, country l) -- Don't pickle the PK
instance XmlPickler NewsLocation where
xpickle = pickle_location
+instance DbImport Message where
+ dbimport _ xml = do
+ runMigration defaultMigrationLogger $ do
+ migrate (undefined :: Message)
+ migrate (undefined :: NewsTeam)
+ migrate (undefined :: NewsLocation)
+ let root_element = unpickleDoc xpickle xml
+ case root_element of
+ Nothing -> do
+ let errmsg = "Could not unpickle document in import_news."
+ liftIO $ report_error errmsg
+ return Nothing
+ Just message -> do
+ news_id <- insert message
+
+ let insert_news_team nt = insert (nt { nt_news_id = unsafeCoerce news_id })
+ nt_ids <- mapM insert_news_team (teams message)
+
+ let insert_news_location loc = insert (loc { loc_news_id = unsafeCoerce news_id })
+ loc_ids <- mapM insert_news_location (locations message)
+
+ return $ Just (1 + (length nt_ids) + (length loc_ids))
+
+
-- * Tasty Tests
news_tests :: TestTree
news_tests =
projects / dead / htsn-import.git / commitdiff