[Compaction of repository (new more separate servlet), addition of delicious polling/caching functionality as alpha.
prb@mult.ifario.us**20080203221428] {
move ./perpubplat/LICENSE ./LICENSE
move ./perpubplat/Setup.lhs ./Setup.lhs
move ./perpubplat/perpubplat.cabal ./perpubplat.cabal
move ./perpubplat/src ./src
adddir ./perpubplat/servletsrc
move ./perpubplat/servletsrc ./servletsrc
move ./perpubplat/testsrc ./testsrc
move ./perpubplat_servlet/src/blog.hs ./servletsrc/perpubplat.hs
rmdir ./perpubplat
rmdir ./perpubplat_servlet/src
hunk ./perpubplat_servlet/LICENSE 1
-Copyright (c) 2008, Multfiarious, Inc.
-
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
-    * Redistributions of source code must retain the above copyright
-      notice, this list of conditions and the following disclaimer.
-
-    * Redistributions in binary form must reproduce the above
-      copyright notice, this list of conditions and the following
-      disclaimer in the documentation and/or other materials provided
-      with the distribution.
-
-    * Neither the name of the Multifarious, Inc. nor the names of its
-      contributors may be used to endorse or promote products derived
-      from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
-CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
-EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
rmfile ./perpubplat_servlet/LICENSE
hunk ./perpubplat_servlet/Setup.lhs 1
-#!/usr/bin/env runghc
-
-> module Main where
-> import Distribution.Simple
-
-> main :: IO ()
-> main = defaultMain
rmfile ./perpubplat_servlet/Setup.lhs
hunk ./perpubplat_servlet/perpubplat_servlet.cabal 1
-name:			PerpubplatFastCgiServlet
-version:		0.9
-copyright:		Copyright 2008 Multifarious, Inc.
-description:		Convert JSON exported from Typo into the internal perpubplat format.
-license:        	BSD3
-license-file:   	LICENSE
-author:			Paul Brown <prb@mult.ifario.us>
-homepage:		http://datapr0n.com/perpubplat
-maintainer:		Paul Brown <prb@mult.ifario.us>
-build-depends:		base >= 2.0, parsec >= 2.0, network >= 2.1, haskell98, containers,
-			fastcgi >= 3001.0.0, perpubplat >= 0.9, old-time >= 1.0, filepath >= 1.1,
-			directory >= 1.0, xhtml >= 3000.0.2.1,
-			bytestring >= 0.9
-executable:		perpubplat.fcgi
-main-is:		blog.hs
-hs-source-dirs:		src
-ghc-options:		-O2 -threaded -Werror -fwarn-unused-binds -fwarn-unused-imports -fwarn-unused-matches
rmfile ./perpubplat_servlet/perpubplat_servlet.cabal
rmdir ./perpubplat_servlet
hunk ./perpubplat.cabal 2
-version:		0.9
+version:		0.9.1
hunk ./perpubplat.cabal 16
-Library
+Executable perpubplat.fcgi
hunk ./perpubplat.cabal 20
-  old-locale >= 1.0, json >= 0.1, network >= 2.1
- exposed-modules:
-  Utilities,
-  Blog.Constants,
-  Blog.Model.Entry, Blog.Model.EntryParser, Blog.Model.CommentBodyParser,
-  Blog.Model.CommentForm, Blog.Model.CommentQueue
-  Blog.FrontEnd.ContentAtoms, Blog.FrontEnd.CommentEntry,
-  Blog.FrontEnd.Presentation, Blog.FrontEnd.Syndication,
-  Blog.FrontEnd.Routes, Blog.FrontEnd.Feeds, Blog.FrontEnd.Views,
-  Blog.FrontEnd.Actions, Blog.FrontEnd.Urls,
-  Blog.BackEnd.DataController, Blog.BackEnd.IoOperations,
-  Blog.BackEnd.ModelTransformations, Blog.BackEnd.HttpPoller,
-  Blog.BackEnd.ModelChangeListener,
-  Blog.Widgets.TagCloud, Blog.Widgets.FlickrCollage,
-  Blog.Widgets.ChromeBackEnd,
-  Blog.Admin.PendingComments,
-  Text.Atom
+  old-locale >= 1.0, json >= 0.1, network >= 2.1,
+  fastcgi >= 3001.0.0, bytestring >= 0.9
+ main-is:
+  perpubplat.hs
hunk ./perpubplat.cabal 25
-  src
+  src, servletsrc
hunk ./servletsrc/perpubplat.hs 1
--- blog.hs: servlet to run the blog.
+-- perpubplat.hs: servlet to run the blog.
addfile ./src/Blog/Widgets/Delicious.hs
hunk ./src/Blog/Widgets/Delicious.hs 1
+module Blog.Widgets.Delicious where
+
+import qualified Blog.Model.Entry as B
+import qualified Utilities as Ut
+
+import Network.HTTP
+import Network.URI
+import qualified Text.Json as J
+import qualified Codec.Binary.UTF8.String as UTF8
+import Data.Digest.MD5
+
+import qualified Text.ParserCombinators.Parsec as P
+import Control.Concurrent.MVar
+import Control.Concurrent.Chan
+import Control.Concurrent ( forkIO, myThreadId, ThreadId, threadDelay )
+import Data.ByteString.Lazy.Char8 ( pack )
+import qualified Data.Map as M
+import qualified Data.IntSet as S
+import Data.Maybe
+import qualified System.Posix as SP
+import qualified System.Posix.Time as SPT
+
+data DeliciousRecord = DeliciousRecord { hash :: String
+                                       , top_tags :: [(String,Int)]
+                                       , total_posts :: Int
+                                       , url :: String }
+                       deriving ( Show, Ord, Eq )
+
+
+data Scheduler = Scheduler { s_request_channel :: Chan SRequest
+                           , s_tid :: ThreadId
+                           , next_actions :: [(SP.EpochTime,Int)]
+                           , d_con :: DeliciousController
+                           , active :: S.IntSet }
+
+data SRequest = UpdateModel { model :: B.Model }
+              | Trigger { go_time :: SP.EpochTime }
+
+boot_s :: DeliciousController -> B.Model -> IO Scheduler
+boot_s dc m = do { c <- newChan
+                 ; e <- SPT.epochTime
+                 ; let n_a = zip 
+                             (map (\x -> e+(5*(fromIntegral x))) [1..(length $ B.all_posts m)])
+                             (map B.internal_id $ B.all_posts m)
+                 ; t <- myThreadId
+                 ; let s = Scheduler c t n_a dc S.empty
+                 ; tid <- forkIO $ s_loop s m
+                 ; return $ s { s_tid = tid } }
+
+data DeliciousController = DeliciousController { d_request_channel :: Chan DRequest
+                                               , dc_tid :: ThreadId }
+
+type DeliciousState = M.Map Int DeliciousRecord
+
+data DRequest = GetDRecord { callback :: MVar DeliciousRecord
+                           , item_id :: Int }
+              | PutDRecord { item_id :: Int
+                           , record :: DeliciousRecord }
+
+boot_dc :: IO DeliciousController
+boot_dc = do { c <- newChan
+             ; t <- myThreadId
+             ; let dc = DeliciousController c t
+             ; tid <- forkIO $ dc_loop dc M.empty
+             ; return $ dc { dc_tid = tid } }
+
+update_model :: Scheduler -> B.Model -> IO ()
+update_model s m = writeChan ( s_request_channel s ) $ UpdateModel m
+
+get_record :: DeliciousController -> Int -> IO DeliciousRecord
+get_record dc i = do { cb <- newEmptyMVar
+                     ; writeChan ( d_request_channel dc ) $ GetDRecord cb i
+                     ; takeMVar cb }
+
+put_record :: DeliciousController -> Int -> DeliciousRecord -> IO ()
+put_record dc i r = writeChan ( d_request_channel dc) $ PutDRecord i r 
+
+empty_record :: DeliciousRecord
+empty_record = DeliciousRecord "" [] 0 ""
+
+dc_loop :: DeliciousController -> DeliciousState -> IO ()
+dc_loop dc ds = do { req <- readChan $ d_request_channel dc
+                   ; case req of
+                       GetDRecord cb ii ->
+                           do { putMVar cb $ M.findWithDefault empty_record ii ds
+                              ; dc_loop dc ds }
+                       PutDRecord ii r ->
+                           dc_loop dc $ M.insert ii r ds
+                   }
+
+fire :: Scheduler -> IO ()
+fire s = do { e <- SPT.epochTime
+            ; writeChan (s_request_channel s) $ Trigger e }
+
+s_loop :: Scheduler -> B.Model -> IO ()
+s_loop s m = do { req <- readChan $ s_request_channel s
+                ; case req of
+                    UpdateModel m' ->
+                        do { s_loop s m'}
+                    Trigger t ->
+                        case (next_actions s) of
+                          ((t0,i):ts) | t0 < t ->
+                              do { t1 <- update_and_reschedule (d_con s) m i
+                                 ; let next_actions' = insert (t1,i) (drop 1 $ next_actions s) 
+                                 ; s_loop s { next_actions = next_actions'} m }
+                          _ ->
+                              do { threadDelay 1000000
+                                 ; s_loop s m }
+                }
+
+insert :: (Ord a) => a -> [a] -> [a]
+insert x xs = (fst p) ++ (x:(snd p))
+    where
+      p = span (\y -> y < x) xs
+
+update_and_reschedule :: DeliciousController -> B.Model -> Int -> IO SP.EpochTime
+update_and_reschedule dc m i = do { let item = B.item_by_id m i
+                                  ; age <- Ut.days_since $ B.created item
+                                  ; dr <- fetch_url_data $ B.permalink m item
+                                  ; print $ "Retrieved record " ++ (show dr)
+                                  ; put_record dc (B.internal_id item) dr
+                                  ; next_time age}
+
+next_time :: Int -> IO SP.EpochTime
+next_time t = do { n <- SPT.epochTime
+                 ; return $ n + 60 }
+
+url_fragment :: String
+url_fragment = "http://del.icio.us/feeds/json/url/data?hash="
+
+bookmarks_fragment :: String
+bookmarks_fragment = "http://del.icio.us/feeds/json/"
+
+request_for_bookmarks :: String -> Request
+request_for_bookmarks user = Request ( fromJust . parseURI $
+                                       bookmarks_fragment ++ user ++ "?raw" )
+                             GET [] ""
+
+request_for_url_data :: String -> Request
+request_for_url_data u = Request ( fromJust . parseURI $
+                                   url_fragment ++ (show . md5 . pack $ u ) )
+                         GET [] ""
+
+fetch_url_data :: String -> IO DeliciousRecord
+fetch_url_data url = do { res <- simpleHTTP . request_for_url_data $ url
+                        ; print $ "Loading data for " ++ url
+                        ; case res of
+                            Right res@(Response (2,0,0) _ _ body) ->
+                                return $ process_body body
+                        }
+
+process_body :: String -> DeliciousRecord
+process_body body =
+    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 "top_tags" $ uno o
+                                , url = uns $ M.findWithDefault blank "url" $ uno o
+                                , total_posts = unn $ M.findWithDefault zero "total_posts" $ uno o }
+
+parse_crufty_json :: String -> J.Value
+parse_crufty_json = parse_json . unescape . UTF8.decodeString
+    where
+      parse_json = \s -> case (P.parse J.json "" s) of
+                           Left err -> error . show $ err
+                           Right v -> v
+
+blank :: J.Value
+blank = J.String ""
+
+to_tag_list :: M.Map String J.Value -> [(String,Int)]
+to_tag_list m = map (\(s,n) -> (s, unn n)) $ M.toList m
+
+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
+
+unescape :: String -> String
+unescape s = unescape_ [] s
+
+unescape_ :: String -> String -> String
+unescape_ s [] = reverse s
+unescape_ t ('\\':'\'':ss) = unescape_ ('\'':t) ss
+unescape_ t (s:ss) = unescape_ (s:t) ss
hunk ./src/Utilities.hs 2
-                 , map_by, paginate, last_page ) where
+                 , map_by, paginate, last_page, days_since ) where
hunk ./src/Utilities.hs 4
+import qualified Data.Time.Calendar as C
hunk ./src/Utilities.hs 152
+days_since :: String -> IO Int
+days_since d = do { n <- now
+                  ; return . fromInteger $ C.diffDays (toDay n) (toDay d) }
+
+toDay :: String -> C.Day
+toDay ts = C.fromGregorian _y _m _d
+    where
+      _y = read . (take 4) $ ts
+      _m = read . (take 2) . (drop 5) $ ts
+      _d = read . (take 2) . (drop 8) $ ts
+
}