diff --git a/Network/Delicious.hs b/Network/Delicious.hs --- a/Network/Delicious.hs +++ b/Network/Delicious.hs @@ -1,10 +1,10 @@ -------------------------------------------------------------------- -- | -- Module : Network.Delicious --- Copyright : (c) Galois, Inc. 2008 +-- Copyright : (c) Sigbjorn Finne, 2008- -- License : BSD3 -- --- Maintainer: Sigbjorn Finne +-- Maintainer: Sigbjorn Finne -- Stability : provisional -- Portability: -- diff --git a/Network/Delicious/Fetch.hs b/Network/Delicious/Fetch.hs --- a/Network/Delicious/Fetch.hs +++ b/Network/Delicious/Fetch.hs @@ -4,7 +4,7 @@ -- Copyright : (c) Galois, Inc. 2008 -- License : BSD3 -- --- Maintainer : Sigbjorn Finne +-- Maintainer : Sigbjorn Finne -- Stability : provisional -- Portability : portable -- @@ -27,21 +27,23 @@ -- | @readContentsURL@ fetches the content from the given URL, @u@. -- Via a standard, non-authenticated, @GET@. -readContentsURL :: URLString -> IO String -readContentsURL u = do +readContentsURL :: String -> URLString -> IO String +readContentsURL ua u = do let opts = [ CurlFollowLocation True + , CurlUserAgent ua ] (_,xs) <- curlGetString u opts return xs -- | Like 'readContentsURL', but HTTP authenticated using the supplied -- credentials. -readUserContentsURL :: User -> URLString -> IO String -readUserContentsURL u url = do +readUserContentsURL :: User -> String -> URLString -> IO String +readUserContentsURL u ua url = do let opts = [ CurlHttpAuth [HttpAuthAny] , CurlUserPwd (userName u ++ case userPass u of {"" -> ""; p -> ':':p }) , CurlFollowLocation True + , CurlUserAgent ua ] (_,xs) <- curlGetString url opts return xs diff --git a/Network/Delicious/JSON.hs b/Network/Delicious/JSON.hs --- a/Network/Delicious/JSON.hs +++ b/Network/Delicious/JSON.hs @@ -4,7 +4,7 @@ -- Copyright : (c) Galois, Inc. 2008 -- License : BSD3 -- --- Maintainer : Sigbjorn Finne +-- Maintainer : Sigbjorn Finne -- Stability : provisional -- Portability : portable -- @@ -89,10 +89,11 @@ baseUrl :: String baseUrl = "http://feeds.delicious.com/v2/json" -buildUrl :: (URLString -> IO a) -> URLString -> DM a +buildUrl :: (String -> 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})) + ua <- getUAgent + liftIO (f ua (case mbc of { Nothing -> u ; Just c -> u++"?count="++show c})) handleResult :: JSON a => String -> URLString -> DM a handleResult loc u = do @@ -290,7 +291,8 @@ 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 + ua <- getUAgent + liftIO $ readContentsURL ua eff_url where build_query u c = consSlash (userName u) ++ (fromMaybe "" (fmap consSlash mbTg)) ++ '?':opts where diff --git a/Network/Delicious/RSS.hs b/Network/Delicious/RSS.hs --- a/Network/Delicious/RSS.hs +++ b/Network/Delicious/RSS.hs @@ -4,7 +4,7 @@ -- Copyright : (c) Galois, Inc. 2008 -- License : BSD3 -- --- Maintainer : Sigbjorn Finne +-- Maintainer : Sigbjorn Finne -- Stability : provisional -- Portability : portable -- @@ -96,10 +96,11 @@ b_urlinfo_url = deli_base ++ "/rss/urlinfo/" -} -buildUrl :: (URLString -> IO a) -> URLString -> DM a +buildUrl :: (String -> 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})) + ua <- getUAgent + liftIO (f ua (case mbc of { Nothing -> u ; Just c -> u++"?count="++show c})) performCall :: String -> URLString -> DM [Post] performCall loc u = do diff --git a/Network/Delicious/Types.hs b/Network/Delicious/Types.hs --- a/Network/Delicious/Types.hs +++ b/Network/Delicious/Types.hs @@ -4,7 +4,7 @@ -- Copyright : (c) Galois, Inc. 2008 -- License : BSD3 -- --- Maintainer : Sigbjorn Finne +-- Maintainer : Sigbjorn Finne -- Stability : provisional -- Portability : portable -- @@ -25,9 +25,11 @@ , catchDM -- :: DM a -> (IOError -> DM a) -> DM a , withUser -- :: User -> DM a -> DM a , withCount -- :: Int -> DM a -> DM a + , withUAgent -- :: String -> DM a -> DM a , getUser -- :: DM User , getBase -- :: DM URLString , getCount -- :: DM (Maybe Int) + , getUAgent -- :: DM String , liftIO -- :: IO a -> DM a , runDelic -- :: User -> URLString -> DM a -> IO a @@ -60,6 +62,7 @@ { dmUser :: User , dmBase :: URLString , dmCount :: Maybe Int + , dmAgent :: String } data User @@ -91,6 +94,9 @@ withCount :: Int -> DM a -> DM a withCount c k = DM $ \ env -> (unDM k) env{dmCount=Just c} +withUAgent :: String -> DM a -> DM a +withUAgent s k = DM $ \ env -> (unDM k) env{dmAgent=s} + getUser :: DM User getUser = DM $ \ env -> return (dmUser env) @@ -100,11 +106,18 @@ getBase :: DM URLString getBase = DM $ \ env -> return (dmBase env) +getUAgent :: DM URLString +getUAgent = DM $ \ env -> return (dmAgent 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} +runDelic u b dm = (unDM dm) DMEnv{dmUser=u,dmBase=b,dmCount=Nothing,dmAgent=defaultAgent} + +-- the default User-Agent: setting. +defaultAgent :: String +defaultAgent = "hs-delicious" del_base :: URLString del_base = "https://api.del.icio.us/v1" diff --git a/Network/Delicious/User.hs b/Network/Delicious/User.hs --- a/Network/Delicious/User.hs +++ b/Network/Delicious/User.hs @@ -4,7 +4,7 @@ -- Copyright : (c) Galois, Inc. 2008 -- License : BSD3 -- --- Maintainer : Sigbjorn Finne +-- Maintainer : Sigbjorn Finne -- Stability : provisional -- Portability : portable -- @@ -50,7 +50,8 @@ b <- getBase u <- getUser let effUrl = b ++ '/':cmd ++ tlOpts opts - xs <- liftIO $ readUserContentsURL u effUrl + ua <- getUAgent + xs <- liftIO $ readUserContentsURL u ua effUrl return (fromMaybe (Right xs) $ fmap Left $ parseXMLDoc xs) where tlOpts [] = "" diff --git a/delicious.cabal b/delicious.cabal --- a/delicious.cabal +++ b/delicious.cabal @@ -1,14 +1,14 @@ name: delicious -version: 0.3.2 +version: 0.3.3 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. +author: Sigbjorn Finne +maintainer: Sigbjorn Finne +copyright: (c) 2008-2009 Sigbjorn Finne. cabal-version: >= 1.2 build-type: Simple