diff --git a/FriendFeed/API.hs b/FriendFeed/API.hs new file mode 100644 --- /dev/null +++ b/FriendFeed/API.hs @@ -0,0 +1,25 @@ +-------------------------------------------------------------------- +-- | +-- Module : FriendFeed.API +-- Description : Toplevel FriendFeed API module. +-- Copyright : (c) Sigbjorn Finne, 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: portable +-- +-- Toplevel FriendFeed API module, including re-exports +-- of modules required to work with FriendFeed from other +-- modules. +-- +-------------------------------------------------------------------- +module FriendFeed.API + ( module FriendFeed.Types + , module FriendFeed.Monad + , module FriendFeed.Types.Import + ) where + +import FriendFeed.Types +import FriendFeed.Monad +import FriendFeed.Types.Import diff --git a/FriendFeed/Entry.hs b/FriendFeed/Entry.hs new file mode 100644 --- /dev/null +++ b/FriendFeed/Entry.hs @@ -0,0 +1,55 @@ +-------------------------------------------------------------------- +-- | +-- Module : FriendFeed.Entry +-- Description : Entry-specific FriendFeed API calls. +-- Copyright : (c) Sigbjorn Finne, 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: portable +-- +-- Entry-specific FriendFeed API calls. +-- +-------------------------------------------------------------------- +module FriendFeed.Entry where + +import FriendFeed.Types +import FriendFeed.Types.Import () +import FriendFeed.Monad + +import Data.List + +getIdEntry :: UUID -> FFm Entry +getIdEntry uuid = authCall $ + ffeedTranslate $ + ffeedCall ["feed","entry",uuid] [] + +getIdEntries :: [UUID] -> FFm [Entry] +getIdEntries us = + ffeedTranslateLs "entries" $ + ffeedCall ["feed","entry"] [("entry_id", intercalate "," us)] + +-- | Returns the entries the authenticated user would see on their +-- FriendFeed homepage - all of their subscriptions and +-- friend-of-a-friend entries. +getFriendEntries :: FFm [Entry] +getFriendEntries = authCall $ + ffeedTranslateLs "entries" $ + ffeedCall ["feed","home"] [] + +getURLEntries :: URLString -> FFm [Entry] +getURLEntries u = authCall $ + ffeedTranslateLs "entries" $ + ffeedCall ["feed","url"] + [("url",u)] + +getDomainEntries :: [String] -> Bool -> Bool -> FFm [Entry] +getDomainEntries ds inExact isSubscribed = authCall $ + ffeedTranslateLs "entries" $ + ffeedCall ["feed","domain"] + ((if isSubscribed then (("subscribed","1"):) else id) $ + (if inExact then (("inexact","1"):) else id) + [("domain",intercalate "," ds)]) + -- ToDo: add nickname filtering/restriction + diff --git a/FriendFeed/List.hs b/FriendFeed/List.hs new file mode 100644 --- /dev/null +++ b/FriendFeed/List.hs @@ -0,0 +1,34 @@ +-------------------------------------------------------------------- +-- | +-- Module : FriendFeed.List +-- Description : Look up FriendFeed lists +-- Copyright : (c) Sigbjorn Finne, 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: portable +-- +-- Actions for fetching info regarding a user's FriendFeed lists. +-- +-------------------------------------------------------------------- +module FriendFeed.List where + +import FriendFeed.Types +import FriendFeed.Types.Import () +import FriendFeed.Monad + +-- | Returns a list of all of the list's members +-- and the url associated with the list +-- (Authentication required): +getListProfile :: ListName -> FFm List +getListProfile l = authCall $ + ffeedTranslate $ + ffeedCall ["list",l,"profile"] [] + +-- | Returns entries from the authenticated users +-- list with the given nickname: +getListEntries :: ListName -> FFm [Entry] +getListEntries l = authCall $ + ffeedTranslateLs "entries" $ + ffeedCall ["feed","list",l] [] diff --git a/FriendFeed/Monad.hs b/FriendFeed/Monad.hs new file mode 100644 --- /dev/null +++ b/FriendFeed/Monad.hs @@ -0,0 +1,242 @@ +{-# OPTIONS_GHC -XExistentialQuantification -XDeriveDataTypeable #-} +-------------------------------------------------------------------- +-- | +-- Module : FriendFeed.Monad +-- Description : Monadic layer for supporting friendfeed.com interactions. +-- Copyright : (c) Sigbjorn Finne, 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: portable +-- +-- Monadic layer for handling calls and processing of FriendFeed API +-- interaction. +-------------------------------------------------------------------- +module FriendFeed.Monad where + +import Data.List ( intercalate ) +import Util.Fetch +import Util.Codec.URLEncoder +import Data.Maybe + +import Control.Exception as CE +import Data.Typeable + +import Text.JSON +import Text.JSON.Types +import Text.JSON.String + +-- + +newtype FFm a = FFm (FFmEnv -> IO a) + +data FFmEnv + = FFmEnv + { ffm_auth_user :: AuthUser + , ffm_page_size :: Maybe Int + , ffm_entry_start :: Maybe Int + , ffm_services_filter :: [String] + , ffm_is_post :: Bool + , ffm_base :: URLString + } + +nullFFmEnv :: AuthUser -> FFmEnv +nullFFmEnv au + = FFmEnv + { ffm_auth_user = au + , ffm_page_size = Nothing + , ffm_entry_start = Nothing + , ffm_services_filter = [] + , ffm_is_post = False + , ffm_base = api_base + } + +runFF :: String -> String -> FFm a -> IO a +runFF a b (FFm x) = x (nullFFmEnv (AuthUser a b)) + +withUser :: String -> String -> FFm a -> FFm a +withUser nm rkey x + = withEnv (\env -> env{ffm_auth_user=AuthUser{authUserName=nm,authUserKey=rkey}}) + x + +forService :: String -> FFm a -> FFm a +forService s = withEnv (\ env -> env{ffm_services_filter=[s]}) + +startIndex :: Int -> FFm a -> FFm a +startIndex p = withEnv (\ env -> env{ffm_entry_start=Just p}) + +withPageSize :: Int -> FFm a -> FFm a +withPageSize p = withEnv (\ env -> env{ffm_page_size=Just p}) + +withBase :: URLString -> FFm a -> FFm a +withBase b = withEnv (\ env -> env{ffm_base=b}) + +withEnv :: (FFmEnv -> FFmEnv) -> FFm a -> FFm a +withEnv f (FFm x) = FFm (\ env -> x (f env)) + +postMethod :: FFm a -> FFm a +postMethod a = withEnv (\ env -> env{ffm_is_post=True}) a + +authCall :: FFm a -> FFm a +authCall x = x + +data AuthUser + = AuthUser + { authUserName :: String + , authUserKey :: String + } + +instance Monad FFm where + return x = FFm (\ _ -> return x) + (FFm x) >>= k = FFm $ \ env -> do + v <- x env + case k v of + FFm y -> y env + +liftIO :: IO a -> FFm a +liftIO act = FFm (\ _ -> act) + +ffeedCall_ :: [String] -> [(String,String)] -> FFm () +ffeedCall_ m args = {-ffeedTranslate checkResponse-} (ffeedCall m args) >> return () + +checkResponse :: String -> ErrM String +checkResponse s = Right s + +type ErrM a = Either FFeedErr a + +ffeedTranslateLs :: JSON a => String -> FFm String -> FFm [a] +ffeedTranslateLs l a = do + vs <- a + case runGetJSON readJSObject vs of + Right (JSObject (JSONObject os)) -> + case lookup l os of + Just (JSArray xs) -> mapM (dec vs) xs + Just x -> dec vs x >>= \ v -> return [v] + Nothing -> return [] + _ -> return [] + where + dec vs x = + case readJSON x of + Error e -> liftIO (throwIO (toException FFeedErr{ffErrorCode="translate-error-"++l, ffErrorLoc = (Just e), ffErrorSource = vs {-showJSValue x ""-}})) + Ok s -> return s + +ffeedTranslate :: JSON a => FFm String -> FFm a +ffeedTranslate a = do + x <- a + case decodeStrict x of + Error e -> liftIO (throwIO (toException FFeedErr{ffErrorCode="translate-error", ffErrorLoc = (Just e), ffErrorSource = x})) + Ok s -> return s + +onSuccess :: FFm () -> FFm Bool +onSuccess (FFm x) = FFm (\ env -> do + v <- CE.try (x env) + case v of + Left SomeException{} -> return False + _ -> return True) + +ffeedCall :: [String] -> [(String,String)] -> FFm String +ffeedCall ms args = FFm $ \ env -> do + let + service = intercalate "," $ ffm_services_filter env + start = ffm_entry_start env + num = ffm_page_size env + usr = ffm_auth_user env + + meth = intercalate "/" ms + as = map (\ (x,y) -> encodeString x ++ '=':encodeString y) args + + wArgs [] = "" + wArgs xs = '?':intercalate "&" xs + + base = ffm_base env + + url = base ++ meth ++ (if ffm_is_post env then "" else query) + + query = (wArgs $ + mbArg "num" (fmap show num) $ + mbArg "start" (fmap show start) $ + lsArg "service" service as) + + ausr = User{userName=authUserName usr,userPass=authUserKey usr} + body = (crnl++crnl++tail query) + cs = [ ("Content-Type", "application/x-www-form-urlencoded") + , ("Content-Length", show (length body)) + ] + crnl = "\r\n" + rMeth + | ffm_is_post env = \ x -> postContentsURL (Just ausr) x cs body + | otherwise = readUserContentsURL ausr + + rMeth url + +mbArg :: String -> Maybe String -> [String] -> [String] +mbArg _ Nothing xs = xs +mbArg x (Just y) xs = (x++'=':encodeString y):xs + +lsArg :: String -> String -> [String] -> [String] +lsArg _ [] xs = xs +lsArg x ys xs = (x++'=':encodeString ys):xs + +api_base :: String +api_base = "http://friendfeed.com/api/" + +ffeed_base :: String +ffeed_base = "http://friendfeed.com/" + +data FFeedErr + = FFeedErr + { ffErrorCode :: String + , ffErrorLoc :: Maybe String + , ffErrorSource :: String + } deriving Typeable + +ffeedError :: FFeedErr +ffeedError + = FFeedErr { ffErrorCode = "" + , ffErrorLoc = Nothing + , ffErrorSource = "" + } + +data SomeFFeedException = forall e . Exception e => SomeFFeedException e + deriving Typeable + +instance Show SomeFFeedException where + show (SomeFFeedException e) = show e + +instance Exception SomeFFeedException + +ffeedToException :: Exception e => e -> SomeException +ffeedToException = toException . SomeFFeedException + +ffeedFromException :: Exception e => SomeException -> Maybe e +ffeedFromException x = do + SomeFFeedException a <- fromException x + cast a + +instance Exception FFeedErr where + toException = ffeedToException + fromException = ffeedFromException + +handleFFeed :: (FFeedErr -> FFm a) -> FFm a -> FFm a +handleFFeed h e = catchFFeed e h + +tryFFeed :: FFm a -> FFm (Either FFeedErr a) +tryFFeed f = handleFFeed (\ x -> return (Left x)) (f >>= return.Right) + +throwFFeedErr :: FFeedErr -> FFm a +throwFFeedErr e = FFm (\ _ -> throwIO e) + +catchFFeed :: FFm a -> (FFeedErr -> FFm a) -> FFm a +catchFFeed (FFm f) hdlr = FFm $ \ env -> + CE.catch (f env) + (\ e1 -> case hdlr e1 of { (FFm act) -> act env }) + +instance Show FFeedErr where + show x = unlines ( + [ "FriendFeed error:" + , "" + , " Code: " ++ ffErrorCode x + , " Location: " ++ fromMaybe "" (ffErrorLoc x) + , " Source: " ++ ffErrorSource x + ]) diff --git a/FriendFeed/Publish.hs b/FriendFeed/Publish.hs new file mode 100644 --- /dev/null +++ b/FriendFeed/Publish.hs @@ -0,0 +1,85 @@ +-------------------------------------------------------------------- +-- | +-- Module : FriendFeed.Publish +-- Description : Posting / publishing to FriendFeed +-- Copyright : (c) Sigbjorn Finne, 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: portable +-- +-- Actions for publishing entries, comments, likes etc. to FriendFeed. +-- +-------------------------------------------------------------------- +module FriendFeed.Publish where + +import FriendFeed.Types +import FriendFeed.Types.Import () +import FriendFeed.Monad + +import Data.Maybe + +-- | Publish a new entry on the authenticated user's feed. +publishLink :: String + -> URLString + -> Maybe String + -> FFm () +publishLink title l mbComment = postMethod $ authCall $ + ffeedCall_ ["share"] + [ ("title", title) + , ("link", l) + , ("comment", fromMaybe "" mbComment) + ] + +-- | Add a comment or edit an existing comment on a FriendFeed entry. +addComment :: EntryID -> String -> FFm CommentID +addComment entry body = postMethod $ + ffeedTranslate $ + ffeedCall ["comment"] + [ ("entry", entry) + , ("body", body) + ] + +-- | add a comment or edit an existing comment on a FriendFeed entry. +editComment :: EntryID -> String -> CommentID -> FFm () +editComment entry body c = postMethod $ + ffeedCall_ ["comment"] + [ ("entry", entry) + , ("body", body) + , ("comment", c) + ] + +-- | delete an existing comment. +deleteComment :: EntryID -> CommentID -> FFm () +deleteComment entry c = postMethod $ + ffeedCall_ ["comment","delete"] + [ ("entry", entry) + , ("comment", c) + ] + +-- | add a "Like" to a FriendFeed entry for the authenticated user. +addLike :: EntryID -> FFm () +addLike e = authCall $ postMethod $ + ffeedCall_ ["like"] + [("entry",e)] + +-- | delete an existing @"Like"@. +deleteLike :: EntryID -> FFm () +deleteLike e = authCall $ postMethod $ + ffeedCall_ ["like","delete"] + [("entry",e)] + +-- | Delete an existing entry, but un-delete if 2nd arg is @True@. +deleteEntry :: EntryID -> Bool -> FFm () +deleteEntry e unDel = authCall $ + ffeedCall_ ["entry","delete"] + ((if unDel then (("undelete","1"):) else id) + [("entry",e)]) + +-- | Hide an entry, but un-hide/expose if 2nd arg is @True@. +hideEntry :: EntryID -> Bool -> FFm () +hideEntry e unDel = authCall $ + ffeedCall_ ["entry","hide"] + ((if unDel then (("unhide","1"):) else id) + [("entry",e)]) diff --git a/FriendFeed/Room.hs b/FriendFeed/Room.hs new file mode 100644 --- /dev/null +++ b/FriendFeed/Room.hs @@ -0,0 +1,42 @@ +-------------------------------------------------------------------- +-- | +-- Module : FriendFeed.Room +-- Description : Fetch room-specific FriendFeed info. +-- Copyright : (c) Sigbjorn Finne, 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: portable +-- +-- Actions for fetching info on and entries from a room. +-- +-------------------------------------------------------------------- +module FriendFeed.Room where + +import FriendFeed.Types +import FriendFeed.Types.Import +import FriendFeed.Monad + +-- | Returns a list of all of the room's members +-- and the url associated with the room +-- (Authentication required for private rooms). +getRoomProfile :: RoomName -> FFm Room +getRoomProfile r = authCall $ + ffeedTranslate $ + ffeedCall ["room", r, "profile"] [] + +-- | Returns the entries the authenticated user +-- would see on their Rooms page - entries from all +-- of the rooms they are members of. +getRoomsFeeds :: FFm [Entry] +getRoomsFeeds = authCall $ + ffeedTranslateLs "entries" $ + ffeedCall ["feed","rooms"] [] + +-- | Returns the most recent entries in the room with the given nickname. +-- If the room is private, authentication is required. +getRoomEntries :: RoomName -> FFm [Entry] +getRoomEntries r = + ffeedTranslateLs "entries" $ + ffeedCall ["feed","room",r] [] diff --git a/FriendFeed/Search.hs b/FriendFeed/Search.hs new file mode 100644 --- /dev/null +++ b/FriendFeed/Search.hs @@ -0,0 +1,35 @@ +-------------------------------------------------------------------- +-- | +-- Module : FriendFeed.Search +-- Description : Search FriendFeed entries +-- Copyright : (c) Sigbjorn Finne, 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: portable +-- +-- Actions for publishing entries, comments, likes etc. to FriendFeed. +-- +-------------------------------------------------------------------- +module FriendFeed.Search where + +import FriendFeed.Types +import FriendFeed.Types.Import () +import FriendFeed.Monad + +-- | Executes a search over the entries in FriendFeed. +searchEntries :: String + -> Maybe UserName + -> Maybe ServiceName + -> FFm [Entry] +searchEntries query mbUser mbService = + ffeedTranslateLs "entries" $ + ffeedCall ["feed","search"] + [("q" + , mbPrep "who" mbUser $ + mbPrep "service" mbService + query)] + where + mbPrep _ Nothing xs = xs + mbPrep a (Just b) xs = (a++':':b++ ' ':xs) diff --git a/FriendFeed/Service.hs b/FriendFeed/Service.hs new file mode 100644 --- /dev/null +++ b/FriendFeed/Service.hs @@ -0,0 +1,26 @@ +-------------------------------------------------------------------- +-- | +-- Module : FriendFeed.Service +-- Description : Binding to the service-related FriendFeed API +-- Copyright : (c) Sigbjorn Finne, 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: portable +-- +-- Action for fetching the current services supported by FriendFeed. +-- +-------------------------------------------------------------------- +module FriendFeed.Service where + +import FriendFeed.Types +import FriendFeed.Types.Import () +import FriendFeed.Monad + +-- | Lists all services currently supported by FriendFeed. +getServices :: FFm [Service] +getServices = + ffeedTranslateLs "services" $ + ffeedCall ["services"] [] + diff --git a/FriendFeed/Subscribe.hs b/FriendFeed/Subscribe.hs new file mode 100644 --- /dev/null +++ b/FriendFeed/Subscribe.hs @@ -0,0 +1,36 @@ +-------------------------------------------------------------------- +-- | +-- Module : FriendFeed.Subscribe +-- Description : Control subscriptions to users and rooms. +-- Copyright : (c) Sigbjorn Finne, 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: portable +-- +-- Binding to FriendFeed API controlling subscriptions to rooms +-- and other users. +-- +-------------------------------------------------------------------- +module FriendFeed.Subscribe where + +import FriendFeed.Types +import FriendFeed.Types.Import () +import FriendFeed.Monad + +subscribeUser :: UserName -> FFm () +subscribeUser u = authCall $ + ffeedCall_ ["user",u,"subscribe"] [] + +unsubscribeUser :: UserName -> FFm () +unsubscribeUser u = authCall $ + ffeedCall_ ["user",u,"subscribe"] [("unsubscribe","1")] + +subscribeRoom :: RoomName -> FFm () +subscribeRoom r = authCall $ + ffeedCall_ ["room",r,"subscribe"] [] + +unsubscribeRoom :: RoomName -> FFm () +unsubscribeRoom r = authCall $ + ffeedCall_ ["room",r,"subscribe"] [("unsubscribe","1")] diff --git a/FriendFeed/Types.hs b/FriendFeed/Types.hs new file mode 100644 --- /dev/null +++ b/FriendFeed/Types.hs @@ -0,0 +1,281 @@ +-------------------------------------------------------------------- +-- | +-- Module : FriendFeed.Types +-- Description : Types used in the FriendFeed API +-- Copyright : (c) Sigbjorn Finne, 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: portable +-- +-- Definition of types that the FriendFeed API uses in its +-- responses. +-- +-------------------------------------------------------------------- +module FriendFeed.Types where + +type UUID = String +type URLString = String +type DateString = String +type UserName = String +type ListName = String +type RoomName = String +type ServiceName = String + +type EntryID = UUID +type CommentID = UUID +type RoomID = UUID +type ListID = UUID +type ServiceID = UUID +type UserID = UUID + + +nullUUID :: UUID +nullUUID = "" + +data Entry + = Entry + { entryId :: UUID + , entryTitle :: String + , entryLink :: URLString + , entryPublished :: DateString + , entryUpdated :: DateString + , entryIsHidden :: Bool + , entryIsAnon :: Bool + , entryUser :: Resource User + , entryService :: Service + , entryLikes :: [Like] + , entryComments :: [Comment] + , entryMedia :: [Media] + , entryVia :: Maybe Via + , entryRoom :: Maybe (Resource Room) + } + +type Via = (String, URLString) + +nullVia :: Via +nullVia = ("","") + +nullEntry :: Entry +nullEntry + = Entry + { entryId = nullUUID + , entryTitle = "" + , entryLink = "" + , entryPublished = "" + , entryUpdated = "" + , entryIsHidden = False + , entryIsAnon = False + , entryUser = nullResource + , entryService = nullService + , entryLikes = [] + , entryComments = [] + , entryMedia = [] + , entryVia = Nothing + , entryRoom = Nothing + } + +data User + = User + { userStatus :: String + , userId :: UserID + , userName :: UserName + , userNickname :: UserName + , userProfileURL :: URLString + , userServices :: [Service] + , userSubscriptions :: [Resource Subscription] + , userRooms :: [Resource Room] + , userLists :: [Resource List] + } + +nullUser :: User +nullUser + = User + { userStatus = "unsubscribed" + , userId = nullUUID + , userName = "" + , userNickname = "" + , userProfileURL = "" + , userServices = [] + , userSubscriptions = [] + , userRooms = [] + , userLists = [] + } + +data Subscription = Subscription_ + +data Comment + = Comment + { commentDate :: DateString + , commentUser :: [Resource User] + , commentBody :: String + } + +nullComment :: Comment +nullComment + = Comment + { commentDate = "" + , commentUser = [] + , commentBody = "" + } + +data Like + = Like + { likeDate :: DateString + , likeUser :: Resource User + } + +nullLike :: Like +nullLike + = Like + { likeDate = "" + , likeUser = nullResource + } + +data Media + = Media + { mediaTitle :: Maybe String + , mediaPlayer :: Maybe String + , mediaLink :: URLString + , mediaThumbs :: [Thumbnail] + , mediaContent :: [Content] + , mediaEnclosure :: [Enclosure] + } + +nullMedia :: Media +nullMedia + = Media + { mediaTitle = Nothing + , mediaPlayer = Nothing + , mediaLink = "" + , mediaThumbs = [] + , mediaContent = [] + , mediaEnclosure = [] + } + +data Thumbnail + = Thumbnail + { thumbUrl :: URLString + , thumbWidth :: Int + , thumbHeight :: Int + } + +nullThumbnail :: Thumbnail +nullThumbnail + = Thumbnail + { thumbUrl = "" + , thumbWidth = 0 + , thumbHeight = 0 + } + +data Content + = Content + { contentUrl :: URLString + , contentType :: String -- MIME + , contentWidth :: Int + , contentHeight :: Int + } + +nullContent :: Content +nullContent + = Content + { contentUrl = "" + , contentType = "" + , contentWidth = 0 + , contentHeight = 0 + } + +data Service + = Service + { serviceUrl :: URLString + , serviceIconUrl :: URLString + , serviceId :: ServiceID + , serviceName :: String + } + +nullService :: Service +nullService + = Service + { serviceUrl = "" + , serviceIconUrl = "" + , serviceId = nullUUID + , serviceName = "" + } + +data Enclosure + = Enclosure + { enclosureUrl :: URLString + , enclosureType :: String -- ^ MIME type + , enclosureLength :: Integer + } + +nullEnclosure :: Enclosure +nullEnclosure + = Enclosure + { enclosureUrl = "" + , enclosureType = "" + , enclosureLength = 0 + } + +data Resource a + = Resource + { resourceId :: UUID + , resourceName :: String + , resourceNickname :: String + , resourceUrl :: URLString + } + +nullResource :: Resource a +nullResource + = Resource + { resourceId = nullUUID + , resourceName = "" + , resourceNickname = "" + , resourceUrl = "" + } + +data Room + = Room + { roomStatus :: String -- ^ static or public + , roomDescription :: String + , roomUrl :: URLString + , roomAdmins :: [Resource User] + , roomMember :: [Resource User] + , roomId :: RoomID + , roomName :: String + , roomNickname :: String + } + +nullRoom :: Room +nullRoom + = Room + { roomStatus = "public" + , roomDescription = "" + , roomUrl = "" + , roomAdmins = [] + , roomMember = [] + , roomId = nullUUID + , roomName = "" + , roomNickname = "" + } + +data List + = List + { listId :: ListID + , listName :: String + , listNickname :: String + , listURL :: URLString + , listUsers :: [Resource User] + , listRooms :: [Resource Room] + } + +nullList :: List +nullList = List + { listId = "" + , listName = "" + , listNickname = "" + , listURL = "" + , listUsers = [] + , listRooms = [] + } diff --git a/FriendFeed/User.hs b/FriendFeed/User.hs new file mode 100644 --- /dev/null +++ b/FriendFeed/User.hs @@ -0,0 +1,87 @@ +-------------------------------------------------------------------- +-- | +-- Module : FriendFeed.User +-- Description : Fetch user-specific FriendFeed info. +-- Copyright : (c) Sigbjorn Finne, 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: portable +-- +-- Actions for fetching entries,comments etc. for one or +-- more users\/friends. +-- +-------------------------------------------------------------------- +module FriendFeed.User where + +import FriendFeed.Types +import FriendFeed.Types.Import () +import FriendFeed.Monad + +import Data.List ( intercalate ) + +-- | Returns list of all of the user's subscriptions +-- (people) and services connected to their account +-- (Authentication required for private users): +getUserProfile :: UserName -> FFm User +getUserProfile uname = authCall $ + ffeedTranslate $ + ffeedCall ["user",uname,"profile"] [] + +-- | Get a user's profile picture. +getUserPicture :: UserName -> String -> FFm URLString +getUserPicture uname sz = withBase ffeed_base $ + ffeedTranslate $ + ffeedCall [uname,"picture"] + [("size",sz)] + +-- | Returns the most recent public entries on FriendFeed. +getPublicEntries :: FFm [Entry] +getPublicEntries = authCall $ + ffeedTranslateLs "entries" $ + ffeedCall ["feed", "public"] [] + +getUserEntries :: UserName -> FFm [Entry] +getUserEntries u = authCall $ + ffeedTranslateLs "entries" $ + ffeedCall ["feed","user",u] [] + +getUserComments :: UserName -> FFm [Entry] +getUserComments u = authCall $ + ffeedTranslateLs "entries" $ + ffeedCall ["feed","user",u, "comments"] [] + +getUserLikes :: UserName -> FFm [Entry] +getUserLikes u = authCall $ + ffeedTranslateLs "entries" $ + ffeedCall ["feed","user",u, "likes"] [] + +-- | Returns the most recent entries the user has commented +-- on or "liked". +getUserDiscussion :: UserName -> FFm [Entry] +getUserDiscussion u = authCall $ + ffeedTranslateLs "entries" $ + ffeedCall ["feed","user",u, "discussion"] [] + +-- | Returns entries from a user's friends. +getFriendEntries :: UserName -> FFm [Entry] +getFriendEntries u = authCall $ + ffeedTranslateLs "entries" $ + ffeedCall ["feed","user",u, "friends"] [] + +-- | Returns the most recent entries from a list of users, +-- specified by nickname. +getUsersEntries :: [UserName] -> FFm [Entry] +getUsersEntries us = + ffeedTranslateLs "entries" $ + ffeedCall ["feed","user"] + [("nickname", intercalate "," us)] + +-- | Validates the user's remote key. If the HTTP Basic +-- Authentication nickname and remote key are valid, we +-- return a HTTP 200 status code. Otherwise, we return an +-- HTTP 401 status code. +validateUserKey :: FFm Bool +validateUserKey = onSuccess $ authCall $ + ffeedCall_ ["validate"] [] diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) Sigbjorn Finne, 2008. + +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/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,6 @@ +module Main(main) where + +import FriendFeed.User + +main :: IO () +main = return () diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,43 @@ += hsffeed - Programming FriendFeed from Haskell = + +'hsffeed' is a Haskell package providing a binding to +the FriendFeed API - + + http://friendfeed.com/api/ + http://code.google.com/p/friendfeed-api/wiki/ApiDocumentation + +The binding is functionally complete (Nov 2008), letting you write +applications in Haskell that accesses and manipulates content on +FriendFeed and the sites it aggregates. + += Getting started = + +For some code samples showing you how to get started using this +API binding, have a look in the examples/ directory. + += Building and installing = + +This package is provided in Cabal form, so only thing you need to +do to get going is: + + foo% runghc Setup configure + foo% runghc Setup build + foo% runghc Setup install + +The package depends on a bunch of other packages though, so you +need to have them built&installed, as well. They are: + + * HTTP: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/HTTP + * json: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/json + * utf8-string: http://hackage.haskell.org/cgi-bin/hackage-scripts/package/utf8-string + += Authentication = + +When using this API binding to build your own FriendFeed application, +authenticated calls require a user's remote key. This key is available +to logged-in FriendFeed users via http://www.friendfeed.com/remotekey + += Feedback / question = + +Please send them to sof@forkIO.com , and I'll try to respond to them +as best/quickly as possible. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,8 @@ +module Main(main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain + + diff --git a/Util/Codec/Percent.hs b/Util/Codec/Percent.hs new file mode 100644 --- /dev/null +++ b/Util/Codec/Percent.hs @@ -0,0 +1,57 @@ +{- | + + Module : Util.Codec.Percent + Copyright : (c) 2008 + + Maintainer : sof@forkIO.com + + License : See the file LICENSE + + Status : Coded + + Codec for de/encoding URI strings via percent encodings + (cf. RFC 3986.) +-} +module Util.Codec.Percent where + +import Data.Char ( chr, isAlphaNum ) +import Numeric ( readHex, showHex ) + +getEncodedString :: String -> String +getEncodedString "" = "" +getEncodedString (x:xs) = + case getEncodedChar x of + Nothing -> x : getEncodedString xs + Just ss -> ss ++ getEncodedString xs + +getDecodedString :: String -> String +getDecodedString "" = "" +getDecodedString ls@(x:xs) = + case getDecodedChar ls of + Nothing -> x : getDecodedString xs + Just (ch,xs1) -> ch : getDecodedString xs1 + +getEncodedChar :: Char -> Maybe String +getEncodedChar x + | isAlphaNum x || + x `elem` "-_.~" = Nothing + | xi < 0xff = Just ('%':showHex (xi `div` 16) (showHex (xi `mod` 16) "")) + | otherwise = -- ToDo: import utf8 lib + error "getEncodedChar: can only handle 8-bit chars right now." + where + xi :: Int + xi = fromEnum x + +getDecodedChar :: String -> Maybe (Char, String) +getDecodedChar str = + case str of + "" -> Nothing + (x:xs) + | x /= '%' -> Nothing + | otherwise -> do + case xs of + (b1:b2:bs) -> + case readHex [b1,b2] of + ((v,_):_) -> Just (Data.Char.chr v, bs) + _ -> Nothing + _ -> Nothing diff --git a/Util/Codec/URLEncoder.hs b/Util/Codec/URLEncoder.hs new file mode 100644 --- /dev/null +++ b/Util/Codec/URLEncoder.hs @@ -0,0 +1,33 @@ +{- + Codec for de/encoding form data shipped in URL query strings + or in POST request bodies. (application/x-www-form-urlencoded) + (cf. RFC 3986.) +-} +module Util.Codec.URLEncoder + ( encodeString + , decodeString + ) where + +import qualified Codec.Binary.UTF8.String as UTF8 ( encodeString ) +import Util.Codec.Percent ( getEncodedChar, getDecodedChar ) + +encodeString :: String -> String +encodeString str = go (UTF8.encodeString str) + where + go "" = "" + go (' ':xs) = '+':go xs + go ('\r':'\n':xs) = '%':'0':'D':'%':'0':'A':go xs + go ('\r':xs) = go ('\r':'\n':xs) + go ('\n':xs) = go ('\r':'\n':xs) + go (x:xs) = + case getEncodedChar x of + Nothing -> x : go xs + Just ss -> ss ++ go xs + +decodeString :: String -> String +decodeString "" = "" +decodeString ('+':xs) = ' ':decodeString xs +decodeString ls@(x:xs) = + case getDecodedChar ls of + Nothing -> x : decodeString xs + Just (ch,xs1) -> ch : decodeString xs1 diff --git a/Util/Fetch.hs b/Util/Fetch.hs new file mode 100644 --- /dev/null +++ b/Util/Fetch.hs @@ -0,0 +1,134 @@ +-------------------------------------------------------------------- +-- | +-- Module : Util.Fetch +-- Copyright : (c) Sigbjorn Finne, 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne +-- Stability : provisional +-- Portability: so-so +-- +-- Simple GET\/de-ref of URLs; abstracting out networking backend\/package. +-- +module Util.Fetch + ( readContentsURL + , readUserContentsURL + + , postContentsURL + + , URLString + , User(..) + ) where + +--import Network.Curl +import Network.Browser +import Network.HTTP +import Network.URI + +type URLString = String + +data User + = User { userName :: String + , userPass :: String + } + +readContentsURL :: URLString -> IO String +readContentsURL u = do + req <- + case parseURI u of + Nothing -> fail ("ill-formed URL: " ++ u) + Just ur -> return (defaultGETRequest ur) + -- don't like doing this, but HTTP is awfully chatty re: cookie handling.. + let nullHandler _ = return () + (_u, resp) <- browse $ setOutHandler nullHandler >> request req + case rspCode resp of + (2,_,_) -> return (rspBody resp) + _ -> fail ("Failed reading URL " ++ show u ++ " code: " ++ show (rspCode resp)) + +{- Curl version: +readContentsURL :: URLString -> IO String +readContentsURL u = do + let opts = [ CurlFollowLocation True + ] + (_,xs) <- curlGetString u opts + return xs +-} + +readUserContentsURL :: User -> URLString -> IO String +readUserContentsURL usr us = do -- readContentsURL u + req <- + case parseURI us of + Nothing -> fail ("ill-formed URL: " ++ us) + Just ur -> return (defaultGETRequest ur) + -- don't like doing this, but HTTP is awfully chatty re: cookie handling.. + let nullHandler _ = return () + (u, resp) <- browse $ do + setOutHandler nullHandler + setAllowBasicAuth True + setAuthorityGen (\ _ _ -> return (Just (userName usr,userPass usr))) +{- + addAuthority AuthBasic{ auUsername = userName usr + , auPassword = userPass usr + , auRealm = "" + , auSite = nullURI{uriPath="/"} + } +-} + request req + case rspCode resp of + (2,_,_) -> return (rspBody resp) + _ -> fail ("Failed reading URL " ++ show u ++ " code: " ++ show (rspCode resp)) + + +postContentsURL :: Maybe User -> URLString -> [(String,String)] -> String -> IO String +postContentsURL mbU u hdrs body = do + let hs = + case parseHeaders $ map (\ (x,y) -> x++": " ++ y) hdrs of + Left{} -> [] + Right xs -> xs + req0 <- + case parseURI u of + Nothing -> fail ("ill-formed URL: " ++ u) + Just ur -> return (defaultGETRequest ur) + let req = req0{rqMethod=POST + ,rqBody=body + ,rqHeaders=hs + } + let nullHandler _ = return () + (_,rsp) <- browse $ do + setOutHandler nullHandler + case mbU of + Nothing -> return () + Just usr -> do + setAllowBasicAuth True + setAuthorityGen (\ _ _ -> return (Just (userName usr,userPass usr))) + + request req + case rspCode rsp of + (2,_,_) -> return (rspBody rsp) + x -> fail ("POST failed - code: " ++ show x ++ ", URL: " ++ u) + +{- Curl versions: +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 + +postContentsURL :: URLString -> [(String,String)] -> String -> IO String +postContentsURL u hdrs body = do + let opts = [ CurlCustomRequest "POST" + , CurlFollowLocation True + , CurlPost True + , CurlPostFields [body] + , CurlHttpTransferDecoding False + ] ++ [CurlHttpHeaders (map ( \ (x,y) -> (x ++ ':':y)) hdrs)] + rsp <- curlGetResponse u opts + case respStatus rsp `div` 100 of + 2 -> return (respBody rsp) + x -> fail ("POST failed - code: " ++ show x ++ ", URL: " ++ u) + +-} diff --git a/examples/ShowPublic.hs b/examples/ShowPublic.hs new file mode 100644 --- /dev/null +++ b/examples/ShowPublic.hs @@ -0,0 +1,125 @@ +{- + Demonstrates how to use the FriendFeed API by querying + for the most recent public entries collected by FriendFeed. + + The API interaction happens in @showPublic@, with + @presentEntries@ outputting the results. The rest is option + handling stuff + startup and shutdown code in @main@. + + Example command-line invocation: + + foo$ showPublic -u -k \ + -s twitter -l 2 + + showing the last 2 public tweets. + + where and is your FriendFeed auth + setup. Your remote key can be located here: + + http://friendfeed.com/remotekey + + However, since this example presently uses public methods not + needing authentication, any old username/key combo will work. + [Top tip: try leaving them out..] + + The @-s@ option constrains the entries from a given FriendFeed-supported + service. @-l@ limits the length to given size (default: 30.) +-} +module Main(main) where + +import FriendFeed.API +import FriendFeed.User + +import Util.GetOpts +import System.IO +import System.Environment +import System.Exit + +import Control.Monad +import Data.Maybe ( fromMaybe ) + +-- main functions for grabbing public entries + +-- presenting them to the user: +showPublic :: Maybe String -> Maybe Int -> FFm [Entry] +showPublic mbS mbL = + (fromMaybe id (fmap forService mbS)) $ + (fromMaybe id (fmap withPageSize mbL)) $ + getPublicEntries + +presentEntries :: [Entry] -> IO () +presentEntries [] = putStrLn "No public entries found!" +presentEntries xs = do + putStrLn ("Most recent public entries: ") + mapM_ presentEntry xs + where + presentEntry e = + putStrLn $ unlines + [ "---" + , " Title: " ++ entryTitle e + , " Link: " ++ entryLink e + , " User: " ++ resourceName (entryUser e) + ] + + +-- start option handling + +data Options + = Options + { optUser :: Maybe String + , optKey :: Maybe String + , optSize :: Maybe Int + , optService :: Maybe String + } + +nullOptions :: Options +nullOptions = Options + { optUser = Just "" + , optKey = Just "" + , optSize = Nothing + , optService = Nothing + } + +option_descr :: [OptDescr (Options -> Options)] +option_descr = + [ Option ['u'] ["user"] + (ReqArg (\ x o -> o{optUser=Just x}) "USER") + "user name to authenticate as" + , Option ['k','p'] ["key","remote-key"] + (ReqArg (\ x o -> o{optKey=Just x}) "REMOTE KEY") + "the user's FriendFeed remote key" + , Option ['l'] ["length"] + (ReqArg (\ x o -> o{optSize=Just (read x)}) "SIZE") + "fetch SIZE entries" + , Option ['s'] ["service"] + (ReqArg (\ x o -> o{optService=Just x}) "SERVICE") + "limit query to given service name" + ] + +parseOptions :: [String] -> (Options, [String], [String]) +parseOptions argv = getOpt2 Permute option_descr argv nullOptions + +processOptions :: IO Options +processOptions = do + ls <- getArgs + let (opts, ws, es) = parseOptions ls + when (not $ null ws) $ do + hPutStrLn stderr "Command-line warnings: " + hPutStrLn stderr (unlines ws) + when (not $ null es) $ do + hPutStrLn stderr (unlines es) + hPutStrLn stderr ("(try '--help' for list of options supported.)") + exitFailure + return opts + +-- end option handling + +main :: IO () +main = do + opts <- processOptions + case (optUser opts, optKey opts) of + (Just u,Just k) -> do + xs <- runFF u k (showPublic (optService opts) (optSize opts)) + presentEntries xs + _ -> do + putStrLn ("Both user and remote-key options are required.") + return () diff --git a/examples/Util/GetOpts.hs b/examples/Util/GetOpts.hs new file mode 100644 --- /dev/null +++ b/examples/Util/GetOpts.hs @@ -0,0 +1,203 @@ +-- | +-- +-- Module : Util.GetOpts +-- Copyright : (c) 2004-2008, Sigbjorn Finne. +-- +-- Maintainer : sof@forkIO.com +-- Stability : provisional +-- Portability : portable +-- +-- Accumulator-style command-line option parsing; minor extension +-- of @System.Console.GetOpt@ (whose interface this module re-exports). +-- +-- So, to correctly attribute the source of the bulk of the functionality +-- provided, here's its module header: +-- +-- Module : System.Console.GetOpt +-- Copyright : (c) Sven Panne Oct. 1996 (small changes Dec. 1997) +-- License : BSD-style (see the file libraries\/core\/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- A Haskell port of GNU's getopt library +-- + +module Util.GetOpts + ( module System.Console.GetOpt + , getOpt2 -- :: ArgOrder (a->a) + -- -> [OptDescr (a->a)] + -- -> [String] + -- -> a + -- -> (a,[String],[String]) + , usageInfo2 -- :: String -> [OptDescr a] -> String + ) where + +import Prelude +import Data.List ( isPrefixOf ) +import Text.PrettyPrint +--import Util.Pretty +import System.Console.GetOpt + +{- | + The @getOpt@ provided @System.Console.GetOpt@ returns a list of + values representing the options found present in an @argv@-vector. + + @getOpt2@ offers a different view -- the options are represented + by a single value instead, i.e., you define a labelled field record + type representing the options supported, and have the OptDescr + elements just update the contents of that record. This has proven + to be quite a bit less cumbersome to work with, leaving you at + the end with a single value (the record) packaging up all the + options setting. + + With @getOpt@, you normally end up (essentially) having to + write a sub parser of the list of values returned, which just + adds even more bulk to your code, for very little benefit. +-} +getOpt2 :: ArgOrder (a -> a) -- non-option handling + -> [OptDescr (a -> a)] -- option descriptors + -> [String] -- the commandline arguments + -> a -- initial state + -> (a,[String],[String]) -- (options,non-options,error messages) +getOpt2 _ _ [] st = (st,[],[]) +getOpt2 ordering optDescr (arg:args) st = procNextOpt opt ordering + where procNextOpt (Opt f) _ = (f st',xs,es) + procNextOpt (NonOpt x) RequireOrder = (st,x:rest,[]) + procNextOpt (NonOpt x) Permute = (st',x:xs,es) + procNextOpt (NonOpt x) (ReturnInOrder f) = (f x st', xs,es) + procNextOpt EndOfOpts RequireOrder = (st',rest,[]) + procNextOpt EndOfOpts Permute = (st',rest,[]) + procNextOpt EndOfOpts (ReturnInOrder f) = (foldr f st' rest,[],[]) + procNextOpt (OptErr e) _ = (st',xs,e:es) + + (opt,rest) = getNext arg args optDescr + (st',xs,es) = getOpt2 ordering optDescr rest st + +-- getOpt2 supporting code - copied verbatim from System.Console.GetOpt +-- as it isn't exported. + +data OptKind a -- kind of cmd line arg (internal use only): + = Opt a -- an option + | NonOpt String -- a non-option + | EndOfOpts -- end-of-options marker (i.e. "--") + | OptErr String -- something went wrong... + +-- take a look at the next cmd line arg and decide what to do with it +getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +getNext ('-':'-':[]) rest _ = (EndOfOpts,rest) +getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr +getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr +getNext a rest _ = (NonOpt a,rest) + +-- handle long option +longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +longOpt ls rs optDescr = long ads arg rs + where (opt,arg) = break (=='=') ls + options = [ o | o@(Option _ xs _ _) <- optDescr, + l <- xs, + opt `isPrefixOf` l + ] + ads = [ ad | Option _ _ ad _ <- options ] + optStr = ("--"++opt) + + long (_:_:_) _ rest = (errAmbig options optStr,rest) + long [NoArg a ] [] rest = (Opt a,rest) + long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest) + long [ReqArg _ d] [] [] = (errReq d optStr,[]) + long [ReqArg f _] [] (r:rest) = (Opt (f r),rest) + long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest) + long [OptArg f _] [] rest = (Opt (f Nothing),rest) + long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest) + long _ _ rest = (errUnrec optStr,rest) + +-- handle short option +shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +shortOpt x ys rest1 optDescr = short ads ys rest1 + where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, x == s ] + ads = [ ad | Option _ _ ad _ <- options ] + optStr = '-':[x] + + short (_:_:_) _ rest = (errAmbig options optStr,rest) + short (NoArg a :_) [] rest = (Opt a,rest) + short (NoArg a :_) xs rest = (Opt a,('-':xs):rest) + short (ReqArg _ d:_) [] [] = (errReq d optStr,[]) + short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest) + short (ReqArg f _:_) xs rest = (Opt (f xs),rest) + short (OptArg f _:_) [] rest = (Opt (f Nothing),rest) + short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest) + short [] [] rest = (errUnrec optStr,rest) + short [] xs rest = (errUnrec optStr,('-':xs):rest) + +-- miscellaneous error formatting + +errAmbig :: [OptDescr a] -> String -> OptKind a +errAmbig ods optStr = + OptErr $ usageInfo header ods + where header = "option '" ++ optStr ++ "' is ambiguous; could be one of:" + +errReq :: String -> String -> OptKind a +errReq d optStr = + OptErr $ "option '" ++ optStr ++ "' requires an argument " ++ d + +errUnrec :: String -> OptKind a +errUnrec optStr = + OptErr $ "unrecognized option '" ++ optStr ++ "'" + +errNoArg :: String -> OptKind a +errNoArg optStr = + OptErr $ "option '" ++ optStr ++ "' doesn't allow an argument" + +usageInfo2 :: String -- header + -> [OptDescr a] -- option descriptors + -> String -- nicely formatted decription of options +usageInfo2 header optDescr = render $ vcat $ text header : table + where + (ss, ls, descs) = unzip3 $ map fmtOpt optDescr + table = + let (c1, ssd) = sameLen ss + (c2, lsd) = sameLen ls + in + zipWith3 (paste (74 - c1 - c2)) ssd lsd descs + paste c3 x y z = nest 2 $ x <+> space <> y <> space <+> fitText c3 z + sameLen xs = + let width = maximum $ map length xs + in + (width, flushLeft width xs) + flushLeft n xs = [ text $ take n (x ++ repeat ' ') | x <- xs ] + + fmtOpt :: OptDescr a -> (String, String, String) + fmtOpt (Option sos los argdesc descr) = + ( render $ hcat $ punctuate comma $ map (fmtShort argdesc) sos + , render $ hcat $ punctuate comma $ map (fmtLong argdesc) los + , descr + ) + where + fmtShort :: ArgDescr a -> Char -> Doc + fmtShort (NoArg _ ) so = char '-' <> char so + fmtShort (ReqArg _ ad) so = char '-' <> char so <+> text ad + fmtShort (OptArg _ ad) so = char '-' <> char so <+> brackets (text ad) + + fmtLong :: ArgDescr a -> String -> Doc + fmtLong (NoArg _ ) lo = text "--" <> text lo + fmtLong (ReqArg _ ad) lo = text "--" <> text lo <> equals <> text ad + fmtLong (OptArg _ ad) lo = text "--" <> text lo <> equals <> + brackets (text ad) + +-- | Simple line formatting of a paragraph, introducing line breaks +-- whenever length exceeds that of the first argument. +fitText :: Int -> String -> Doc +fitText width s = + vcat $ map (hsep . (map text)) + (fit 0 [] (words s)) + where + -- fill up lines left-to-right, introducing line breaks + -- whenever line length exceeds 'width'. + fit :: Int -> [String] -> [String] -> [[String]] + fit _ acc [] = [reverse acc] + fit n acc (w:ws) + | (n + l) >= width = (reverse (w:acc)) : fit 0 [] ws + | otherwise = fit (n+l+1{-word space-}) (w:acc) ws + where + l = length w diff --git a/ffeed.cabal b/ffeed.cabal new file mode 100644 --- /dev/null +++ b/ffeed.cabal @@ -0,0 +1,59 @@ +name: ffeed +version: 0.2 +synopsis: Haskell binding to the FriendFeed API +description: + The hs-ffeed API binding lets you access friendfeed.com's + resources and methods from Haskell. Implements the + full API, as specified at http://code.google.com/p/friendfeed-api/wiki/ApiDocumentation + +category: Web +license: BSD3 +license-file: LICENSE +author: Sigbjorn Finne +maintainer: sof@forkio.com +build-depends: base, HTTP, xml +cabal-version: >= 1.2 +build-type: Simple +extra-source-files: README + examples/ShowPublic.hs + examples/Util/GetOpts.hs + +flag new-base + Description: Build with new smaller base library + Default: False + + +library + Exposed-modules: FriendFeed.Types, + FriendFeed.Monad, + FriendFeed.API, + FriendFeed.Entry, + FriendFeed.List, + FriendFeed.Publish, + FriendFeed.Room, + FriendFeed.Search, + FriendFeed.Service, + FriendFeed.Subscribe, + FriendFeed.User, + Util.Codec.Percent, + Util.Codec.URLEncoder, + Util.Fetch + Ghc-Options: -Wall + build-depends: base, HTTP, network, utf8-string, json + + if flag(new-base) + Build-Depends: base >= 3 + else + Build-Depends: base < 3 + +executable main { + build-depends: base + main-is: Main.hs + ghc-options: -Wall -fglasgow-exts +} + +executable showPublic { + build-depends: base, pretty + main-is: examples/ShowPublic.hs + ghc-options: -Wall -fglasgow-exts -iexamples +}