[Implementation of personal aggregator (del.icio.us, twwitter, google reader). Removal of some old files.
prb@mult.ifario.us**20080216103248] {
adddir ./src/Blog/Widgets/StreamOfConsciousness
hunk ./perpubplat.cabal 19
- fastcgi >= 3001.0.0, bytestring >= 0.9, pureMD5 >= 0.1.1, base64-string
+ fastcgi >= 3001.0.0, bytestring >= 0.9, pureMD5 >= 0.1.1, base64-string,
+ hxt >= 7.4
hunk ./src/Blog/Constants.hs 17
-blog_root = "http://mult.ifario.us"
+blog_root = "http://localhost:7007"
hunk ./src/Blog/Constants.hs 35
-generator_version = "0.9"
+generator_version = "0.9.1"
hunk ./src/Blog/Constants.hs 53
-base_url = "http://mult.ifario.us"
+base_url = "http://localhost:7007"
hunk ./src/Blog/Constants.hs 84
-twitter_pass = ""
+twitter_pass = "hnadner"
hunk ./src/Blog/Constants.hs 93
-flickr_api_key = ""
+flickr_api_key = "233b3c334c93b6f999f9b4b810f9d603"
hunk ./src/Blog/FrontEnd/Presentation.hs 15
-import qualified Blog.Widgets.Twitter as TwC
+import qualified Blog.Widgets.StreamOfConsciousness as SoC
hunk ./src/Blog/FrontEnd/Presentation.hs 109
- ; twc <- TwC.get_tweets $ CB.twitter cb
+ ; soc <- SoC.get_content $ CB.soc cb
hunk ./src/Blog/FrontEnd/Presentation.hs 115
- , h3 $ stringToHtml "Twitter"
- , primHtml twc
+ , h3 $ stringToHtml "Stream Of Consciousness"
+ , primHtml soc
hunk ./src/Blog/Widgets/ChromeBackEnd.hs 7
-import Blog.Widgets.Twitter ( TwitterController, boot_twitter )
+import Blog.Widgets.StreamOfConsciousness
hunk ./src/Blog/Widgets/ChromeBackEnd.hs 18
- , twitter :: TwitterController}
+ , soc :: SoCController }
hunk ./src/Blog/Widgets/ChromeBackEnd.hs 29
- ; tc <- boot_twitter C.twitter_user C.twitter_pass C.twitter_count
- ; return $ ChromeBackEnd f p t dc s ffd tc }
+ ; socc <- start_soc 20
+ ; start_twitter socc "paulrbrown" "" 15
+ ; start_delicious socc "prb"
+ ; start_google_reader socc google_user
+ ; return $ ChromeBackEnd f p t dc s ffd socc }
hunk ./src/Blog/Widgets/FlickrBadge.hs 1
-module Blog.Widgets.FlickrBadge ( flickr_badge ) where
-
-import Text.XHtml.Strict ( Html, script, (!), (<<),
- thetype, src, concatHtml, noHtml, identifier, primHtml, thediv )
-
-flickr_badge :: Html
-flickr_badge = thediv ! [ identifier "filckr_badge_uber_wrapper"]
- << ( thediv ! [ identifier "flickr_badge_wrapper" ]
- << ( concatHtml [ script ! [ thetype "text/javascript",
- src flickr_script ] << noHtml
- , flickr_link ] ) )
-
-flickr_link :: Html
-flickr_link = primHtml $ ""
- ++ "www.flick"
- ++ "r.com"
-
-flickr_count :: String
-flickr_count = show 10
-
-flickr_script :: String
-flickr_script = "http://www.flickr.com/badge_code_v2.gne?count="
- ++ flickr_count
- ++ "&display=random&size=t&layout=x&source=user&user=92922008%40N00"
+
rmfile ./src/Blog/Widgets/FlickrBadge.hs
addfile ./src/Blog/Widgets/StreamOfConsciousness.hs
hunk ./src/Blog/Widgets/StreamOfConsciousness.hs 1
-
+module Blog.Widgets.StreamOfConsciousness ( module Blog.Widgets.StreamOfConsciousness.DeliciousPosts
+ , module Blog.Widgets.StreamOfConsciousness.GoogleReader
+ , module Blog.Widgets.StreamOfConsciousness.Twitter
+ , module Blog.Widgets.StreamOfConsciousness.Thought
+ , module Blog.Widgets.StreamOfConsciousness.Controller ) where
+
+import Blog.Widgets.StreamOfConsciousness.DeliciousPosts
+import Blog.Widgets.StreamOfConsciousness.Twitter
+import Blog.Widgets.StreamOfConsciousness.GoogleReader
+import Blog.Widgets.StreamOfConsciousness.Thought
+import Blog.Widgets.StreamOfConsciousness.Controller
addfile ./src/Blog/Widgets/StreamOfConsciousness/Controller.hs
hunk ./src/Blog/Widgets/StreamOfConsciousness/Controller.hs 1
+module Blog.Widgets.StreamOfConsciousness.Controller where
+
+import Blog.Widgets.StreamOfConsciousness.Thought
+import Blog.BackEnd.HttpPoller
+
+import Control.Concurrent
+import Control.Concurrent.MVar
+import Control.Concurrent.Chan
+
+data Worker = Worker { soc_controller :: SoCController
+ , poller :: HttpPoller }
+
+data Snapshot = Snapshot { items :: [Thought]
+ , max_size :: Int
+ , version :: Int
+ , rendered :: String }
+ deriving ( Show, Read, Eq )
+
+data SoCRequest = GetData { snapshot_handback :: MVar Snapshot }
+ | GetHtmlFragment { content :: MVar String }
+ | Update { retry :: MVar Bool
+ , snapshot :: Snapshot }
+
+
+data SoCController = SoCController { tid :: ThreadId
+ , request_channel :: Chan SoCRequest }
+
+start_soc :: Int -> IO SoCController
+start_soc mx_sz = do { rc <- newChan
+ ; let snap = Snapshot [] mx_sz 0 ""
+ ; _tid <- forkIO $ loop rc snap
+ ; return $ SoCController _tid rc }
+
+stop_soc :: SoCController -> IO ()
+stop_soc = killThread . tid
+
+stop_worker :: Worker -> IO ()
+stop_worker = stop_poller . poller
+
+get_content :: SoCController -> IO String
+get_content c = do { x <- newEmptyMVar
+ ; writeChan (request_channel c) $ GetHtmlFragment x
+ ; takeMVar x }
+
+get_data :: SoCController -> IO Snapshot
+get_data c = do { x <- newEmptyMVar
+ ; writeChan (request_channel c) $ GetData x
+ ; takeMVar x }
+
+update :: SoCController -> Snapshot -> IO Bool
+update c snap = do { ok <- newEmptyMVar
+ ; writeChan (request_channel c) $ Update ok snap
+ ; takeMVar ok }
+
+collision_delay :: Int
+collision_delay = 1000
+
+commit :: SoCController -> [Thought] -> IO ()
+commit socc new_items = do { snap <- get_data socc
+ ; let items' = take (max_size snap) $ merge new_items $ items snap
+ ; let rendered' = thoughts_to_xhtml items'
+ ; let snap' = snap { items = items'
+ , rendered = rendered' }
+ ; ok <- update socc snap'
+ ; if ok then
+ return ()
+ else
+ do { threadDelay collision_delay
+ ; commit socc new_items }
+ }
+
+loop :: Chan SoCRequest -> Snapshot -> IO ()
+loop ch snap =
+ do { req <- readChan ch
+ ; snap' <- case req of
+ GetHtmlFragment c ->
+ do { putMVar c $ rendered snap
+ ; return snap }
+ GetData h ->
+ do { putMVar h snap
+ ; return snap }
+ Update ok snap'' ->
+ if (version snap) == (version snap'') then
+ do { putMVar ok True
+ ; let snap' = snap'' { version = (version snap) + 1 }
+ ; return snap' }
+ else
+ do { putMVar ok False
+ ; return snap }
+ ; loop ch snap' }
+
addfile ./src/Blog/Widgets/StreamOfConsciousness/DeliciousPosts.hs
hunk ./src/Blog/Widgets/StreamOfConsciousness/DeliciousPosts.hs 1
+{-# LANGUAGE Arrows, NoMonomorphismRestriction #-}
+module Blog.Widgets.StreamOfConsciousness.DeliciousPosts ( start_delicious ) where
+
+import Blog.Widgets.StreamOfConsciousness.Thought
+import Blog.Widgets.StreamOfConsciousness.Controller
+import Blog.BackEnd.HttpPoller
+
+import Text.XML.HXT.Arrow
+import Network.HTTP
+import Network.URI ( parseURI )
+import Data.Maybe ( fromJust )
+
+
+delicious_period :: Int
+delicious_period = 360 * 10^6
+
+start_delicious :: SoCController -> String -> IO Worker
+start_delicious socc user = do { let req = Request ( fromJust . parseURI $ "http://feeds.delicious.com/rss/" ++ user ) GET [] ""
+ ; p <- start_poller "DeliciousPosts" req (handle_posts socc) delicious_period
+ ; return $ Worker socc p }
+
+handle_posts :: SoCController -> String -> IO ()
+handle_posts socc body = do { posts <- runX ( readString parse_opts body >>> getItems )
+ ; commit socc posts }
+
+parse_opts = [(a_validate, v_0), (a_check_namespaces,v_1)]
+
+atElemQName qn = deep (isElem >>> hasQName qn)
+text = getChildren >>> getText
+textOf qn = atElemQName qn >>> text
+
+rdf_uri :: String
+rdf_uri = "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+
+rdf_RDF :: QName
+rdf_RDF = QN "rdf" "RDF" rdf_uri
+
+rss_uri :: String
+rss_uri = "http://purl.org/rss/1.0/"
+
+rss_item :: QName
+rss_item = QN "rss" "item" rss_uri
+
+rss_title :: QName
+rss_title = QN "rss" "title" rss_uri
+
+rss_link :: QName
+rss_link = QN "rss" "link" rss_uri
+
+dc_uri :: String
+dc_uri = "http://purl.org/dc/elements/1.1/"
+
+dc_date :: QName
+dc_date = QN "dc" "date" dc_uri
+
+getItem = atElemQName rss_item >>>
+ proc i -> do
+ t <- textOf rss_title -< i
+ u <- textOf rss_link -< i
+ d <- textOf dc_date -< i
+ returnA -< Thought Delicious d u t
+
+getItems = atElemQName rdf_RDF >>>
+ proc r -> do
+ items <- getItem -< r
+ returnA -< items
addfile ./src/Blog/Widgets/StreamOfConsciousness/GoogleReader.hs
hunk ./src/Blog/Widgets/StreamOfConsciousness/GoogleReader.hs 1
+{-# LANGUAGE Arrows, NoMonomorphismRestriction #-}
+module Blog.Widgets.StreamOfConsciousness.GoogleReader ( start_google_reader, google_user ) where
+
+import Blog.Widgets.StreamOfConsciousness.Thought
+import Blog.Widgets.StreamOfConsciousness.Controller
+import Blog.BackEnd.HttpPoller
+
+import Text.XML.HXT.Arrow
+import Network.HTTP
+import Network.URI ( parseURI )
+import Data.Maybe ( fromJust )
+
+
+google_reader_period :: Int
+google_reader_period = 240 * 10^6
+
+google_user :: String
+google_user = "14627107182419169041"
+
+start_google_reader :: SoCController -> String -> IO Worker
+start_google_reader socc user = do { let req = Request ( fromJust . parseURI $ "http://www.google.com/reader/public/atom/user/" ++ user ++ "/state/com.google/broadcast" ) GET [] ""
+ ; p <- start_poller "GoogleReaderSharedItems" req (handle_posts socc) google_reader_period
+ ; return $ Worker socc p }
+
+handle_posts :: SoCController -> String -> IO ()
+handle_posts socc body = do { posts <- runX ( readString parse_opts body >>> getEntries )
+ ; commit socc posts }
+
+parse_opts = [(a_validate, v_0), (a_check_namespaces,v_1)]
+
+atElemQName qn = deep (isElem >>> hasQName qn)
+childElemQName qn = getChildren >>> isElem >>> hasQName qn
+text = getChildren >>> getText
+textOf qn = childElemQName qn >>> text
+
+atom_uri :: String
+atom_uri = "http://www.w3.org/2005/Atom"
+
+atom_entry :: QName
+atom_entry = QN "atom" "entry" atom_uri
+
+atom_title :: QName
+atom_title = QN "atom" "title" atom_uri
+
+atom_updated :: QName
+atom_updated = QN "atom" "updated" atom_uri
+
+atom_link :: QName
+atom_link = QN "atom" "link" atom_uri
+
+atom_feed :: QName
+atom_feed = QN "atom" "feed" atom_uri
+
+getEntry = atElemQName atom_entry >>>
+ proc i -> do
+ t <- textOf atom_title -< i
+ l <- childElemQName atom_link >>> hasAttrValue "rel" ((==) "alternate") -< i
+ u <- getAttrValue "href" -< l
+ d <- textOf atom_updated -< i
+ returnA -< Thought GoogleReader d u t
+
+getEntries = atElemQName atom_feed >>>
+ proc r -> do
+ entries <- getEntry -< r
+ returnA -< entries
addfile ./src/Blog/Widgets/StreamOfConsciousness/Thought.hs
hunk ./src/Blog/Widgets/StreamOfConsciousness/Thought.hs 1
-
+module Blog.Widgets.StreamOfConsciousness.Thought where
+
+import Text.XHtml.Strict
+import Data.List
+
+import Blog.FrontEnd.ContentAtoms
+import qualified Blog.Constants as C
+
+data Channel = Delicious | Twitter | GoogleReader
+ deriving ( Show, Read, Eq, Ord, Enum )
+
+icon :: Channel -> Html
+icon c = image ! [ src $ C.blog_root ++ "/files/" ++ (show c) ++ "-icon.png"
+ , alt $ show c ]
+
+data Thought = Thought { channel :: Channel
+ , date :: String
+ , url :: String
+ , txt :: String }
+
+ deriving ( Show, Read )
+
+instance Eq Thought where
+ t1 == t2 = (channel t1 == channel t2)
+ && (date t1 == date t2)
+
+instance Ord Thought where
+ t1 <= t2 = ((date t1) <= (date t2))
+ || ( ((date t1) == (date t2))
+ && ((channel t1) <= (channel t2)) )
+
+thoughts_to_xhtml :: [Thought] -> String
+thoughts_to_xhtml = showHtmlFragment . (divid "thoughts")
+ . (traverse_thoughts "1970-01-01")
+
+traverse_thoughts :: String -> [Thought] -> Html
+traverse_thoughts _ [] = noHtml
+traverse_thoughts l_d (t:ts)
+ = (concatHtml [ if l_d `isPrefixOf` d then
+ noHtml
+ else
+ (p ! [theclass "thought_group" ]) . stringToHtml $ d
+ , p ! [theclass "thought"] $ concatHtml [ icon $ channel t
+ , stringToHtml " "
+ , to_html t
+ ]
+ ]) +++ (traverse_thoughts d ts)
+ where
+ d = take 10 $ date t
+
+to_html :: Thought -> Html
+to_html (Thought Twitter d u t) = concatHtml [ _a u time
+ , stringToHtml " "
+ , text ]
+ where
+ wrap st = (thespan ! [ theclass st ])
+ time_hunk = (take 9) . (drop 11)
+ time = (wrap "tweet_stamp") . stringToHtml $ time_hunk d
+ text = wrap "tweet_text" $ primHtml t
+
+to_html (Thought _ _ u t) = _a u (primHtml t)
+
+-- "zip" two lists into an ordered list, eliminating duplicates
+merge :: (Eq a, Ord a) => [a] -> [a] -> [a]
+merge as bs = merge_ as [] bs
+
+merge_ :: (Eq a, Ord a) => [a] -> [a] -> [a] -> [a]
+merge_ [] y z = (reverse y) ++ z
+merge_ x y [] = (reverse y) ++ x
+merge_ x@(x0:xs) y z@(z0:zs) | x0 == z0 = merge_ xs (x0:y) zs
+ | x0 >= z0 = merge_ xs (x0:y) z
+ | otherwise = merge_ x (z0:y) zs
+
+dedup :: (Eq a) => [a] -> [a]
+dedup = (map head) . group
addfile ./src/Blog/Widgets/StreamOfConsciousness/Twitter.hs
hunk ./src/Blog/Widgets/StreamOfConsciousness/Twitter.hs 1
+module Blog.Widgets.StreamOfConsciousness.Twitter ( start_twitter ) where
+
+import Blog.Widgets.StreamOfConsciousness.Thought
+import Blog.Widgets.StreamOfConsciousness.Controller
+
+import Text.ParserCombinators.Parsec
+
+import Network.HTTP
+import Network.HTTP.Headers
+import Network.URI ( parseURI )
+import Data.Maybe ( fromJust )
+import Data.List ( elemIndex, intersperse )
+import Text.XHtml.Strict
+
+import qualified Codec.Binary.Base64.String as B64
+
+import Blog.Widgets.JsonUtilities
+
+import Blog.BackEnd.HttpPoller
+
+twitter_period :: Int
+twitter_period = 300 * 10^6
+
+start_twitter :: SoCController -> String -> String -> Int -> IO Worker
+start_twitter socc user password count
+ = do { let req = build_tweet_request user password count
+ ; p <- start_poller "Tweets" req (handle_tweets socc user)
+ twitter_period
+ ; return $ Worker socc p }
+
+build_tweet_request :: String -> String -> Int -> Request
+build_tweet_request user password count = Request uri GET heads ""
+ where
+ uri = fromJust $ parseURI $ "http://twitter.com/statuses/user_timeline/"
+ ++ user ++ ".json?count=" ++ (show count)
+ heads = [ Header HdrAuthorization $ (++) "Basic " $ B64.encode $ user ++ ":" ++ password ]
+
+handle_tweets :: SoCController -> String -> String -> IO ()
+handle_tweets socc user body
+ = 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 }
+
+tweet_id_to_link :: String -> String -> String
+tweet_id_to_link user t_id = "http://twitter.com/" ++ user ++ "/statuses/" ++ t_id
+
+tweet_body_to_xhtml :: String -> String
+tweet_body_to_xhtml = showHtmlFragment . (thespan ! [ theclass "tweet_text" ])
+ . primHtml . pre_process
+
+convert_twitter_tstmp :: String -> String
+convert_twitter_tstmp ts = concat [ y, "-", mo', "-", d, "T", tm, "Z" ]
+ where
+ mo = take 3 $ drop 4 ts
+ mo' = pad $ 1 + ( fromJust $ elemIndex mo [ "Jan", "Feb", "Mar", "Apr", "May", "Jun"
+ , "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" ] )
+ pad = \n -> if n <10 then ('0':show n) else show n
+ y = take 4 $ drop 26 ts
+ d = take 2 $ drop 8 ts
+ tm = take 8 $ drop 11 ts
+
+
+pre_process :: String -> String
+pre_process s = case parse pre_process_parser "" s of
+ Left err -> error . show $ err
+ Right v -> v
+
+
+pre_process_parser :: Parser String
+pre_process_parser = do { ts <- tok `sepBy` (many1 space)
+ ; return $ concat . (intersperse " ") $ ts }
+
+tok :: Parser String
+tok = try http_link <|> try at_someone <|> word
+
+word :: Parser String
+word = many1 $ noneOf " "
+
+at_someone :: Parser String
+at_someone = do { char '@'
+ ; s <- many1 $ noneOf " "
+ ; return $ "@" ++ s ++ "" }
+
+http_link :: Parser String
+http_link = do { string "http://"
+ ; s <- many1 $ noneOf " "
+ ; return $ "" ++ s ++ "" }
+
hunk ./src/Blog/Widgets/Twitter.hs 1
-module Blog.Widgets.Twitter (boot_twitter, get_tweets, TwitterController ( poller, twitter_tid )) where
-
-import Text.ParserCombinators.Parsec
-
-import Network.HTTP
-import Network.HTTP.Headers
-import Network.URI ( parseURI )
-import Data.Maybe ( fromJust )
-import Data.List ( elemIndex, intersperse )
-import Text.XHtml.Strict
-import Control.Concurrent
-import Control.Concurrent.Chan
-import Control.Concurrent.MVar
-
-import qualified Codec.Binary.Base64.String as B64
-
-import Blog.Widgets.JsonUtilities
-
-import Blog.BackEnd.HttpPoller
-
-data TRequest = GetTweets ( MVar String )
- | UpdateTweets String
-
-data TwitterController = TwitterController { request_channel :: Chan TRequest
- , poller :: HttpPoller
- , twitter_tid :: ThreadId }
-
-boot_twitter :: String -> String -> Int -> IO TwitterController
-boot_twitter user password count = do { let req = build_tweet_request user password count
- ; rc <- newChan
- ; p <- start_poller "Tweets" req (handle_body rc) (60 * 10^6)
- ; tid <- forkIO $ loop rc ""
- ; return $ TwitterController rc p tid }
-
-loop :: Chan TRequest -> String -> IO ()
-loop rc xh = do { req <- readChan rc
- ; case req of
- GetTweets hb ->
- putMVar hb xh >> loop rc xh
- UpdateTweets xh' ->
- loop rc xh' }
-
-build_tweet_request :: String -> String -> Int -> Request
-build_tweet_request user password count = Request uri GET heads ""
- where
- uri = fromJust $ parseURI $ "http://twitter.com/statuses/user_timeline/"
- ++ user ++ ".json?count=" ++ (show count)
- heads = [ Header HdrAuthorization $ (++) "Basic " $ B64.encode $ user ++ ":" ++ password ]
-
-handle_body :: Chan TRequest -> String -> IO ()
-handle_body tc body = do { let v = parse_json body
- ; let texts = map uns $ una $ v "text"
- ; let times = map (convert_twitter_tstmp . uns) $ una $ v "created_at"
- ; update_tweets tc $ tweets_to_xhtml $ zip texts times }
-
-send :: TwitterController -> TRequest -> IO ()
-send tc = writeChan (request_channel tc)
-
-update_tweets :: Chan TRequest -> String -> IO ()
-update_tweets tc tweets = writeChan tc $ UpdateTweets tweets
-
-get_tweets :: TwitterController -> IO String
-get_tweets tc = do { hb <- newEmptyMVar
- ; send tc $ GetTweets hb
- ; takeMVar hb }
-
-convert_twitter_tstmp :: String -> String
-convert_twitter_tstmp ts = concat [ y, "-", mo', "-", d, "T", tm, "Z" ]
- where
- mo = take 3 $ drop 4 ts
- mo' = pad $ 1 + ( fromJust $ elemIndex mo [ "Jan", "Feb", "Mar", "Apr", "May", "Jun"
- , "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" ] )
- pad = \n -> if n <10 then ('0':show n) else show n
- y = take 4 $ drop 26 ts
- d = take 2 $ drop 8 ts
- tm = take 8 $ drop 11 ts
-
-tweets_to_xhtml :: [(String,String)] -> String
-tweets_to_xhtml = showHtmlFragment . (ulist ! [ identifier "tweets"]) . concatHtml . (map tweet_to_xhtml)
-
-tweet_to_xhtml :: (String, String) -> Html
-tweet_to_xhtml (txt,tstmp) = (li ! [ theclass "tweet" ]) $ (wrap "tweet_stamp" $ stringToHtml tstmp)
- +++ (stringToHtml " ") +++ (wrap "tweet_text" $ primHtml . pre_process $ txt)
- where
- wrap st = (thespan ! [ theclass st ])
-
-pre_process :: String -> String
-pre_process s = case parse pre_process_parser "" s of
- Left err -> error . show $ err
- Right v -> v
-
-
-pre_process_parser :: Parser String
-pre_process_parser = do { ts <- tok `sepBy` (many1 space)
- ; return $ concat . (intersperse " ") $ ts }
-
-tok :: Parser String
-tok = try http_link <|> try at_someone <|> word
-
-word :: Parser String
-word = many1 $ noneOf " "
-
-at_someone :: Parser String
-at_someone = do { char '@'
- ; s <- many1 $ noneOf " "
- ; return $ "@" ++ s ++ "" }
-
-http_link :: Parser String
-http_link = do { string "http://"
- ; s <- many1 $ noneOf " "
- ; return $ "" ++ s ++ "" }
+
rmfile ./src/Blog/Widgets/Twitter.hs
}