delicious (empty) → 0.3.2
raw patch · 9 files changed
+1142/−0 lines, 9 filesdep +basedep +bytestringdep +curlsetup-changed
Dependencies added: base, bytestring, curl, feed, json, nano-md5, xml
Files
- LICENSE +27/−0
- Network/Delicious.hs +26/−0
- Network/Delicious/Fetch.hs +49/−0
- Network/Delicious/JSON.hs +320/−0
- Network/Delicious/RSS.hs +222/−0
- Network/Delicious/Types.hs +211/−0
- Network/Delicious/User.hs +248/−0
- Setup.lhs +3/−0
- delicious.cabal +36/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) Galois, Inc. 2007++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.
+ Network/Delicious.hs view
@@ -0,0 +1,26 @@+-------------------------------------------------------------------- +-- | +-- Module : Network.Delicious +-- Copyright : (c) Galois, Inc. 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne <sof@galois.com> +-- Stability : provisional +-- Portability: +-- +-- Binding to del.icio.us tagging system +-- + +module Network.Delicious + ( module Network.Delicious.Types + , module Network.Delicious.User + , module Network.Delicious.JSON + ) where + +import Network.Delicious.Types +import Network.Delicious.User +-- default is JSON; selectively import the RSS one +-- if you want to use it instead. +import Network.Delicious.JSON +--import Network.Delicious.RSS +
+ Network/Delicious/Fetch.hs view
@@ -0,0 +1,49 @@+--------------------------------------------------------------------+-- |+-- Module : Network.Delicious.JSON+-- Copyright : (c) Galois, Inc. 2008+-- License : BSD3+--+-- Maintainer : Sigbjorn Finne <sof@galois.com>+-- Stability : provisional+-- Portability : portable+--+-- Simple GET\/de-ref of URLs; abstracting out networking backend\/package.+--+module Network.Delicious.Fetch + ( readContentsURL+ , readUserContentsURL++ , URLString+ ) where+ +{-+ Note regarding HTTP libraries: the main reason for+ using Curl rather than HTTP is that del.icio.us uses+ HTTPS for parts of its API offerings. +-}+import Network.Curl+import Network.Delicious.Types++-- | @readContentsURL@ fetches the content from the given URL, @u@.+-- Via a standard, non-authenticated, @GET@.+readContentsURL :: URLString -> IO String+readContentsURL u = do+ let opts = [ CurlFollowLocation True+ ]+ (_,xs) <- curlGetString u opts+ return xs++-- | Like 'readContentsURL', but HTTP authenticated using the supplied+-- credentials.+readUserContentsURL :: User -> URLString -> IO String+readUserContentsURL u url = do+ let opts = [ CurlHttpAuth [HttpAuthAny]+ , CurlUserPwd (userName u ++ + case userPass u of {"" -> ""; p -> ':':p })+ , CurlFollowLocation True+ ]+ (_,xs) <- curlGetString url opts+ return xs+ +
+ Network/Delicious/JSON.hs view
@@ -0,0 +1,320 @@+--------------------------------------------------------------------+-- |+-- Module : Network.Delicious.JSON+-- Copyright : (c) Galois, Inc. 2008+-- License : BSD3+--+-- Maintainer : Sigbjorn Finne <sof@galois.com>+-- Stability : provisional+-- Portability : portable+--+-- Access del.icio.us JSON services.+--+-- See <http://del.icio.us/help/json/> for more details on the API.+--+-- "You can use JSON feeds at del.icio.us to fetch, remix, and mashup a+-- variety of data for use in your own custom applications and+-- browser-based presentation styles."+--+module Network.Delicious.JSON + ( getHotlist -- :: DM [Post]+ , getRecentBookmarks -- :: IO [Post]+ , getTagBookmarks -- :: Tag -> IO [Post]+ , getTagsBookmarks -- :: [Tag] -> IO [Post]+ , getPopularBookmarks -- :: IO [Post]+ , getTagPopularBookmarks -- :: Tag -> IO [Post]+ , getSiteAlerts -- :: IO [Post]+ , getUserBookmarks -- :: String -> IO [Post]+ , getUserTagBookmarks -- :: String -> Tag -> IO [Post]+ , getUserTaggedBookmarks -- :: String -> [Tag] -> IO [Post]+ , getUserInfo -- :: String -> IO [Post]+ , getUserPublicTags -- :: String -> IO [Post]+ , getUserSubscriptions -- :: String -> IO [Post]+ , getUserInboxBookmarks -- :: String -> String -> IO [Post]+ , getNetworkMemberBookmarks -- :: String -> IO [Post]+ , getNetworkMemberTaggedBookmarks -- :: String -> [Tag] -> IO [Post]+ , getNetworkMembers -- :: String -> IO [Post]+ , getNetworkFans -- :: String -> IO [Post]+ , getURLBookmarks -- :: URLString -> IO [Post]+ , getURLSummary -- :: URLString -> IO URLDetails+ , getURLDetails -- :: URLString -> IO URLDetails+ + , HtmlFeed(..)+ , baseHtmlFeed -- :: HtmlFeed+ , feed_html_url+ , getHtmlForTag -- :: HtmlFeed -> Maybe Tag -> IO {-Html-}String++ , URLDetails(..)+ ) where++import Text.JSON+import Text.JSON.Types++import Network.Delicious.Types++import Control.Monad+import Data.List+import Data.Ord+import Data.Char+import Data.Maybe+ +import Network.Delicious.Fetch ( readContentsURL )+import Data.ByteString ( pack )+import Data.Digest.OpenSSL.MD5 ++------------------------------------------------------------------------++-- | Retrieve tags associated with a url from delicious. +-- An example, extract the tags associated with 'xmonad':+--+-- > > getURLSummary "http://xmonad.org/"+-- >+-- > (URLDetails {total = 283+-- > ,tags = [("haskell",176)+-- > ,("windowmanager",133)+-- > ,("x11",126)+-- > ,("linux",116)+-- > ,("wm",74)+-- > ,("software",55)+-- > ,("gui",39)+-- > ,("desktop",26)+-- > ,("programming",25)+-- > ,("opensource",23)+-- > ,("xmonad",20)]+-- > }+--+getURLDetails :: String -> DM URLDetails+getURLDetails uarl = getURLSummary uarl++baseUrl :: String+baseUrl = "http://feeds.delicious.com/v2/json"++buildUrl :: (URLString -> IO a) -> URLString -> DM a+buildUrl f u = do+ mbc <- getCount+ liftIO (f (case mbc of { Nothing -> u ; Just c -> u++"?count="++show c}))++handleResult :: JSON a => String -> URLString -> DM a+handleResult loc u = do+ s <- buildUrl readContentsURL u+ case decodeStrict s of+ Ok e -> return e+ Error e -> liftIO $ ioError $ userError (loc ++ ':':' ':e)++------------------------------------------------------------------------++getHotlist :: DM [Post]+getHotlist = handleResult "getHotlist" baseUrl++getRecentBookmarks :: DM [Post]+getRecentBookmarks = handleResult "getRecentBookmarks" rec_url+ where rec_url = baseUrl ++ "/recent"++getTagBookmarks :: Tag -> DM [Post]+getTagBookmarks tg = handleResult "getTagBookmarks" eff_url+ where eff_url = baseUrl ++ "/tag/" ++ tg++getTagsBookmarks :: [Tag] -> DM [Post]+getTagsBookmarks tgs = handleResult "getTagsBookmarks" eff_url+ where eff_url = baseUrl ++ "/tag/" ++ concat (intersperse "+" tgs)++getPopularBookmarks :: DM [Post]+getPopularBookmarks = handleResult "getPopularBookmarks" eff_url+ where eff_url = baseUrl ++ "/popular"++getTagPopularBookmarks :: Tag -> DM [Post]+getTagPopularBookmarks tg = handleResult "getTagPopularBookmarks" eff_url+ where eff_url = baseUrl ++ "/popular/" ++ tg++getSiteAlerts :: DM [Post]+getSiteAlerts = handleResult "getSiteAlerts" eff_url+ where eff_url = baseUrl ++ "/alerts"++getUserBookmarks :: String -> DM [Post]+getUserBookmarks usr = handleResult "getUserBookmarks" eff_url+ where eff_url = baseUrl ++ '/':usr++getUserTagBookmarks :: String -> Tag -> DM [Post]+getUserTagBookmarks usr tg = handleResult "getUserTagBookmarks" eff_url+ where eff_url = baseUrl ++ '/':usr++'/':tg++getUserTaggedBookmarks :: String -> [Tag] -> DM [Post]+getUserTaggedBookmarks usr tgs = handleResult "getUserTaggedBookmarks" eff_url+ where eff_url = baseUrl ++ '/':usr++'/':concat (intersperse "+" tgs)++getUserInfo :: String -> DM [Post]+getUserInfo usr = handleResult "getUserInfo" eff_url+ where eff_url = baseUrl ++ "/userinfo/" ++ usr++getUserPublicTags :: String -> DM [Post]+getUserPublicTags usr = handleResult "getUserPublicTags" eff_url+ where eff_url = baseUrl ++ "/tags/" ++ usr+++getUserSubscriptions :: String -> DM [Post]+getUserSubscriptions usr = handleResult "getUserSubscriptions" eff_url+ where eff_url = baseUrl ++ "/subscriptions/" ++ usr++getUserInboxBookmarks :: String -> String -> DM [Post]+getUserInboxBookmarks usr k = handleResult "getUserInboxBookmarks" eff_url+ where eff_url = baseUrl ++ "/inbox/" ++ usr ++ "?private="++k++getNetworkMemberBookmarks :: String -> DM [Post]+getNetworkMemberBookmarks usr = handleResult "getNetworkMemberBookmarks" eff_url+ where eff_url = baseUrl ++ "/network/" ++ usr++getNetworkMemberTaggedBookmarks :: String -> [Tag] -> DM [Post]+getNetworkMemberTaggedBookmarks usr tgs = + handleResult "getNetworkMemberTaggedBookmarks" eff_url+ where eff_url = baseUrl ++ "/network/" ++ usr ++ '/':concat (intersperse "+" tgs)+++getNetworkMembers :: String -> DM [Post]+getNetworkMembers usr = handleResult "getNetworkMembers" eff_url+ where eff_url = baseUrl ++ "/networkmembers/" ++ usr++getNetworkFans :: String -> DM [Post]+getNetworkFans usr = handleResult "getNetworkFans" eff_url+ where eff_url = baseUrl ++ "/networkfans/" ++ usr++getURLBookmarks :: URLString -> DM [Post]+getURLBookmarks turl = handleResult "getURLBookmarks" eff_url+ where eff_url = baseUrl ++ "/url/" ++ hashUrl turl++getURLSummary :: URLString -> DM URLDetails+getURLSummary turl = handleResult "getURLSummary" eff_url+ where eff_url = baseUrl ++ "/urlinfo/" ++ hashUrl turl++hashUrl :: URLString -> String+hashUrl s = md5sum (pack (map (fromIntegral.fromEnum) s))++------------------------------------------------------------------------++-- | A structure represening the the delicious tags associated with a url.+data URLDetails =+ URLDetails { total :: !Integer+ , tags :: [(String,Integer)]+ , hash :: String {-MD5-}+ , url :: String {-URL-}+ }+ deriving (Eq,Show,Read)++nullURLDetails :: URLDetails+nullURLDetails = + URLDetails { total = 0+ , tags = []+ , hash = ""+ , url = ""+ }++-- | Compose and decompose URLDetails as JSON in the form delicious uses.+instance JSON URLDetails where+ showJSON ud = JSObject $ toJSObject+ [ ("hash", showJSON (JSONString (hash ud)))+ , ("total_posts", showJSON (total ud))+ , ("top_tags", JSObject $ toJSObject+ [(x,showJSON y) | (x,y) <- tags ud ])+ , ("url", showJSON (JSONString (url ud)))+ ]++ readJSON (JSArray []) = return nullURLDetails+ readJSON (JSArray [x]) = readJSON x+ readJSON (JSObject (JSONObject pairs))+ = do the_tags <- case lookup "top_tags" pairs of+ Nothing -> fail "Network.Delicious.JSON: Missing JSON field: top_tags"+ Just (JSObject (JSONObject obj)) ->+ liftM (reverse . sortBy (comparing snd)) $+ mapM (\(x,y) -> readJSON y >>= \y' -> return (x,y')) obj+ Just x -> + fail ("Network.Delicious.JSON: Unexpected JSON value for 'top_tags': " ++ show x)++ the_total <- case lookup "total_posts" pairs of+ Nothing -> fail "Network.Delicious.JSON: Missing JSON field: total_posts"+ Just n -> readJSON n++ the_url <- case lookup "url" pairs of+ Nothing -> fail "Network.Delicious.JSON: Missing JSON field: url"+ Just n -> readJSON n++ hsh <- readJSON (fromMaybe JSNull (lookup "hash" pairs))+ return $+ URLDetails { total = the_total+ , url = the_url+ , tags = the_tags+ , hash = hsh+ }++ readJSON s = fail ("Network.Delicious.JSON: url details malformed: "++ show s)++data HtmlFeed+ = HtmlFeed+ { hf_delUrl :: Maybe {-URL-}String+ , hf_extended :: Bool+ , hf_divClass :: Maybe String+ , hf_aClass :: Maybe String+ , hf_showTags :: Bool+ , hf_tagClass :: Maybe String+ , hf_tagSep :: Maybe String+ , hf_tagSepClass :: Maybe String+ , hf_bulletEnt :: Maybe String+ , hf_withFeedButton :: Maybe Bool+ , hf_extendedInDiv :: Maybe Bool+ , hf_extendedClass :: Maybe String+ }++baseHtmlFeed :: HtmlFeed+baseHtmlFeed = HtmlFeed+ { hf_delUrl = Nothing+ , hf_extended = False+ , hf_divClass = Nothing+ , hf_aClass = Nothing+ , hf_showTags = True+ , hf_tagClass = Nothing+ , hf_tagSep = Nothing+ , hf_tagSepClass = Nothing+ , hf_bulletEnt = Nothing+ , hf_withFeedButton = Nothing+ , hf_extendedInDiv = Nothing+ , hf_extendedClass = Nothing+ }+ +feed_html_url :: {-URL-}String+feed_html_url = "http://feeds.delicious.com/html"++getHtmlForTag :: HtmlFeed+ -> Maybe Tag+ -> DM {-Html-}String+getHtmlForTag hf mbTg = do+ u <- getUser+ c <- getCount+ let partial_url = build_query u c+ let base_url = fromMaybe feed_html_url (hf_delUrl hf)+ let eff_url = base_url ++ partial_url+ liftIO $ readContentsURL eff_url+ where+ build_query u c = consSlash (userName u) ++ (fromMaybe "" (fmap consSlash mbTg)) ++ '?':opts+ where+ opts = concat $ intersperse "&" $ catMaybes+ [ "count" -==> fmap show c+ , "extended" -=> toB (hf_extended hf) "title" "body"+ , "divclass" -==> hf_divClass hf+ , "aclass" -==> hf_aClass hf+ , "tags" -=> toB (hf_showTags hf) "no" "yes"+ , "tagclass" -==> hf_tagClass hf+ , "tagsep" -==> hf_tagSep hf+ , "tagsepclass" -==> hf_tagSepClass hf+ , "bullet" -==> hf_bulletEnt hf+ , "rssbutton" -==> fmap (\ x -> toB x "no" "yes") (hf_withFeedButton hf)+ , "extendeddiv" -==> fmap (\ x -> toB x "no" "yes") (hf_extendedInDiv hf)+ , "extendedclass" -==> hf_extendedClass hf+ ]+ + consSlash "" = ""+ consSlash xs = '/':xs++ (-==>) _ Nothing = Nothing+ (-==>) a (Just b) = Just (a ++ '=':b)+ (-=>) a b = Just (a ++ '=':b)+ + toB False a _ = a+ toB _ _ b = b
+ Network/Delicious/RSS.hs view
@@ -0,0 +1,222 @@+--------------------------------------------------------------------+-- |+-- Module : Network.Delicious.User+-- Copyright : (c) Galois, Inc. 2008+-- License : BSD3+--+-- Maintainer : Sigbjorn Finne <sof@galois.com>+-- Stability : provisional+-- Portability : portable+--+--------------------------------------------------------------------+module Network.Delicious.RSS+ ( getHotlist -- :: DM [Post]+ , getRecentBookmarks -- :: DM [Post]+ , getTagBookmarks -- :: Tag -> DM [Post]+ , getTagsBookmarks -- :: [Tag] -> DM [Post]+ , getPopularBookmarks -- :: DM [Post]+ , getTagPopularBookmarks -- :: Tag -> DM [Post]+ , getSiteAlerts -- :: DM [Post]+ , getUserBookmarks -- :: String -> DM [Post]+ , getUserTagBookmarks -- :: String -> Tag -> DM [Post]+ , getUserTaggedBookmarks -- :: String -> [Tag] -> DM [Post]+ , getUserInfo -- :: String -> DM [Post]+ , getUserPublicTags -- :: String -> DM [Post]+ , getUserSubscriptions -- :: String -> DM [Post]+ , getUserInboxBookmarks -- :: String -> String -> DM [Post]+ , getNetworkMemberBookmarks -- :: String -> DM [Post]+ , getNetworkMemberTaggedBookmarks -- :: String -> [Tag] -> DM [Post]+ , getNetworkMembers -- :: String -> DM [Post]+ , getNetworkFans -- :: String -> DM [Post]+ , getURLBookmarks -- :: URLString -> DM [Post]+{-+ , getURLSummary -- :: URLString -> DM [Post]+-}+ ) where++import Network.Delicious.Types+import Network.Delicious.Fetch++import Text.Feed.Query+import Text.Feed.Types+import Text.Feed.Import++import Data.Maybe+import Data.List ( intercalate )++import Network.Curl+import Data.ByteString ( pack )+import Data.Digest.OpenSSL.MD5 ++-- ToDo:+-- * support for 'count' parameter+-- * plain/fancy++deli_base :: URLString+deli_base = "http://feeds.delicious.com/v2"++hotlist_url :: {-URL-}String+hotlist_url = deli_base ++ "/rss/"++recent_url :: {-URL-}String+recent_url = deli_base ++ "/rss/recent"++popular_url :: {-URL-}String+popular_url = deli_base ++ "/rss/popular"++user_url :: {-URL-}String+user_url = deli_base ++ "/rss/"++alert_url :: {-URL-}String+alert_url = deli_base ++ "/rss/alerts"++tag_url :: {-URL-}String+tag_url = deli_base ++ "/rss/tag/"++tags_url :: {-URL-}String+tags_url = deli_base ++ "/rss/tags/"++inbox_url :: {-URL-}String+inbox_url = deli_base ++ "/rss/inbox/"++network_url :: {-URL-}String+network_url = deli_base ++ "/rss/network/"++network_mem_url :: {-URL-}String+network_mem_url = deli_base ++ "/rss/networkmembers/"++network_fans_url :: {-URL-}String+network_fans_url = deli_base ++ "/rss/networkfans/"++b_url_url :: {-URL-}String+b_url_url = deli_base ++ "/rss/url/"++{- UNUSED:+b_urlinfo_url :: {-URL-}String+b_urlinfo_url = deli_base ++ "/rss/urlinfo/"+-}++buildUrl :: (URLString -> IO a) -> URLString -> DM a+buildUrl f u = do+ mbc <- getCount+ liftIO (f (case mbc of { Nothing -> u ; Just c -> u++"?count="++show c}))++performCall :: String -> URLString -> DM [Post]+performCall loc u = do+ ls <- buildUrl readContentsURL u+ case parseFeedString ls of+ Nothing -> fail (loc ++ " invalid RSS feed")+ Just f -> return (map toPost (feedItems f))++--++getHotlist :: DM [Post]+getHotlist = performCall "getHotlist" hotlist_url++getRecentBookmarks :: DM [Post]+getRecentBookmarks = performCall "getRecentBookmarks" recent_url++getTagBookmarks :: Tag -> DM [Post]+getTagBookmarks tg = performCall "getTagBookmarks" eff_url+ where+ eff_url = tag_url ++ tg++getTagsBookmarks :: [Tag] -> DM [Post]+getTagsBookmarks tgs = performCall "getTagsBookmarks" eff_url+ where+ eff_url = tag_url ++ intercalate "+" tgs++getPopularBookmarks :: DM [Post]+getPopularBookmarks = performCall "getPopularBookmarks" popular_url++getTagPopularBookmarks :: Tag -> DM [Post]+getTagPopularBookmarks tg = performCall "getTagPopularBookmarks" eff_url+ where+ eff_url = popular_url ++ '/':tg++getSiteAlerts :: DM [Post]+getSiteAlerts = performCall "getSiteAlerts" alert_url++getUserBookmarks :: String -> DM [Post]+getUserBookmarks u = performCall "getUserBookmarks" eff_url+ where+ eff_url = user_url ++ u++getUserTagBookmarks :: String -> Tag -> DM [Post]+getUserTagBookmarks u tg = performCall "getUserTagBookmarks" eff_url+ where+ eff_url = user_url ++ u ++ '/':tg++getUserTaggedBookmarks :: String -> [Tag] -> DM [Post]+getUserTaggedBookmarks u tgs = performCall "getUserTaggedBookmarks" eff_url+ where+ eff_url = user_url ++ u ++ '/':intercalate "+" tgs++getUserInfo :: String -> DM [Post]+getUserInfo u = performCall "getUserInfo" eff_url+ where+ eff_url = user_url ++ "userinfo/" ++ u++getUserPublicTags :: String -> DM [Post]+getUserPublicTags u = performCall "getUserPublicTags" eff_url+ where+ eff_url = tags_url ++ u++getUserSubscriptions :: String -> DM [Post]+getUserSubscriptions u = performCall "getUserSubscriptions" eff_url+ where+ eff_url = user_url ++ "subscriptions/" ++ u++getUserInboxBookmarks :: String -> String -> DM [Post]+getUserInboxBookmarks u key = performCall "getUserInboxBookmarks" eff_url+ where+ eff_url = inbox_url ++ u ++ "?private="++key++getNetworkMemberBookmarks :: String -> DM [Post]+getNetworkMemberBookmarks u = performCall "getNetworkMemberBookmarks" eff_url+ where+ eff_url = network_url ++ u++getNetworkMemberTaggedBookmarks :: String -> [Tag] -> DM [Post]+getNetworkMemberTaggedBookmarks u tgs = + performCall "getNetworkMemberTaggedBookmarks" eff_url+ where+ eff_url = network_url ++ u ++ '/':intercalate "+" tgs++getNetworkMembers :: String -> DM [Post]+getNetworkMembers u = performCall "getNetworkMembers" eff_url+ where+ eff_url = network_mem_url ++ u++getNetworkFans :: String -> DM [Post]+getNetworkFans u = performCall "getNetworkFans" eff_url+ where+ eff_url = network_fans_url ++ u++getURLBookmarks :: URLString -> DM [Post]+getURLBookmarks url = performCall "getURLBookmarks" eff_url+ where+ eff_url = b_url_url ++ hashUrl url++{- Not on offer for RSS backend:+getURLSummary :: URLString -> DM [Post]+getURLSummary url = do+ ls <- buildUrl readContentsURL (b_urlinfo_url ++ hashUrl url)+ case parseFeedString ls of+ Nothing -> fail ("getURLSummary: invalid RSS feed")+ Just f -> return (map toPost (feedItems f))+-}++toPost :: Item -> Post+toPost i = + nullPost+ { postHref = fromMaybe "" (getItemLink i)+ , postDesc = fromMaybe "" (getItemTitle i)+ , postUser = fromMaybe "" (getItemAuthor i)+ , postTags = getItemCategories i+ , postStamp = fromMaybe "" (getItemPublishDate i)+ }++hashUrl :: URLString -> String+hashUrl s = md5sum (pack (map (fromIntegral.fromEnum) s))+
+ Network/Delicious/Types.hs view
@@ -0,0 +1,211 @@+--------------------------------------------------------------------+-- |+-- Module : Network.Delicious.Types+-- Copyright : (c) Galois, Inc. 2008+-- License : BSD3+--+-- Maintainer : Sigbjorn Finne <sof@galois.com>+-- Stability : provisional+-- Portability : portable+--+-- Types and data structures used by the Delicious API binding.+-- +--------------------------------------------------------------------+++module Network.Delicious.Types + ( DateString+ , TimeString+ , URLString++ , User(..)+ , nullUser+ + , DM+ , catchDM -- :: DM a -> (IOError -> DM a) -> DM a+ , withUser -- :: User -> DM a -> DM a+ , withCount -- :: Int -> DM a -> DM a+ , getUser -- :: DM User+ , getBase -- :: DM URLString+ , getCount -- :: DM (Maybe Int)++ , liftIO -- :: IO a -> DM a+ , runDelic -- :: User -> URLString -> DM a -> IO a+ , runDM -- :: User -> DM a -> IO a+ + , Tag+ , TagInfo(..)+ , Bundle(..)++ , Filter(..)+ , nullFilter+ + , Post(..)+ , nullPost+ + ) where++import Network.Curl.Types ( URLString )+import Data.Maybe ( catMaybes )++import Text.JSON.Types+import Text.JSON+++type DateString = String+type TimeString = String -- 8601++data DMEnv+ = DMEnv+ { dmUser :: User+ , dmBase :: URLString+ , dmCount :: Maybe Int+ }++data User+ = User+ { userName :: String+ , userPass :: String+ } deriving ( Show )++nullUser :: User+nullUser+ = User { userName = ""+ , userPass = ""+ }++newtype DM a = DM {unDM :: DMEnv -> IO a}++instance Monad DM where+ return x = DM $ \ _ -> return x+ m >>= k = DM $ \ env -> do+ v <- unDM m env+ unDM (k v) env++catchDM :: DM a -> (IOError -> DM a) -> DM a+catchDM (DM m) h = DM $ \ env -> catch (m env) (\err -> unDM (h err) env)++withUser :: User -> DM a -> DM a+withUser u k = DM $ \ env -> (unDM k) env{dmUser=u}++withCount :: Int -> DM a -> DM a+withCount c k = DM $ \ env -> (unDM k) env{dmCount=Just c}++getUser :: DM User+getUser = DM $ \ env -> return (dmUser env)++getCount :: DM (Maybe Int)+getCount = DM $ \ env -> return (dmCount env)++getBase :: DM URLString+getBase = DM $ \ env -> return (dmBase env)++liftIO :: IO a -> DM a+liftIO a = DM $ \ _ -> a++runDelic :: User -> URLString -> DM a -> IO a+runDelic u b dm = (unDM dm) DMEnv{dmUser=u,dmBase=b,dmCount=Nothing}++del_base :: URLString+del_base = "https://api.del.icio.us/v1"++runDM :: User -> DM a -> IO a+runDM user a = runDelic user del_base a++-- ++type Tag = String++data TagInfo+ = TagInfo+ { tagName :: Tag+ , tagUses :: Integer+ } deriving ( Show )++data Bundle+ = Bundle+ { bundleName :: String+ , bundleTags :: [Tag]+ } deriving ( Show )++data Filter+ = Filter+ { filterTag :: Maybe Tag -- it looks as if no more than one can be given+ , filterDate :: Maybe DateString+ , filterURL :: Maybe URLString+ , filterCount :: Maybe Integer+ } deriving ( Show )++nullFilter :: Filter+nullFilter =+ Filter{ filterTag = Nothing+ , filterDate = Nothing+ , filterURL = Nothing+ , filterCount = Nothing+ }++data Post+ = Post+ { postHref :: URLString+ , postUser :: String+ , postDesc :: String+ , postNotes :: String+ , postTags :: [Tag]+ , postStamp :: DateString+ , postHash :: String+ } deriving ( Show )++nullPost :: Post+nullPost = Post+ { postHref = ""+ , postUser = ""+ , postDesc = ""+ , postNotes = ""+ , postTags = []+ , postStamp = ""+ , postHash = ""+ }+++instance JSON Post where+ showJSON p = JSObject $ toJSObject $ catMaybes+ [ Just ("u", showJSON (JSONString (postHref p)))+ , mb "d" (showJSON.JSONString) (postDesc p)+ , mb "n" (showJSON.JSONString) (postNotes p)+ , mb "dt" (showJSON.JSONString) (postStamp p)+ , Just ("t", JSArray (map (showJSON.JSONString) (postTags p)))+ ]+ where+ mb _ _ "" = Nothing+ mb t f xs = Just (t, f xs)++ readJSON (JSArray []) = return nullPost+ readJSON (JSArray [x]) = readJSON x+ readJSON (JSObject (JSONObject pairs))+ = do tgs <- case lookup "t" pairs of+ Just n -> readJSON n+ Nothing -> return []+ ur <- case lookup "u" pairs of+ Nothing -> fail "Network.Delicious.JSON: Missing required JSON field: url"+ Just n -> readJSON n++ notes <- case lookup "n" pairs of+ Nothing -> return ""+ Just n -> readJSON n+ desc <- case lookup "d" pairs of+ Nothing -> return ""+ Just n -> readJSON n+ ts <- case lookup "dt" pairs of+ Nothing -> return ""+ Just n -> readJSON n++ return $ nullPost{ postHref=ur+ , postDesc=desc+ , postNotes=notes+ , postTags=tgs+ , postStamp=ts+ }++ readJSON s = fail ("Network.Delicious.JSON: malformed post: "++ show s)++
+ Network/Delicious/User.hs view
@@ -0,0 +1,248 @@+--------------------------------------------------------------------+-- |+-- Module : Network.Delicious.User+-- Copyright : (c) Galois, Inc. 2008+-- License : BSD3+--+-- Maintainer : Sigbjorn Finne <sof@galois.com>+-- Stability : provisional+-- Portability : portable+--+-- Accessing a user's tags and bookmarks+--+--------------------------------------------------------------------+module Network.Delicious.User+ ( getLastUpdate -- :: DM TimeString++ , getTags -- :: DM [TagInfo]+ , renameTag -- :: Tag -> Tag -> DM ()+ , deleteTag -- :: Tag -> DM ()+ , getPosts -- :: Filter -> DM [Post]++ , getRecent -- :: Maybe Tag -> Maybe Integer -> DM [Post]+ , getAll -- :: Maybe Tag -> DM [Post]+ , getAllHashes -- :: DM [Post]+ , getByDate -- :: Maybe Tag -> DM [(DateString,Integer)]++ , addPost -- :: Post -> Bool -> Bool -> DM ()+ , deletePost -- :: URLString -> DM ()++ , getBundles -- :: DM [Bundle]+ , setBundle -- :: String -> [Tag] -> DM ()+ , deleteBundle -- :: String -> IO ()++ , restReq+ ) where++import Network.Delicious.Types+import Network.Delicious.Fetch+++import Control.Monad+import Data.List+import Data.Maybe++import Text.XML.Light as XML hiding ( findAttr )++--+restReq :: String -> [(String,String)] -> DM (Either XML.Element String)+restReq cmd opts = do+ b <- getBase+ u <- getUser+ let effUrl = b ++ '/':cmd ++ tlOpts opts+ xs <- liftIO $ readUserContentsURL u effUrl+ return (fromMaybe (Right xs) $ fmap Left $ parseXMLDoc xs)+ where+ tlOpts [] = ""+ tlOpts xs = '?':concat (intersperse "&" (map (\ (x,y) -> x ++ '=':y) xs))++--++getLastUpdate :: DM TimeString+getLastUpdate = do+ pl <- restReq "posts/update" []+ case pl of+ Right x -> fail ("getLastUpdate: no parse -- " ++ x)+ Left d ->+ case find (\ (Attr a _) -> qName a == "time") (elAttribs d) of+ Just (Attr _ v) -> return v+ Nothing -> fail (show pl)++getTags :: DM [TagInfo]+getTags = do+ pl <- restReq "tags/get" []+ case pl of+ Right x -> fail ("getTags: no parse -- " ++ x)+ Left d ->+ case qName $ elName d of+ "tags" -> return (map eltToTag $ findElements (unqual "tag") d)+ _ -> fail ("getTags: unexpected return payload " ++ show d)+ where+ eltToTag e =+ TagInfo+ { tagName = findAttr "tag" "" e+ , tagUses = readInt 0 $ findAttr "count" "0" e+ }++readInt :: Integer -> String -> Integer+readInt d xs =+ case reads xs of+ ((x,_):_) -> x+ _ -> d++findAttr :: String -> String -> Element -> String+findAttr n d e =+ fromMaybe d $+ fmap (\ (Attr _ v) -> v) $+ find (\ (Attr a _) -> qName a == n) (elAttribs e)++renameTag :: Tag -> Tag -> DM ()+renameTag ot nt = do+ pl <- restReq "tags/rename" [("old",ot),("new", nt)]+ case pl of+ Right x -> fail ("renameTag: ill-formed return value -- " ++ x)+ Left d ->+ case qName $ elName d of+ "result" | strContent d == "done" -> return ()+ _ -> fail ("renameTag: unexpected return value " ++ show d)++deleteTag :: Tag -> DM ()+deleteTag dt = do+ pl <- restReq "tags/delete" [("tag",dt)]+ case pl of+ Right x -> fail ("deleteTag: ill-formed return value -- " ++ x)+ Left d ->+ case qName $ elName d of+ "result" | strContent d == "done" -> return ()+ _ -> fail ("deleteTag: unexpected return value " ++ show d)+++getPosts :: Filter -> DM [Post]+getPosts f = getPosts' "getPosts" "posts/get" f++getPosts' :: String -> String -> Filter -> DM [Post]+getPosts' loc r f = do+ pl <- restReq r (toFilterArgs f)+ case pl of+ Right x -> fail (loc ++ ": ill-formed return value -- " ++ x)+ Left d ->+ case qName $ elName d of+ "posts" -> return (map eltToPost $ findElements (unqual "post") d)+ _ -> fail (loc ++ ": unexpected return payload " ++ show d)+ where+ eltToPost e = Post+ { postHref = findAttr "href" "" e+ , postDesc = findAttr "description" "" e+ , postUser = findAttr "user" "" e+ , postNotes = findAttr "extended" "" e+ , postTags = words $ findAttr "tag" "" e+ , postStamp = findAttr "time" "" e+ , postHash = findAttr "hash" "" e+ }++toFilterArgs :: Filter -> [(String,String)]+toFilterArgs f =+ mb "tag" (filterTag f) $+ mb "dt" (filterDate f) $+ mb "url" (filterURL f) []++mb :: a -> Maybe b -> [(a,b)] -> [(a,b)]+mb _ Nothing xs = xs+mb t (Just v) xs = (t,v):xs++getRecent :: Maybe Tag -> Maybe Integer -> DM [Post]+getRecent mbTg mbCount =+ getPosts' "getRecent" "posts/recent"+ nullFilter{filterTag=mbTg,filterCount=mbCount}++getAll :: Maybe Tag -> DM [Post]+getAll mbTg = getPosts' "getAll" "posts/all" nullFilter{filterTag=mbTg}++getAllHashes :: DM [Post]+getAllHashes = getPosts' "getAll" "posts/all?hashes" nullFilter++getByDate :: Maybe Tag -> DM [(DateString,Integer)]+getByDate mbTg = do+ pl <- restReq "posts/dates" (toFilterArgs nullFilter{filterTag=mbTg})+ case pl of+ Right x -> fail ("getByDate: no parse -- " ++ x)+ Left d ->+ case qName $ elName d of+ "dates" -> return (map eltToDate $ findElements (unqual "date") d)+ _ -> fail ("getByDate: unexpected return payload " ++ show d)+ where+ eltToDate e =+ ( findAttr "date" "" e+ , readInt 0 $ findAttr "count" "0" e+ )++addPost :: Post -> Bool -> Bool -> DM ()+addPost ps replace shared = do+ pl <- restReq "posts/add" (toPostArgs ps)+ case pl of+ Right x -> fail ("addPost: ill-formed return value -- " ++ x)+ Left d ->+ case qName $ elName d of+ "result"+ | findAttr "code" "" d == "done" -> return ()+ _ -> fail ("addPost: unexpected return payload " ++ show d)+ where+ toPostArgs p =+ mb "url" (l2m $ postHref p) $+ mb "description" (l2m $ postDesc p) $+ mb "extended" (l2m $ postNotes p) $+ mb "tags" (l2m $ unwords $ postTags p) $+ mb "dt" (l2m $ postStamp p) $+ mb "replace" (if replace then Just "yes" else Just "no") $+ mb "shared" (if shared then Just "yes" else Just "no")+ []+ l2m "" = Nothing+ l2m xs = Just xs++deletePost :: URLString -> DM ()+deletePost u = do+ pl <- restReq "posts/delete" [("url", u)]+ case pl of+ Right x -> fail ("deletePost: ill-formed return value -- " ++ x)+ Left d -> + case qName $ elName d of+ "result" + | findAttr "code" "" d == "done" -> return ()+ _ -> fail ("deletePost: unexpected return payload " ++ show d)++getBundles :: DM [Bundle]+getBundles = do+ pl <- restReq "tags/bundles/all" []+ case pl of+ Right x -> fail ("getBundles: ill-formed return value -- " ++ x)+ Left d ->+ case qName $ elName d of+ "bundles" -> return (map eltToBundle $ findElements (unqual "bundle") d)+ _ -> fail ("getBundles: unexpected return payload " ++ show d)+ where+ eltToBundle e = + Bundle+ { bundleName = findAttr "name" "" e+ , bundleTags = words $ findAttr "tag" "" e+ }++setBundle :: String -> [Tag] -> DM ()+setBundle nm tgs = do+ pl <- restReq "tags/bundles/set" [("bundle",nm),("tags", unwords tgs)] + case pl of+ Right x -> fail ("setBundle: ill-formed return value -- " ++ x)+ Left d -> + case qName $ elName d of+ "result" | strContent d == "ok" -> return ()+ _ -> fail ("setBundle: unexpected return value " ++ show d)++deleteBundle :: String -> DM ()+deleteBundle nm = do+ pl <- restReq "tags/bundles/delete" [("bundle",nm)]+ case pl of+ Right x -> fail ("deleteBundle: ill-formed return value -- " ++ x)+ Left d -> + case qName $ elName d of+ "result" | strContent d == "done" -> return ()+ _ -> fail ("deleteBundle: unexpected return value " ++ show d)+
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ delicious.cabal view
@@ -0,0 +1,36 @@+name: delicious+version: 0.3.2+homepage: http://galois.com+synopsis: Accessing the del.icio.us APIs from Haskell (v2)+description: Access to the del.icio.us social tagging site's API(v2) from Haskell+category: Web+license: BSD3+license-file: LICENSE+author: Sigbjorn Finne <sof@galois.com>+maintainer: Sigbjorn Finne <sof@galois.com>+copyright: (c) 2008 Galois, Inc.+cabal-version: >= 1.2+build-type: Simple++library+ exposed-modules: + Network.Delicious.Types,+ Network.Delicious.User,+ Network.Delicious.RSS,+ Network.Delicious.JSON,+ Network.Delicious.Fetch,+ Network.Delicious+++ build-depends: base,+ xml >= 1.2.6,+ feed >= 0.3.1,+ curl >= 1.1,+ bytestring,+ nano-md5,+ json >= 0.3.3++ ghc-options: -Wall++-- Executable: dtest+-- Main-is: Main.hs