+{-# 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.
+data NewsTeam =
+ NewsTeam {
+ nt_news_id :: Int64, -- Foreign key.
+ team_name :: String }
+deriving instance Eq NewsTeam
+deriving instance Show NewsTeam
+
data MsgId =
MsgId {
- msg_id_text :: Int,
- event_id :: String }
+ msg_id :: Int,
+ event_id :: String } -- TODO: make optional
deriving (Eq, Show)
-data Location =
- Location {
+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 {
xml_file_id :: Int,
- msg_id :: MsgId,
heading :: String,
+ mid :: MsgId,
category :: String,
sport :: String,
url :: String,
- teams :: [String],
- location :: Location,
+ teams :: [NewsTeam],
+ locations :: [NewsLocation],
sms :: String,
text :: String,
continue :: String,
deriving (Eq, Show)
--- mkPersist defaultCodegenConfig [groundhog|
--- - entity: Message
--- dbName: injuries
--- |]
+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
+
+- entity: Message
+ dbName: news
+ constructors:
+ - name: Message
+ fields:
+ - name: mid
+ embeddedType:
+ - {name: msg_id, dbName: msg_id}
+ - {name: event_id, dbName: event_id}
+
+- embedded: MsgId
+ fields:
+ - name: msg_id
+ - name: event_id
+|]
+
+
+pickle_news_team :: PU NewsTeam
+pickle_news_team =
+ xpElem "team" $
+ xpWrap (from_string, to_string) xpText
+ where
+ to_string :: NewsTeam -> String
+ to_string = team_name
+ from_string :: String -> NewsTeam
+ from_string = NewsTeam 0
+
+instance XmlPickler NewsTeam where
+ xpickle = pickle_news_team
pickle_msg_id :: PU MsgId
pickle_msg_id =
xpPair xpPrim (xpAttr "EventId" xpText0)
where
from_tuple = uncurryN MsgId
- to_tuple m = (msg_id_text m, event_id m)
+ to_tuple m = (msg_id m, event_id m)
instance XmlPickler MsgId where
xpickle = pickle_msg_id
-pickle_location :: PU Location
+pickle_location :: PU NewsLocation
pickle_location =
- xpElem "listing" $
+ xpElem "location" $
xpWrap (from_tuple, to_tuple) $
xpTriple (xpElem "city" xpText)
- (xpElem "state" xpPrim)
- (xpElem "location" xpText)
+ (xpElem "state" xpText)
+ (xpElem "country" xpText)
where
- from_tuple = uncurryN Location
- 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 Location where
+instance XmlPickler NewsLocation where
xpickle = pickle_location
xpElem "message" $
xpWrap (from_tuple, to_tuple) $
xp12Tuple (xpElem "XML_File_ID" xpPrim)
- pickle_msg_id
(xpElem "heading" xpText)
+ pickle_msg_id
(xpElem "category" xpText)
(xpElem "sport" xpText)
(xpElem "url" xpText)
- (xpList $ xpElem "team" xpText)
- (pickle_location)
- (xpElem "sms" xpText)
+ (xpList $ pickle_news_team)
+ (xpList $ pickle_location)
+ (xpElem "SMS" xpText)
(xpElem "text" xpText)
- (xpElem "continue" xpText)
+ pickle_continue
(xpElem "time_stamp" xpText)
where
from_tuple = uncurryN Message
to_tuple m = (xml_file_id m,
- msg_id m,
heading m,
+ mid m,
category m,
sport m,
url m,
teams m,
- location m,
+ locations m,
sms m,
text m,
continue m,
time_stamp m)
+ pickle_continue :: PU String
+ pickle_continue =
+ xpWrap (to_string, from_string) $
+ xpElem "continue" $
+ (xpList $ xpElem "P" xpText)
+ where
+ from_string :: String -> [String]
+ from_string = split "\n"
+
+ to_string :: [String] -> String
+ to_string = join "\n"
+
instance XmlPickler Message where
xpickle = pickle_message
+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 / blobdiff