X-Git-Url: http://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FTSN%2FNews.hs;h=1796963b8ba3175ee0543416d8b9e2c4911b818f;hb=e46de7e95112d4e35219b74c0b3efffe99c69c6a;hp=74b48463edb071ceac391355247a7cf6556ee6bd;hpb=9cf45320c04c72472be8148819753e41d6535f65;p=dead%2Fhtsn-import.git

diff --git a/src/TSN/News.hs b/src/TSN/News.hs
index 74b4846..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,15 +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,
@@ -33,28 +46,35 @@ 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.
+-- 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 {
@@ -76,6 +96,13 @@ data 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
@@ -106,7 +133,7 @@ pickle_news_team =
     to_string = team_name
 
     from_string :: String -> NewsTeam
-    from_string = NewsTeam
+    from_string = NewsTeam 0
 
 instance XmlPickler NewsTeam where
   xpickle = pickle_news_team
@@ -131,8 +158,9 @@ pickle_location =
              (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
@@ -186,6 +214,30 @@ instance XmlPickler Message where
 
 
 
+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 =