[Asynchronous tag cloud generation.
prb@mult.ifario.us**20080131180718] {
hunk ./perpubplat/perpubplat.cabal 32
+  Blog.BackEnd.ModelChangeListener,
hunk ./perpubplat/perpubplat.cabal 40
-  -O -Werror -fwarn-unused-binds -fwarn-unused-imports -fwarn-unused-matches
+  -O -Werror -fwarn-unused-binds -fwarn-unused-imports -fwarn-unused-matches -threaded
hunk ./perpubplat/perpubplat.cabal 51
+
hunk ./perpubplat/src/Blog/Constants.hs 40
+content_root :: String
+content_root  = "/Users/prb/web/perpubplat"
+
hunk ./perpubplat/src/Blog/Constants.hs 44
-content_storage_dir = "/tmp/content"
+content_storage_dir = content_root ++ "/content"
hunk ./perpubplat/src/Blog/Constants.hs 47
-draft_dir = "/tmp/drafts"
+draft_dir = content_root ++ "/drafts"
hunk ./perpubplat/src/Blog/Constants.hs 50
-comment_dir = "/tmp/comments"
+comment_dir = content_root ++ "/comments"
hunk ./perpubplat/src/Blog/FrontEnd/Presentation.hs 8
-import qualified Blog.Constants as C
hunk ./perpubplat/src/Blog/FrontEnd/Presentation.hs 106
+       ; tc <- TC.get_cloud $ CB.tag_cloud_controller cb
hunk ./perpubplat/src/Blog/FrontEnd/Presentation.hs 111
-         , TC.tag_cloud (B.all_posts b) C.tags_to_show
+         , primHtml tc
hunk ./perpubplat/src/Blog/FrontEnd/Routes.hs 223
--- todo : tolerate spaces in tags?
hunk ./perpubplat/src/Blog/FrontEnd/Routes.hs 224
-p_tag_name =  many1 (alphaNum <|> char '-' <|> char '_')
+p_tag_name =  many1 (alphaNum <|> char '-' <|> char '_' <|> char '.' )
hunk ./perpubplat/src/Blog/Widgets/ChromeBackEnd.hs 3
+import Blog.Model.Entry
hunk ./perpubplat/src/Blog/Widgets/ChromeBackEnd.hs 5
+import Blog.Widgets.TagCloud (TagCloudController, boot_tag_cloud)
hunk ./perpubplat/src/Blog/Widgets/ChromeBackEnd.hs 7
+import Blog.BackEnd.ModelChangeListener
hunk ./perpubplat/src/Blog/Widgets/ChromeBackEnd.hs 10
-                                   , flickr_poller :: HttpPoller }
+                                   , flickr_poller :: HttpPoller
+                                   , tag_cloud_controller :: TagCloudController }
hunk ./perpubplat/src/Blog/Widgets/ChromeBackEnd.hs 13
-boot :: IO ChromeBackEnd
-boot = do { (f,p) <- boot_flickr_collage
-          ; return $ ChromeBackEnd f p }
+instance ModelChangeListener ChromeBackEnd where
+    handle_model_change cb m = handle_model_change (tag_cloud_controller cb) m
+
+boot :: Model -> IO ChromeBackEnd
+boot m = do { (f,p) <- boot_flickr_collage
+            ; t <- boot_tag_cloud m
+            ; return $ ChromeBackEnd f p t}
hunk ./perpubplat/src/Blog/Widgets/TagCloud.hs 1
-module Blog.Widgets.TagCloud ( tag_cloud ) where
+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
hunk ./perpubplat/src/Blog/Widgets/TagCloud.hs 6
-import Blog.Model.Entry
-import Blog.FrontEnd.Urls
+import qualified Blog.BackEnd.ModelChangeListener as MCL
+import qualified Blog.Model.Entry as B
+import qualified Blog.FrontEnd.Urls as U
+import qualified Blog.Constants as C
hunk ./perpubplat/src/Blog/Widgets/TagCloud.hs 11
-                           concatHtml, toHtml, hotlink, theclass, thediv )
+                           concatHtml, toHtml, hotlink, theclass, thediv, showHtml )
hunk ./perpubplat/src/Blog/Widgets/TagCloud.hs 14
-tag_cloud :: [Item] -> Int -> Html
-tag_cloud = tag_cloud_ . sort . concat . (map tags)
+import Control.Concurrent ( forkIO, myThreadId, ThreadId )
+import Control.Concurrent.MVar ( MVar, newEmptyMVar, putMVar, takeMVar )
+import Control.Concurrent.Chan ( Chan, newChan, readChan, writeChan )
+
+data TagCloudRequest = GetRequest { callback :: MVar String }
+                     | PutRequest { cloud_fragment :: String }
+
+
+data TagCloudController = TagCloudController { request_channel :: Chan TagCloudRequest
+                                             , thread_id :: ThreadId }
+
+instance MCL.ModelChangeListener TagCloudController where
+    handle_model_change tcc m = (put_cloud tcc) . showHtml $ tag_cloud (B.all_posts m) C.tags_to_show
+
+boot_tag_cloud :: B.Model -> IO TagCloudController
+boot_tag_cloud m = do { let tc = showHtml $ 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
+
+tag_cloud :: [B.Item] -> Int -> Html
+tag_cloud = tag_cloud_ . sort . concat . (map B.tags)
hunk ./perpubplat/src/Blog/Widgets/TagCloud.hs 83
-tag_atom (nm,c,n,sz) = thespan ( toHtml ( hotlink (posts_by_tag nm)
+tag_atom (nm,c,n,sz) = thespan ( toHtml ( hotlink (U.posts_by_tag nm)
hunk ./perpubplat_servlet/src/blog.hs 18
+import qualified Blog.BackEnd.ModelChangeListener as MCL
hunk ./perpubplat_servlet/src/blog.hs 23
--- import Control.Monad ( liftM )
hunk ./perpubplat_servlet/src/blog.hs 107
-                                   do { (i,m) <- liftIO ( DataC.ingest_draft (data_c con) d )
+                                   do { (i,m) <- liftIO ( DataC.ingest_draft (data_c con) d)
+                                      ; liftIO $ MCL.handle_model_change (chrome_b con) m
hunk ./perpubplat_servlet/src/blog.hs 144
-          ; cb <- ChromeB.boot
+          ; cb <- ChromeB.boot m
}