diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Network/Delicious.hs b/Network/Delicious.hs new file mode 100644 --- /dev/null +++ b/Network/Delicious.hs @@ -0,0 +1,26 @@ +-------------------------------------------------------------------- +-- | +-- Module : Network.Delicious +-- Copyright : (c) Galois, Inc. 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- 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 + diff --git a/Network/Delicious/Fetch.hs b/Network/Delicious/Fetch.hs new file mode 100644 --- /dev/null +++ b/Network/Delicious/Fetch.hs @@ -0,0 +1,49 @@ +-------------------------------------------------------------------- +-- | +-- Module : Network.Delicious.JSON +-- Copyright : (c) Galois, Inc. 2008 +-- License : BSD3 +-- +-- Maintainer : Sigbjorn Finne +-- 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 + + diff --git a/Network/Delicious/JSON.hs b/Network/Delicious/JSON.hs new file mode 100644 --- /dev/null +++ b/Network/Delicious/JSON.hs @@ -0,0 +1,320 @@ +-------------------------------------------------------------------- +-- | +-- Module : Network.Delicious.JSON +-- Copyright : (c) Galois, Inc. 2008 +-- License : BSD3 +-- +-- Maintainer : Sigbjorn Finne +-- Stability : provisional +-- Portability : portable +-- +-- Access del.icio.us JSON services. +-- +-- See 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 diff --git a/Network/Delicious/RSS.hs b/Network/Delicious/RSS.hs new file mode 100644 --- /dev/null +++ b/Network/Delicious/RSS.hs @@ -0,0 +1,222 @@ +-------------------------------------------------------------------- +-- | +-- Module : Network.Delicious.User +-- Copyright : (c) Galois, Inc. 2008 +-- License : BSD3 +-- +-- Maintainer : Sigbjorn Finne +-- 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)) + diff --git a/Network/Delicious/Types.hs b/Network/Delicious/Types.hs new file mode 100644 --- /dev/null +++ b/Network/Delicious/Types.hs @@ -0,0 +1,211 @@ +-------------------------------------------------------------------- +-- | +-- Module : Network.Delicious.Types +-- Copyright : (c) Galois, Inc. 2008 +-- License : BSD3 +-- +-- Maintainer : Sigbjorn Finne +-- 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) + + diff --git a/Network/Delicious/User.hs b/Network/Delicious/User.hs new file mode 100644 --- /dev/null +++ b/Network/Delicious/User.hs @@ -0,0 +1,248 @@ +-------------------------------------------------------------------- +-- | +-- Module : Network.Delicious.User +-- Copyright : (c) Galois, Inc. 2008 +-- License : BSD3 +-- +-- Maintainer : Sigbjorn Finne +-- 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) + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/delicious.cabal b/delicious.cabal new file mode 100644 --- /dev/null +++ b/delicious.cabal @@ -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 +maintainer: Sigbjorn Finne +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