[Switched to honest logging with use of hslogger. prb@mult.ifario.us**20080505073937] { hunk ./perpubplat.cabal 18 - old-locale >= 1.0, json >= 0.1, network >= 2.1, time >= 1.1.2.0, unix >= 2.3, + old-locale >= 1.0, json == 0.1, network >= 2.1, time >= 1.1.2.0, unix >= 2.3, hunk ./perpubplat.cabal 20 - hxt == 7.5 + hxt == 7.5, hslogger >= 1.0.5 hunk ./servletsrc/perpubplat.hs 21 +import Blog.BackEnd.AsyncLogHandler + +import qualified System.Log.Logger as L + +import qualified System.IO as SIO + hunk ./servletsrc/perpubplat.hs 187 -main = do { print "Booting master application." +main = do { root_l <- L.getRootLogger + ; h <- SIO.openFile "/tmp/perpubplat.log" SIO.AppendMode + ; logfile_appender <- asyncHandler h L.INFO + ; L.saveGlobalLogger $ (L.setHandlers [logfile_appender]) . (L.setLevel L.INFO) $ root_l addfile ./src/Blog/BackEnd/AsyncLogHandler.hs hunk ./src/Blog/BackEnd/AsyncLogHandler.hs 1 +module Blog.BackEnd.AsyncLogHandler where + +import System.Log.Handler +import System.IO +import System.Log + +import Utilities ( now ) + +import Control.Concurrent ( forkIO ) +import Control.Concurrent.Chan ( Chan, newChan, readChan, writeChan ) + +data AsyncLogHandler = AsyncLogHandler { channel :: Chan (LogRecord, String) + , level :: Priority } + +instance LogHandler AsyncLogHandler where + setLevel alh p = alh { level = p } + getLevel alh = level alh + emit alh lr msg = writeChan (channel alh) (lr,msg) + close _ = return () -- make this better + +asyncHandler :: Handle -> Priority -> IO AsyncLogHandler +asyncHandler h pri = do { c <- newChan + ; forkIO $ append h c + ; return $ AsyncLogHandler { channel = c + , level = pri } } + + +append :: Handle -> Chan (LogRecord, String) -> IO () +append h c = do { ((p,m),l) <- readChan c + ; n <- now + ; hPutStrLn h $ n ++ " [" ++ (show p) ++ "] " ++ l ++ " - " ++ m + ; append h c + ; hFlush h } hunk ./src/Blog/BackEnd/HttpPoller.hs 6 +import qualified System.Log.Logger as L + hunk ./src/Blog/BackEnd/HttpPoller.hs 12 -import Utilities hunk ./src/Blog/BackEnd/HttpPoller.hs 25 + ; L.infoM n $ "Forked new HttpPoller for " ++ ( show . rqURI $ b) ++ " with thread ID " + ++ (show new_tid) hunk ./src/Blog/BackEnd/HttpPoller.hs 37 + ; L.debugM (name p) $ "Performing HTTP request " ++ (show req) hunk ./src/Blog/BackEnd/HttpPoller.hs 39 - ; ghetto_log (name p) (show req) hunk ./src/Blog/BackEnd/HttpPoller.hs 40 - ; ghetto_log (name p) $ logtime (base_request p) ct_stop ct_start + ; L.infoM (name p) $ logtime (base_request p) ct_stop ct_start hunk ./src/Blog/BackEnd/HttpPoller.hs 43 - do { ghetto_log (name p) $ show e + do { L.errorM (name p) $ "Error connecting to " ++ ( show . rqURI $ req ) + ++ ": " ++ (show e) hunk ./src/Blog/BackEnd/HttpPoller.hs 49 - do { ghetto_log (name p) $ "Server returned a 200; processing response body." + do { L.infoM (name p) $ "Server returned a 200; processing response body." hunk ./src/Blog/BackEnd/HttpPoller.hs 52 - ; ghetto_log (name p) $ "Found ETag " ++ (fromMaybe "" e) + ; L.infoM (name p) $ "Found ETag " ++ (fromMaybe "" e) hunk ./src/Blog/BackEnd/HttpPoller.hs 54 - ; ghetto_log (name p) $ "Found last modified timestamp of " ++ (fromMaybe "" lm) + ; L.infoM (name p) $ "Found last modified timestamp of " ++ (fromMaybe "" lm) hunk ./src/Blog/BackEnd/HttpPoller.hs 58 - do { ghetto_log (name p) $ "Server returned a 304; nothing to do." + do { L.infoM (name p) $ "Server returned a 304; nothing to do." hunk ./src/Blog/BackEnd/HttpPoller.hs 62 - do { ghetto_log (name p) $ "Server returned a " ++ (show_rc rc) + do { L.infoM (name p) $ "Server returned a " ++ (show_rc rc) hunk ./src/Blog/BackEnd/HttpPoller.hs 67 - do { ghetto_log (name p) $ "Server returned an unexpected response " ++ (show_rc rc) ++ " " ++ reasn + do { L.errorM (name p) $ "Server returned an unexpected response " ++ (show_rc rc) ++ " " ++ reasn hunk ./src/Blog/BackEnd/HttpPoller.hs 72 - `E.catch` \ex -> do { cont <- handle_exception ex + `E.catch` \ex -> do { cont <- handle_exception (name p) ex hunk ./src/Blog/BackEnd/HttpPoller.hs 75 - do { ghetto_log (name p) $ "Sleeping for " + do { L.infoM (name p) $ "Sleeping for " hunk ./src/Blog/BackEnd/HttpPoller.hs 80 - `E.catch` handle_exception + `E.catch` (handle_exception (name p)) hunk ./src/Blog/BackEnd/HttpPoller.hs 89 -ghetto_log :: String -> String -> IO () -ghetto_log h m = do { n <- now - ; print $ n ++ " [" ++ h ++ "] " ++ m } - hunk ./src/Blog/BackEnd/HttpPoller.hs 100 -handle_exception :: E.Exception -> IO Bool -handle_exception (E.ErrorCall msg) = - do { print $ "Exception during HTTP operation: " ++ msg +handle_exception :: String -> E.Exception -> IO Bool +handle_exception hnd (E.ErrorCall msg) = + do { L.errorM hnd $ "Exception during HTTP operation: " ++ msg hunk ./src/Blog/BackEnd/HttpPoller.hs 104 -handle_exception (E.AsyncException E.ThreadKilled) = - do { print $ "Kill received; exiting gracefully." +handle_exception hnd (E.AsyncException E.ThreadKilled) = + do { L.errorM hnd $ "Kill received; exiting gracefully." hunk ./src/Blog/BackEnd/HttpPoller.hs 107 -handle_exception (E.IOException ex) = - do { print $ "IOException encountered: " ++ show ex +handle_exception hnd (E.IOException ex) = + do { L.errorM hnd $ "IOException encountered: " ++ show ex hunk ./src/Blog/BackEnd/HttpPoller.hs 110 -handle_exception e = - do { print $ "Unexpected exception encountered; stopping poller. Exception was: " ++ (show e) +handle_exception hnd e = + do { L.errorM hnd $ "Unexpected exception encountered; stopping poller. Exception was: " ++ (show e) hunk ./src/Blog/Constants.hs 93 -flickr_api_key = "" -- fill yours in +flickr_api_key = "233b3c334c93b6f999f9b4b810f9d603" hunk ./src/Blog/Widgets/Delicious.hs 7 +import qualified System.Log.Logger as L + hunk ./src/Blog/Widgets/Delicious.hs 28 +log_handle :: String +log_handle = "DeliciousLinks" + hunk ./src/Blog/Widgets/Delicious.hs 105 + ; L.infoM log_handle $ "Forked back-end scheduler as thread ID " ++ (show tid) hunk ./src/Blog/Widgets/Delicious.hs 123 + ; L.infoM log_handle $ "Forked front-end controller as thread ID " ++ (show tid) hunk ./src/Blog/Widgets/Delicious.hs 164 -ffd_loop ffd = do { fire $ target_scheduler ffd +ffd_loop ffd = do { L.infoM log_handle "Waking up worker..." + ; fire $ target_scheduler ffd hunk ./src/Blog/Widgets/Delicious.hs 185 - s_loop s m + do { L.debugM log_handle "No next action registered; reading from request channel." + ; s_loop s m } hunk ./src/Blog/Widgets/Delicious.hs 226 -fetch_url_data url = do { res <- simpleHTTP . request_for_url_data $ url - ; print $ "Loading data for " ++ url +fetch_url_data url = do { L.infoM log_handle $ "Loading data for " ++ url + ; res <- simpleHTTP . request_for_url_data $ url hunk ./src/Blog/Widgets/Delicious.hs 230 - return . Just $! process_body body - _ -> - do { print . show $ request_for_url_data url - ; print $ show res - ; return Nothing } + process_body body + Right (Response rc reason _ _) -> + do { L.errorM log_handle $ "Received " ++ (show_rc rc) + ++ " response code from delicious with reason " ++ reason + ; return Nothing } + Left err -> + do { L.errorM log_handle $ "Error connecting to " ++ (show url) ++ ": " ++ (show err) + ; return Nothing } hunk ./src/Blog/Widgets/Delicious.hs 240 -process_body :: String -> DeliciousRecord +show_rc :: (Int, Int, Int) -> String +show_rc (x,y,z) = show $ (100 * x) + (10 * y) + z + +process_body :: String -> IO (Maybe DeliciousRecord) hunk ./src/Blog/Widgets/Delicious.hs 245 - case parse_crufty_json body of - J.Array a -> - case a of - [] -> - DeliciousRecord "" [] 0 "" - [o] -> - DeliciousRecord { hash = uns $ M.findWithDefault blank "hash" $ uno o - , top_tags = to_tag_list . uno $ M.findWithDefault empty_object "top_tags" $ uno o - , url = uns $ M.findWithDefault blank "url" $ uno o - , total_posts = unn $ M.findWithDefault zero "total_posts" $ uno o } + case parse_utf8_json $ unescape body of + Right (J.Array a) -> + return $ Just (unpack_json a) + Right _ -> + do { L.errorM log_handle $ "JSON response did not contain an array at the top level." + ; return Nothing } + Left err -> + do { L.errorM log_handle $ "Error parsing JSON: " ++ err + ; return Nothing } hunk ./src/Blog/Widgets/Delicious.hs 255 -parse_crufty_json :: String -> J.Value -parse_crufty_json = parse_json . unescape +unpack_json :: [J.Value] -> DeliciousRecord +unpack_json [] = DeliciousRecord "" [] 0 "" +unpack_json [o] = DeliciousRecord { hash = uns $ M.findWithDefault blank "hash" $ uno o + , top_tags = to_tag_list . uno $ M.findWithDefault empty_object "top_tags" $ uno o + , url = uns $ M.findWithDefault blank "url" $ uno o + , total_posts = unn $ M.findWithDefault zero "total_posts" $ uno o } hunk ./src/Blog/Widgets/FlickrCollage.hs 7 +import qualified System.Log.Logger as L + hunk ./src/Blog/Widgets/FlickrCollage.hs 22 +log_handle :: String +log_handle = "FlickrCollage" + hunk ./src/Blog/Widgets/FlickrCollage.hs 50 -polling_frequency = 15 * 60 * 10^6 +polling_frequency = 15 * 60 * 10^6 -- 15 minutes hunk ./src/Blog/Widgets/FlickrCollage.hs 72 -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 body +handle_flickr_response fc body = case parse_utf8_json body of + Right v -> + do { let photos = map to_photo ( una $ v "photos" "photo" ) + ; L.infoM log_handle $ "Retrieved " ++ (show . length $ photos) ++ " photos." + ; put_photos fc photos } + Left err -> + L.errorM log_handle err hunk ./src/Blog/Widgets/JsonUtilities.hs 8 - -parse_json :: String -> J.Value -parse_json s = case P.parse J.json "" $ UTF8.decodeString s of - Left err -> error . show $ err - Right v -> v +parse_utf8_json :: String -> Either String J.Value +parse_utf8_json s = case ( P.parse J.json "" ) . UTF8.decodeString $ s of + Right v -> Right v + Left err -> Left $ show err hunk ./src/Blog/Widgets/StreamOfConsciousness/Twitter.hs 8 +import qualified System.Log.Logger as L + hunk ./src/Blog/Widgets/StreamOfConsciousness/Twitter.hs 23 +log_handle :: String +log_handle = "Tweets" + hunk ./src/Blog/Widgets/StreamOfConsciousness/Twitter.hs 32 - ; p <- start_poller "Tweets" req (handle_tweets socc user) + ; p <- start_poller log_handle req (handle_tweets socc user) hunk ./src/Blog/Widgets/StreamOfConsciousness/Twitter.hs 45 - = do { let v = parse_json body - ; let texts = map (tweet_body_to_xhtml . uns) $ una $ v "text" - ; let times = map (convert_twitter_tstmp . uns) $ una $ v "created_at" - ; let urls = map ((tweet_id_to_link user) . show . unn) $ una $ v "id" - ; let tweets = map (\ (d,u,t) -> Thought Twitter d u t) $ zip3 times urls texts - ; commit socc tweets } + = case parse_utf8_json body of + Right v -> + do { let texts = map (tweet_body_to_xhtml . uns) $ una $ v "text" + ; let times = map (convert_twitter_tstmp . uns) $ una $ v "created_at" + ; let urls = map ((tweet_id_to_link user) . show . unn) $ una $ v "id" + ; let tweets = map (\ (d,u,t) -> Thought Twitter d u t) $ zip3 times urls texts + ; commit socc tweets } + Left err_message -> + L.errorM log_handle err_message }