[Added support for Javascript-free Flickr collage.  Started on generic approach to having background sidebars.
prb@mult.ifario.us**20080129054741] {
hunk ./perpubplat/perpubplat.cabal 19
-  old-time >= 1.0, containers, directory
+  old-time >= 1.0, containers, directory, utf8-string >= 0.2, HTTP >= 3001,
+  old-locale >= 1.0, json >= 0.1, network >= 2.1
hunk ./perpubplat/perpubplat.cabal 31
-  Blog.BackEnd.ModelTransformations,
-  Blog.Widgets.TagCloud, Blog.Widgets.FlickrBadge,
+  Blog.BackEnd.ModelTransformations, Blog.BackEnd.HttpPoller,
+  Blog.Widgets.TagCloud, Blog.Widgets.FlickrCollage,
+  Blog.Widgets.ChromeBackEnd
addfile ./perpubplat/src/Blog/BackEnd/HttpPoller.hs
hunk ./perpubplat/src/Blog/BackEnd/HttpPoller.hs 1
+module Blog.BackEnd.HttpPoller where
+
+import Network.HTTP
+import qualified Control.Exception as E
+import System.Time
+import Control.Concurrent ( ThreadId, threadDelay, killThread )
+
+data HttpPoller = HttpPoller { request :: Request
+                             , handle_response :: Result Response -> IO ()
+                             , polling_period_millis :: Int
+                             , p_tid :: ThreadId }
+
+stop_poller :: HttpPoller -> IO ()
+stop_poller = killThread . p_tid
+
+poller_loop :: HttpPoller -> IO ()
+poller_loop p = do { cont <-
+                         do { ct_start <- getClockTime
+                            ; resp <- simpleHTTP $ request p
+                            ; ct_stop <- getClockTime
+                            ; logtime (request p) ct_stop ct_start
+                            ; (handle_response p) resp
+                            ; return True }
+                       `E.catch` handle_exception
+                     ; if cont then
+                           do { print $ "Sleeping for "
+                                ++ (show . polling_period_millis $ p) ++ " microseconds."
+                              ; loop <-
+                                  do { threadDelay $ polling_period_millis p
+                                     ; return True }
+                              `E.catch` handle_exception
+                            ; if loop then poller_loop p else return () }
+                     else return ()
+                   }
+
+logtime :: Request -> ClockTime -> ClockTime -> IO ()
+logtime req ct_stop ct_start = 
+    print $ "Took " ++ td ++ " seconds to perform "
+              ++ (show . rqMethod $ req )
+              ++ " "
+              ++ (show . rqURI $ req )
+    where
+      td = tenths_of_a_second $ diffClockTimes ct_stop ct_start
+                     
+handle_exception :: E.Exception -> IO Bool
+handle_exception (E.ErrorCall msg) =
+    do { print $ "Exception during HTTP operation: " ++ msg
+       ; return True }
+handle_exception (E.AsyncException E.ThreadKilled) =
+    do { print $ "Kill received; exiting gracefully."
+       ; return False }
+handle_exception (E.IOException ex) =
+    do { print $ "IOException encountered: " ++ show ex
+       ; return True }
+handle_exception e =
+    do { print $ "Unexpected exception encountered; stopping poller.  Exception was: " ++ (show e)
+       ; return False } 
+
+tenths_of_a_second :: TimeDiff -> String
+tenths_of_a_second (TimeDiff 0 0 0 0 m s p) = fmt $ show hundreths
+    where
+      hundreths = 6000*m + 100*s + fromInteger ((p `div` (10^10)))
+tenths_of_a_second t = timeDiffToString t
+
+fmt :: String -> String
+fmt s = (take l ps) ++ "." ++ ((drop l) ps)
+    where
+      ps = pad 3 '0' s
+      l = (length ps) - 2
+
+pad :: Int -> Char -> String -> String
+pad i c s | length s >= i = s
+          | otherwise = pad (i-1) c (c:s)
hunk ./perpubplat/src/Blog/FrontEnd/Presentation.hs 13
-import qualified Blog.Widgets.FlickrBadge as FB
+import qualified Blog.Widgets.FlickrCollage as FC
+import qualified Blog.Widgets.ChromeBackEnd as CB
hunk ./perpubplat/src/Blog/FrontEnd/Presentation.hs 21
+              -> CB.ChromeBackEnd -- ^ a backend for chrome data
hunk ./perpubplat/src/Blog/FrontEnd/Presentation.hs 23
-              -> String
-assemble_page v m | paged_posts == [] = ""
-                  | otherwise = showHtml . concatHtml $
-                                [ topmatter v                                         
-                                , body . (divid "container") . concatHtml $
-                                  [ heading
-                                  , divid "posts" $ phunk +++ bottom_nav v m
-                                  , sidebar v m paged_posts
-                                  , footer ] ]
+              -> IO String
+assemble_page v cb m =
+    case paged_posts of
+      [] ->
+          return ""
+      _ ->
+          do { sb <- sidebar v cb m paged_posts
+             ; return . showHtml . concatHtml $
+                          [ topmatter v
+                          , body . (divid "container") . concatHtml $
+                                     [ heading
+                                     , divid "posts" $ phunk +++ bottom_nav v m
+                                     , sb
+                                     , footer ] ] }
hunk ./perpubplat/src/Blog/FrontEnd/Presentation.hs 104
-sidebar :: (V.Viewable v) => v -> B.Model -> [B.Item] -> Html
-sidebar w b p = (divid "sidebar") . concatHtml $ 
-                [ sidebar_nav w b
-                , contents_block "sidebarcontents" w b p 
-                , h3 $ stringToHtml "Tags"
-                , TC.tag_cloud (B.all_posts b) C.tags_to_show
-                , h3 $ stringToHtml "Pictures"
-                , FB.flickr_badge ]
+sidebar :: (V.Viewable v) => v -> CB.ChromeBackEnd -> B.Model -> [B.Item] -> IO Html
+sidebar w cb b p =
+    do { fc <- FC.build_collage $ CB.flickr_controller cb
+       ; return $ (divid "sidebar") . concatHtml $ 
+         [ sidebar_nav w b
+         , contents_block "sidebarcontents" w b p 
+         , h3 $ stringToHtml "Tags"
+         , TC.tag_cloud (B.all_posts b) C.tags_to_show
+         , h3 $ stringToHtml "Pictures"
+         , fc ] }
hunk ./perpubplat/src/Blog/FrontEnd/Syndication.hs 7
+import Data.Maybe (fromJust)
hunk ./perpubplat/src/Blog/FrontEnd/Syndication.hs 59
-                  | otherwise = [ A.Summary $ A.AtomContent A.XHTML s ]
-    where 
-      s = unwrap $ B.summary i              
+                  | otherwise = [ A.Summary . (A.AtomContent A.XHTML) . fromJust $ B.summary i ]
hunk ./perpubplat/src/Blog/FrontEnd/Syndication.hs 61
-unwrap :: Maybe a -> a
-unwrap (Just s) = s
addfile ./perpubplat/src/Blog/Widgets/ChromeBackEnd.hs
hunk ./perpubplat/src/Blog/Widgets/ChromeBackEnd.hs 1
-
+module Blog.Widgets.ChromeBackEnd where
+
+import Blog.Widgets.FlickrCollage (FlickrController, boot_flickr_collage)
+import Blog.BackEnd.HttpPoller
+
+data ChromeBackEnd = ChromeBackEnd { flickr_controller :: FlickrController
+                                   , flickr_poller :: HttpPoller }
+
+boot :: IO ChromeBackEnd
+boot = do { (f,p) <- boot_flickr_collage
+          ; return $ ChromeBackEnd f p }
addfile ./perpubplat/src/Blog/Widgets/FlickrCollage.hs
hunk ./perpubplat/src/Blog/Widgets/FlickrCollage.hs 1
+module Blog.Widgets.FlickrCollage where
+
+import Blog.FrontEnd.ContentAtoms
+import Blog.BackEnd.HttpPoller
+
+import Text.ParserCombinators.Parsec;
+import Random
+
+import Network.HTTP
+import Network.HTTP.Headers
+import Network.URI
+import qualified Text.Json as J
+import Data.Maybe
+import qualified Data.Map as M
+import Control.Concurrent
+import Control.Concurrent.MVar
+import Control.Concurrent.Chan
+import Data.Char
+import Data.List
+import qualified Codec.Binary.UTF8.String as UTF8
+
+import Text.XHtml.Strict
+
+build_collage :: FlickrController -> IO Html
+build_collage fc = do { images <- get_photos fc
+                      ; return $ ( divid "flickr_badge_uber_wrapper")
+                        . ( divid "flickr_badge_wrapper" )
+                        . concatHtml $ [ concatHtml . (map to_xhtml) $ images
+                                       , flickr_link ] }
+
+flickr_link :: Html
+flickr_link = primHtml $ "<a href=\"http://www.flickr.com\" id=\"flickr_www\">"
+              ++ "www.<strong style=\"color:#3993ff\">flick"
+              ++ "<span style=\"color:#ff1c92\">r</span></strong>.com</a>"
+
+flickr_api_key :: String
+flickr_api_key = "233b3c334c93b6f999f9b4b810f9d603"
+
+flickr_service_url :: String
+flickr_service_url = "http://api.flickr.com/services/rest/"
+
+flickr_view_url :: String
+flickr_view_url = "http://www.flickr.com/photos/" ++ user_id ++ "/"
+
+user_id :: String
+user_id = "92922008@N00"
+
+display_count :: Int
+display_count = 10
+
+photo_count :: Int
+photo_count = 500
+
+polling_frequency :: Int
+polling_frequency = 15 * 60 * 10^6
+
+data FRequest = Put { photo_urls :: [FlickrPhoto] } | Get { callback :: MVar [FlickrPhoto]}
+
+data FlickrController = FlickrController { request_channel :: Chan FRequest
+                                         , fc_tid :: ThreadId}
+
+data FlickrPhoto = FlickrPhoto { photo_id :: String
+                               , owner :: String
+                               , secret :: String
+                               , server :: String
+                               , farm :: Int
+                               , photo_title :: String }
+                 deriving ( Show, Ord, Eq )
+
+boot_flickr_collage :: IO (FlickrController, HttpPoller)
+boot_flickr_collage =
+    do { temp_tid <- myThreadId
+       ; rc <- newChan
+       ; let fc = FlickrController rc temp_tid
+       ; ftid <- forkIO (run_loop fc [])
+       ; let p = HttpPoller (flickr_people_getPublicPhotos_req user_id)
+                 (handle_flickr_response fc) polling_frequency temp_tid
+       ; ptid <- forkIO (poller_loop p)
+       ; return (fc { fc_tid = ftid}, p { p_tid = ptid }) }
+
+handle_flickr_response :: FlickrController -> Result Response -> IO ()
+handle_flickr_response fc resp = put_photos fc $ response_to_photo_urls resp
+
+response_to_photo_urls :: Result Response -> [FlickrPhoto]
+response_to_photo_urls resp =
+    case resp of
+      Right ( Response (2,0,0) _ _ body ) ->
+          map (to_photo . uno)
+              ( una . (flip (M.!) $ "photo") . uno
+                . (flip (M.!) $ "photos") . uno
+                . parse_json . UTF8.decodeString $ body )
+      Right rsp ->
+          error $ "Unexpected HTTP response " ++ (show_reason rsp)
+      Left ce  ->
+          error $ show ce
+                                             
+run_loop :: FlickrController -> [FlickrPhoto] -> IO ()
+run_loop fc photos = do { req <- readChan $ request_channel fc
+                        ; case req of
+                            Put photos' ->
+                                run_loop fc photos'
+                            Get cb ->
+                                do { putMVar cb photos
+                                   ; run_loop fc photos }
+                        }
+
+get_photos :: FlickrController -> IO [FlickrPhoto]
+get_photos fc = do { cb <- newEmptyMVar
+                   ; writeChan (request_channel fc) $ Get cb
+                   ; photos <- takeMVar cb
+                   ; case photos of
+                       [] ->
+                           return []
+                       _ ->
+                           do { let c = min (length photos) display_count
+                              ; idxs <- n_different_random (0,(length photos)-1) c []
+                              ; return $ map ((!!) photos) idxs } }
+
+put_photos :: FlickrController -> [FlickrPhoto] -> IO ()
+put_photos fc photos = writeChan (request_channel fc) $ Put photos
+
+compose_uri :: String -> [(String,String)] -> URI
+compose_uri b a = fromJust . parseURI $ b ++ "?" ++ (conc a)
+    where
+      to_nvp = \(x,y) -> x ++ "=" ++ (urlEncode y)
+      conc = concat . (intersperse "&") . (map to_nvp)
+
+flickr_people_getPublicPhotos_req :: String -> Request
+flickr_people_getPublicPhotos_req user = Request url GET [ Header HdrAcceptCharset "utf-8" ] ""
+    where
+      url = compose_uri flickr_service_url [ ("api_key", flickr_api_key)
+                                           , ("format","json")
+                                           , ("nojsoncallback","1")
+                                           , ("method","flickr.people.getPublicPhotos")
+                                           , ("per_page",show photo_count)
+                                           , ("user_id",user) ]
+
+parse_json :: String -> J.Value
+parse_json s = case parse J.json "<HTTP Response Body>" s of
+          Left e -> error $ "Unable to parse JSON response body; error was:\n" ++ (show e)
+          Right v  -> v
+
+show_reason :: Response -> String
+show_reason (Response (c1,c2,c3) r _ _) = (show (c1*100 + c2*10 + c3))
+                                          ++ ": " ++ r
+to_xhtml :: FlickrPhoto -> Html
+to_xhtml fp = _a (photo_page_url fp) ( image ! [ src (image_url fp)
+                                               , theclass "flickr_badge_image"
+                                               , alt (photo_title fp) ] )
+
+to_photo :: M.Map String J.Value -> FlickrPhoto
+to_photo m = FlickrPhoto { photo_id = uns $ m M.! "id"
+                         , owner = uns $ m M.! "owner"
+                         , secret = uns $ m M.! "secret"
+                         , server = uns $ m M.! "server"
+                         , photo_title = uns $ m M.! "title"
+                         , farm = unn $ m M.! "farm" }
+
+photo_page_url :: FlickrPhoto -> String
+photo_page_url fp = flickr_view_url ++ (photo_id fp)
+
+image_url :: FlickrPhoto -> String
+image_url fp = "http://farm" ++ (show $ farm fp) ++ ".static.flickr.com/" ++ (server fp)
+               ++ "/" ++ (photo_id fp) ++ "_" ++ (secret fp) ++ "_t.jpg"
+
+n_different_random :: (Int,Int) -> Int -> [Int] -> IO [Int]
+n_different_random (l,h) n ns = do { x <- getStdRandom $ randomR (l,h)
+                                   ; if (x `elem` ns) then
+                                         n_different_random (l,h) n ns
+                                     else
+                                         if (n == 1) then
+                                             return (x:ns)
+                                         else 
+                                             n_different_random (l,h) (n-1) (x:ns) }
+
+blank :: J.Value
+blank = J.String ""
+
+zero :: J.Value
+zero = J.Number 0
+
+empty :: J.Value
+empty = J.Object M.empty
+
+empty_array :: J.Value
+empty_array = J.Array []
+
+unn :: J.Value -> Int
+unn (J.Number n) = fromInteger . round $ n
+
+uno :: J.Value -> M.Map String J.Value
+uno (J.Object o) = o
+
+una :: J.Value -> [J.Value]
+una (J.Array a) = a
+
+uns :: J.Value -> String
+uns (J.String s) = s
hunk ./perpubplat_servlet/src/blog.hs 17
+import qualified Blog.Widgets.ChromeBackEnd as ChromeB
hunk ./perpubplat_servlet/src/blog.hs 28
-                               , comment_c :: CommentQ.CommentController }
+                               , comment_c :: CommentQ.CommentController
+                               , chrome_b :: ChromeB.ChromeBackEnd }
hunk ./perpubplat_servlet/src/blog.hs 54
-                         ; output $ P.assemble_page v m }                     
+                         ; h <- liftIO $ P.assemble_page v (chrome_b con) m
+                         ; output h }
hunk ./perpubplat_servlet/src/blog.hs 143
-          ; let con = Controllers dc cc
+          ; cb <- ChromeB.boot
+          ; let con = Controllers dc cc cb
}