X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FNews.hs;h=1796963b8ba3175ee0543416d8b9e2c4911b818f;hb=e46de7e95112d4e35219b74c0b3efffe99c69c6a;hp=4e24c3ae0e89fa575dbc2d54e519645306d2e11c;hpb=3835f96aea2f383501071106be0a69abd1ef89d1;p=dead%2Fhtsn-import.git diff --git a/src/TSN/News.hs b/src/TSN/News.hs index 4e24c3a..1796963 100644 --- a/src/TSN/News.hs +++ b/src/TSN/News.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} @@ -14,14 +15,27 @@ module TSN.News ( 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, @@ -32,34 +46,46 @@ import Text.XML.HXT.Core ( 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, @@ -67,11 +93,50 @@ data Message = 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 = @@ -80,23 +145,24 @@ 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 @@ -105,37 +171,73 @@ pickle_message = 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 =