module Network.Delicious.User
( getLastUpdate
, getTags
, renameTag
, deleteTag
, getPosts
, getRecent
, getAll
, getAllHashes
, getByDate
, addPost
, deletePost
, getBundles
, setBundle
, deleteBundle
, 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)