[Better HTTP polling and simpler JSON interaction. prb@mult.ifario.us**20080212164007] { hunk ./src/Blog/BackEnd/HttpPoller.hs 3 +import Data.Char +import Data.Maybe + hunk ./src/Blog/BackEnd/HttpPoller.hs 7 +import Network.HTTP.Headers + hunk ./src/Blog/BackEnd/HttpPoller.hs 10 +import Utilities hunk ./src/Blog/BackEnd/HttpPoller.hs 12 -import Control.Concurrent ( ThreadId, threadDelay, killThread ) +import Control.Concurrent ( ThreadId, threadDelay, killThread, forkIO, myThreadId ) hunk ./src/Blog/BackEnd/HttpPoller.hs 14 -data HttpPoller = HttpPoller { request :: Request - , handle_response :: Result Response -> IO () - , polling_period_millis :: Int +data HttpPoller = HttpPoller { name :: String + , base_request :: Request + , handle_response :: String -> IO () + , polling_period_micros :: Int hunk ./src/Blog/BackEnd/HttpPoller.hs 20 +start_poller :: String -> Request -> (String -> IO ()) -> Int -> IO HttpPoller +start_poller n b hdlr p = do { tid <- myThreadId + ; let pre_h = HttpPoller n b hdlr p tid + ; new_tid <- forkIO $ poller_loop pre_h Nothing Nothing + ; return $ pre_h { p_tid = new_tid } } + hunk ./src/Blog/BackEnd/HttpPoller.hs 29 -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 () - } +poller_loop :: HttpPoller -> Maybe String -> Maybe String -> IO () +poller_loop p me mlm = do { (e,lm,cont) <- + do { ct_start <- getClockTime + ; let req = (add_maybe HdrIfNoneMatch me) . (add_maybe HdrIfModifiedSince mlm) + $ base_request p + ; resp <- simpleHTTP req + ; ghetto_log (name p) (show req) + ; ct_stop <- getClockTime + ; ghetto_log (name p) $ logtime (base_request p) ct_stop ct_start + ; case resp of + Left e -> + do { ghetto_log (name p) $ show e + ; return (me,mlm,True) } + Right r -> + do { case r of + Response (2,0,0) _ _ body -> + do { ghetto_log (name p) $ "Server returned a 200; processing response body." + ; handle_response p $ body + ; let e = findHeader HdrETag r + ; ghetto_log (name p) $ "Found ETag " ++ (fromMaybe "" e) + ; let lm = findHeader HdrLastModified r + ; ghetto_log (name p) $ "Found last modified timestamp of " ++ (fromMaybe "" lm) + ; return (e, lm, True) + } + Response (3,0,4) _ _ _ -> + do { ghetto_log (name p) $ "Server returned a 304; nothing to do." + ; return (me, mlm, True) + } + Response rc@(3,0,k) _ _ _ | k == 1 || k == 2 -> + do { ghetto_log (name p) $ "Server returned a " ++ (show_rc rc) + ++ " with new location " ++ (fromMaybe "" $ findHeader HdrLocation r) + ; return (me, mlm, True) + } + Response rc reasn _ _ -> + do { ghetto_log (name p) $ "Server returned an unexpected response " ++ (show_rc rc) ++ " " ++ reasn + ; return (me, mlm, True) + } + } + } + `E.catch` \ex -> do { cont <- handle_exception ex + ; return (me,mlm,cont) } + ; if cont then + do { ghetto_log (name p) $ "Sleeping for " + ++ (show . polling_period_micros $ p) ++ " microseconds." + ; loop <- + do { threadDelay $ polling_period_micros p + ; return True } + `E.catch` handle_exception + ; if loop then + poller_loop p e lm + else + return () } + else + return () + } + +ghetto_log :: String -> String -> IO () +ghetto_log h m = do { n <- now + ; print $ n ++ " [" ++ h ++ "] " ++ m } hunk ./src/Blog/BackEnd/HttpPoller.hs 89 -logtime :: Request -> ClockTime -> ClockTime -> IO () -logtime req ct_stop ct_start = - print $ "Took " ++ td ++ " seconds to perform " - ++ (show . rqMethod $ req ) - ++ " " - ++ (show . rqURI $ req ) +add_maybe :: HeaderName -> Maybe String -> Request -> Request +add_maybe _ Nothing req = req +add_maybe h (Just s) req = req { rqHeaders = (Header h s):(rqHeaders req) } + +logtime :: Request -> ClockTime -> ClockTime -> String +logtime req ct_stop ct_start = "Took " ++ td ++ " seconds to perform " + ++ (show . rqMethod $ req ) ++ " " + ++ (show . rqURI $ req ) hunk ./src/Blog/BackEnd/HttpPoller.hs 130 +show_rc :: ResponseCode -> String +show_rc (h,t,o) = [ digit h, digit t, digit o ] + where + digit = chr . (ord '0' + ) + hunk ./src/Blog/Widgets/Delicious.hs 5 +import Blog.Widgets.JsonUtilities hunk ./src/Blog/Widgets/Delicious.hs 239 - , top_tags = to_tag_list . uno $ M.findWithDefault empty "top_tags" $ uno o + , top_tags = to_tag_list . uno $ M.findWithDefault empty_object "top_tags" $ uno o hunk ./src/Blog/Widgets/Delicious.hs 250 -blank :: J.Value -blank = J.String "" - hunk ./src/Blog/Widgets/Delicious.hs 253 -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 ./src/Blog/Widgets/FlickrCollage.hs 3 +import Blog.Widgets.JsonUtilities hunk ./src/Blog/Widgets/FlickrCollage.hs 15 -import qualified Data.Map as M hunk ./src/Blog/Widgets/FlickrCollage.hs 76 - ; 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 }) } + ; p <- start_poller "FlickrCollage" (flickr_people_getPublicPhotos_req user_id) + (handle_flickr_response fc) polling_frequency + ; return (fc { fc_tid = ftid}, p) } hunk ./src/Blog/Widgets/FlickrCollage.hs 80 -handle_flickr_response :: FlickrController -> Result Response -> IO () -handle_flickr_response fc resp = put_photos fc $ response_to_photo_urls resp +handle_flickr_response :: FlickrController -> String -> IO () +handle_flickr_response fc body = put_photos fc $ response_to_photo_urls body + +response_to_photo_urls :: String -> [FlickrPhoto] +response_to_photo_urls body = map to_photo + ( una $ json "photos" "photo" ) + where + json = (parse_json . UTF8.decodeString $ body) hunk ./src/Blog/Widgets/FlickrCollage.hs 89 -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 - hunk ./src/Blog/Widgets/FlickrCollage.hs 135 -show_reason :: Response -> String -show_reason (Response (c1,c2,c3) r _ _) = (show (c1*100 + c2*10 + c3)) - ++ ": " ++ r hunk ./src/Blog/Widgets/FlickrCollage.hs 140 -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" } +to_photo :: J.Value -> FlickrPhoto +to_photo m = FlickrPhoto { photo_id = uns $ m "id" + , owner = uns $ m "owner" + , secret = uns $ m "secret" + , server = uns $ m "server" + , photo_title = uns $ m "title" + , farm = unn $ m "farm" } hunk ./src/Blog/Widgets/FlickrCollage.hs 165 -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 - }