+{-# 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 =