[Introduction of Holder a primitive to simplify repeated use of same idiom. Broadcast of model changes to delicious widget. prb@mult.ifario.us**20080710060253] { move ./src/Blog/BackEnd/DataController.hs ./src/Blog/BackEnd/ModelSupport.hs hunk ./servletsrc/perpubplat.hs 8 -import qualified Blog.BackEnd.DataController as DataC +import qualified Blog.BackEnd.ModelSupport as MSupp +import qualified Blog.BackEnd.Holder as H hunk ./servletsrc/perpubplat.hs 13 -import qualified Blog.BackEnd.IoOperations as O hunk ./servletsrc/perpubplat.hs 39 -data Controllers = Controllers { data_c :: DataC.DataController +data Controllers = Controllers { model :: H.Holder B.Model hunk ./servletsrc/perpubplat.hs 73 - ; m <- liftIO $ DataC.get_model (data_c con) + ; m <- liftIO $ H.get (model con) hunk ./servletsrc/perpubplat.hs 81 - do { m <- liftIO $ DataC.get_model (data_c con) + do { m <- liftIO $ H.get (model con) hunk ./servletsrc/perpubplat.hs 121 - ; m <- liftIO $ DataC.get_model (data_c con) + ; m <- liftIO $ H.get (model con) hunk ./servletsrc/perpubplat.hs 131 - do { m <- liftIO $ DataC.get_model (data_c con) + do { m <- liftIO $ H.get (model con) hunk ./servletsrc/perpubplat.hs 146 - ; liftIO $ CommentQ.post_comment (data_c con) (comment_c con) (fromJust int_id) + ; liftIO $ CommentQ.post_comment (model con) (comment_c con) (fromJust int_id) hunk ./servletsrc/perpubplat.hs 162 - do { result <- liftIO ( DataC.ingest_draft (data_c con) d) + do { result <- liftIO ( MSupp.ingest_draft (model con) d) hunk ./servletsrc/perpubplat.hs 165 - do { m <- liftIO $ DataC.get_model (data_c con) + do { m <- liftIO $ H.get (model con) hunk ./servletsrc/perpubplat.hs 167 - ; redirect $ B.permalink m i} + ; redirect $ B.permalink m i} hunk ./servletsrc/perpubplat.hs 176 -add_comment_form con t = do { m <- liftIO $ DataC.get_model (data_c con) +add_comment_form con t = do { m <- liftIO $ H.get (model con) hunk ./servletsrc/perpubplat.hs 182 - ; m <- liftIO $ DataC.get_model (data_c con) + ; m <- liftIO $ H.get (model con) hunk ./servletsrc/perpubplat.hs 211 - ; m <- O.boot hunk ./servletsrc/perpubplat.hs 212 - ; dc <- DataC.spawn m + ; mh <- MSupp.boot hunk ./servletsrc/perpubplat.hs 214 - ; cb <- ChromeB.boot m + ; cb <- (H.get mh) >>= ChromeB.boot hunk ./servletsrc/perpubplat.hs 216 - ; let con = Controllers dc cc cb rs + ; let con = Controllers mh cc cb rs hunk ./src/Blog/BackEnd/HitTracker.hs 42 + ; checkVersion "3.4.0" conn hunk ./src/Blog/BackEnd/HitTracker.hs 62 +checkVersion :: DH.IConnection conn => String -> conn -> IO () +checkVersion min_ver c = L.infoM log_handle $ "Client version is " ++ (DH.proxiedClientVer c) + ++ "; this may cause problems if it is less than " ++ min_ver ++ "." + hunk ./src/Blog/BackEnd/ModelSupport.hs 1 -module Blog.BackEnd.DataController where +module Blog.BackEnd.ModelSupport where hunk ./src/Blog/BackEnd/ModelSupport.hs 3 -import Blog.Model.Entry +import Blog.Model.Entry (Item, Model) hunk ./src/Blog/BackEnd/ModelSupport.hs 6 +import qualified Blog.BackEnd.Holder as H hunk ./src/Blog/BackEnd/ModelSupport.hs 8 -import Control.Concurrent ( ThreadId, forkIO ) -import Control.Concurrent.Chan ( Chan, newChan, writeChan, readChan ) -import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, putMVar ) +import Control.Monad ((=<<)) hunk ./src/Blog/BackEnd/ModelSupport.hs 10 -import System.Log.Logger +boot :: IO (H.Holder Model) +boot = H.newHolder =<< IoO.boot hunk ./src/Blog/BackEnd/ModelSupport.hs 13 -data Request = GetModel { get_handback :: MVar Model } - | IngestDraft { draft :: Item } - | PostComment { comment :: Item } - | Boot { boot_handback :: MVar Model } +ingest_draft :: (H.Holder Model) -> String -> IO (Either String Item) +ingest_draft h s = do { d <- IoO.load_draft s + ; case d of + Right i -> + do { H.applyIO' h (MT.ingest_draft i) + ; return $ Right i } + Left err -> + return $ Left $ show err } hunk ./src/Blog/BackEnd/ModelSupport.hs 22 -data DataController = DataController { request_channel :: Chan Request, - thread_id :: ThreadId } - -log_handle :: String -log_handle = "DataController" - -spawn :: Model -> IO DataController -spawn m = do { rc <- newChan - ; t <- forkIO (loop rc m) - ; infoM log_handle $ "Forked new DataController on thread ID " ++ (show t) ++ "." - ; return $ DataController rc t } - -send :: DataController -> Request -> IO () -send = writeChan . request_channel - -boot :: DataController -> IO Model -boot c = do { cb <- newEmptyMVar - ; send c (Boot cb) - ; takeMVar cb } - -get_model :: DataController -> IO Model -get_model c = do { cb <- newEmptyMVar - ; send c (GetModel cb) - ; takeMVar cb } - -ingest_draft :: DataController -> String -> IO (Either String Item) -ingest_draft dc s = do { d <- IoO.load_draft s - ; case d of - Right i -> - do { send dc $ IngestDraft i - ; return $ Right i } - Left err -> - return $ Left $ show err } - -post_comment :: DataController -> Item -> IO () -post_comment dc i = send dc $ PostComment i - -loop :: Chan Request -> Model -> IO () -loop c m = do { req <- readChan c - ; case req of - (GetModel hb) -> - do { putMVar hb m - ; loop c m } - (IngestDraft d) -> - do { m' <- MT.ingest_draft m d - ; loop c m' } - (PostComment i) -> - do { m' <- MT.ingest_comment m i - ; loop c m' } - (Boot hb) -> - do { m' <- IoO.boot - ; putMVar hb m' - ; loop c m' } - } +post_comment :: (H.Holder Model) -> Item -> IO () +post_comment h i = do H.applyIO' h (MT.ingest_comment i) hunk ./src/Blog/BackEnd/ModelTransformations.hs 16 -ingest_draft :: Model -> Item -> IO Model -ingest_draft m i = do { let t = to_permatitle $ title i - ; let pt = uniquify_permatitle m t 0 - ; ts <- now - ; let i' = i { internal_id = next_id m - , permatitle = pt - , created = ts - , updated = ts - , kind = Post } - ; let (_,m') = insert m i' - ; forkIO $ I.save m' i' >> return () - ; return m' } +ingest_draft :: Item -> Model -> IO Model +ingest_draft i m = do { let t = to_permatitle $ title i + ; let pt = uniquify_permatitle m t 0 + ; ts <- now + ; let i' = i { internal_id = next_id m + , permatitle = pt + , created = ts + , updated = ts + , kind = Post } + ; let (_,m') = insert m i' + ; forkIO $ I.save m' i' >> return () + ; return m' } hunk ./src/Blog/BackEnd/ModelTransformations.hs 32 -ingest_comment :: Model -> Item -> IO Model -ingest_comment m c = do { ts <- now +ingest_comment :: Item -> Model -> IO Model +ingest_comment c m = do { ts <- now hunk ./src/Blog/BackEnd/RefererStream.hs 53 - putMVar h r >> referer_loop rs r } + putMVar h r >> referer_loop rs r } + + +create_referrers_tables_sql :: String +create_referrers_tables_sql = + "CREATE TABLE referers ( permatitle TEXT PRIMARY KEY NOT NULL, " + ++ "referring_uri TEXT NOT NULL, " + ++ "first_hit INTEGER NOT NULL, " + ++ "most_recent_hit INTEGER NOT NULL, " + ++ "count INTEGER NOT NULL DEFAULT 0 )" + + hunk ./src/Blog/FrontEnd/Presentation.hs 11 -import qualified Blog.Widgets.TagCloud as TC +import qualified Blog.BackEnd.Holder as H hunk ./src/Blog/FrontEnd/Presentation.hs 110 - ; tc <- TC.get_cloud $ CB.tag_cloud_controller cb + ; tc <- H.get $ CB.tag_cloud_holder cb hunk ./src/Blog/Model/CommentQueue.hs 11 -import qualified Blog.BackEnd.DataController as DC +import qualified Blog.BackEnd.Holder as H +import qualified Blog.BackEnd.ModelSupport as MSupp hunk ./src/Blog/Model/CommentQueue.hs 93 -post_comment :: DC.DataController -> CommentController -> Int -> IO () -post_comment dc cc idx = do { c <- fetch_comment cc idx - ; case c of - (Just i) -> - do { case (CBP.parse_comment $ B.body i) of - Left _ -> - return () - Right b -> - do { let b' = CBP.blocks_to_string b - ; DC.post_comment dc (i { B.body = b' }) - ; delete_comment cc idx } +post_comment :: (H.Holder B.Model) -> CommentController -> Int -> IO () +post_comment h cc idx = do { c <- fetch_comment cc idx + ; case c of + (Just i) -> + do { case (CBP.parse_comment $ B.body i) of + Left _ -> + return () + Right b -> + do { let b' = CBP.blocks_to_string b + ; MSupp.post_comment h (i { B.body = b' }) + ; delete_comment cc idx } hunk ./src/Blog/Model/CommentQueue.hs 105 - Nothing -> + Nothing -> hunk ./src/Blog/Model/CommentQueue.hs 107 - } + } hunk ./src/Blog/Widgets/ChromeBackEnd.hs 4 -import Blog.Widgets.FlickrCollage ( FlickrPhotos, boot_flickr_collage ) -import Blog.Widgets.TagCloud ( TagCloudController, boot_tag_cloud ) -import Blog.Widgets.Delicious ( DeliciousController, boot_dc, Scheduler, boot_s, FixedFrequencyDriver, start_driver) +import qualified Blog.BackEnd.Holder as H +import qualified Blog.Widgets.FlickrCollage as FlickrC +import qualified Blog.Widgets.TagCloud as TagC +import qualified Blog.Widgets.Delicious as Delicious hunk ./src/Blog/Widgets/ChromeBackEnd.hs 13 -data ChromeBackEnd = ChromeBackEnd { flickr_collage :: FlickrPhotos - , tag_cloud_controller :: TagCloudController - , delicious_controller :: DeliciousController - , scheduler :: Scheduler - , driver :: FixedFrequencyDriver +data ChromeBackEnd = ChromeBackEnd { flickr_collage :: FlickrC.FlickrPhotos + , tag_cloud_holder :: H.Holder String + , delicious_controller :: Delicious.Controller + , delicious_scheduler :: Delicious.Scheduler + , driver :: Delicious.FixedFrequencyDriver hunk ./src/Blog/Widgets/ChromeBackEnd.hs 22 - handle_model_change cb m = handle_model_change (tag_cloud_controller cb) m + handle_model_change cb m = TagC.update_model (tag_cloud_holder cb) m + >> Delicious.update_model (delicious_scheduler cb) m hunk ./src/Blog/Widgets/ChromeBackEnd.hs 26 -boot m = do { f <- boot_flickr_collage C.flickr_user C.flickr_api_key - ; t <- boot_tag_cloud m - ; dc <- boot_dc - ; s <- boot_s dc m - ; ffd <- start_driver s (10^7) +boot m = do { f <- FlickrC.boot C.flickr_user C.flickr_api_key + ; tc <- TagC.boot m + ; ht <- HitT.boot + ; dc <- Delicious.boot_dc + ; s <- Delicious.boot_s dc m + ; ffd <- Delicious.start_driver s (10^7) hunk ./src/Blog/Widgets/ChromeBackEnd.hs 38 - ; ht <- HitT.boot - ; return $ ChromeBackEnd f t dc s ffd socc ht } + ; return $ ChromeBackEnd f tc dc s ffd socc ht } hunk ./src/Blog/Widgets/Delicious.hs 33 -get_chrome :: DeliciousController -> B.Model -> B.Item -> IO Html +get_chrome :: Controller -> B.Model -> B.Item -> IO Html hunk ./src/Blog/Widgets/Delicious.hs 92 - , d_con :: DeliciousController + , d_con :: Controller hunk ./src/Blog/Widgets/Delicious.hs 98 -boot_s :: DeliciousController -> B.Model -> IO Scheduler +boot_s :: Controller -> B.Model -> IO Scheduler hunk ./src/Blog/Widgets/Delicious.hs 110 -data DeliciousController = DeliciousController { d_request_channel :: Chan DRequest - , dc_tid :: ThreadId } +data Controller = Controller { d_request_channel :: Chan DRequest + , dc_tid :: ThreadId } hunk ./src/Blog/Widgets/Delicious.hs 120 -boot_dc :: IO DeliciousController +boot_dc :: IO Controller hunk ./src/Blog/Widgets/Delicious.hs 123 - ; let dc = DeliciousController c t + ; let dc = Controller c t hunk ./src/Blog/Widgets/Delicious.hs 131 -get_record :: DeliciousController -> Int -> IO (DeliciousRecord,Html) +get_record :: Controller -> Int -> IO (DeliciousRecord,Html) hunk ./src/Blog/Widgets/Delicious.hs 136 -put_record :: DeliciousController -> Int -> (DeliciousRecord,Html) -> IO () +put_record :: Controller -> Int -> (DeliciousRecord,Html) -> IO () hunk ./src/Blog/Widgets/Delicious.hs 142 -dc_loop :: DeliciousController -> DeliciousState -> IO () +dc_loop :: Controller -> DeliciousState -> IO () hunk ./src/Blog/Widgets/Delicious.hs 198 -update_and_reschedule :: DeliciousController -> B.Model -> Int -> IO SP.EpochTime +update_and_reschedule :: Controller -> B.Model -> Int -> IO SP.EpochTime hunk ./src/Blog/Widgets/FlickrCollage.hs 64 -boot_flickr_collage :: String -> String -> IO FlickrPhotos -boot_flickr_collage user_id api_key = +boot :: String -> String -> IO FlickrPhotos +boot user_id api_key = hunk ./src/Blog/Widgets/TagCloud.hs 1 -module Blog.Widgets.TagCloud ( TagCloudController ( request_channel, thread_id ) - , TagCloudRequest ( GetRequest, callback, PutRequest, cloud_fragment ) - , boot_tag_cloud, get_cloud, put_cloud - , tag_cloud ) where +module Blog.Widgets.TagCloud ( boot + , update_model ) where hunk ./src/Blog/Widgets/TagCloud.hs 4 -import qualified Blog.BackEnd.ModelChangeListener as MCL hunk ./src/Blog/Widgets/TagCloud.hs 11 -import Control.Concurrent ( forkIO, myThreadId, ThreadId ) -import Control.Concurrent.MVar ( MVar, newEmptyMVar, putMVar, takeMVar ) -import Control.Concurrent.Chan ( Chan, newChan, readChan, writeChan ) +import qualified Blog.BackEnd.Holder as H hunk ./src/Blog/Widgets/TagCloud.hs 13 -data TagCloudRequest = GetRequest { callback :: MVar String } - | PutRequest { cloud_fragment :: String } +boot :: B.Model -> IO (H.Holder String) +boot m = H.newHolder $ showHtmlFragment $ tag_cloud (B.all_posts m) C.tags_to_show hunk ./src/Blog/Widgets/TagCloud.hs 16 - -data TagCloudController = TagCloudController { request_channel :: Chan TagCloudRequest - , thread_id :: ThreadId } - -instance MCL.ModelChangeListener TagCloudController where - handle_model_change tcc m = (put_cloud tcc) . showHtmlFragment $ tag_cloud (B.all_posts m) C.tags_to_show - -boot_tag_cloud :: B.Model -> IO TagCloudController -boot_tag_cloud m = do { let tc = showHtmlFragment $ tag_cloud (B.all_posts m) C.tags_to_show - ; rc <- newChan - ; my_tid <- myThreadId - ; let tcc = TagCloudController rc my_tid - ; tid <- forkIO $ loop tcc tc - ; return $ tcc { thread_id = tid } } - -loop :: TagCloudController -> String -> IO () -loop tcc tc = do { req <- readChan . request_channel $ tcc - ; case req of - GetRequest cb -> - do { putMVar cb tc - ; loop tcc tc } - PutRequest tc' -> - loop tcc tc' } - -get_cloud :: TagCloudController -> IO String -get_cloud tcc = do { cb <- newEmptyMVar - ; writeChan ( request_channel tcc ) $ GetRequest cb - ; takeMVar cb } - -put_cloud :: TagCloudController -> String -> IO () -put_cloud tcc tc = writeChan ( request_channel tcc) $ PutRequest tc +update_model :: (H.Holder String) -> B.Model -> IO () +update_model fh m = H.put fh $ showHtmlFragment $ tag_cloud (B.all_posts m) C.tags_to_show }