ffeed (empty) → 0.2
raw patch · 21 files changed
+1643/−0 lines, 21 filesdep +HTTPdep +basedep +jsonsetup-changed
Dependencies added: HTTP, base, json, network, pretty, utf8-string
Files
- FriendFeed/API.hs +25/−0
- FriendFeed/Entry.hs +55/−0
- FriendFeed/List.hs +34/−0
- FriendFeed/Monad.hs +242/−0
- FriendFeed/Publish.hs +85/−0
- FriendFeed/Room.hs +42/−0
- FriendFeed/Search.hs +35/−0
- FriendFeed/Service.hs +26/−0
- FriendFeed/Subscribe.hs +36/−0
- FriendFeed/Types.hs +281/−0
- FriendFeed/User.hs +87/−0
- LICENSE +27/−0
- Main.hs +6/−0
- README +43/−0
- Setup.hs +8/−0
- Util/Codec/Percent.hs +57/−0
- Util/Codec/URLEncoder.hs +33/−0
- Util/Fetch.hs +134/−0
- examples/ShowPublic.hs +125/−0
- examples/Util/GetOpts.hs +203/−0
- ffeed.cabal +59/−0
+ FriendFeed/API.hs view
@@ -0,0 +1,25 @@+-------------------------------------------------------------------- +-- | +-- Module : FriendFeed.API +-- Description : Toplevel FriendFeed API module. +-- Copyright : (c) Sigbjorn Finne, 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne <sof@forkIO.com> +-- 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
+ FriendFeed/Entry.hs view
@@ -0,0 +1,55 @@+-------------------------------------------------------------------- +-- | +-- Module : FriendFeed.Entry +-- Description : Entry-specific FriendFeed API calls. +-- Copyright : (c) Sigbjorn Finne, 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne <sof@forkIO.com> +-- 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 +
+ FriendFeed/List.hs view
@@ -0,0 +1,34 @@+-------------------------------------------------------------------- +-- | +-- Module : FriendFeed.List +-- Description : Look up FriendFeed lists +-- Copyright : (c) Sigbjorn Finne, 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne <sof@forkIO.com> +-- 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] []
+ FriendFeed/Monad.hs view
@@ -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 <sof@forkIO.com>+-- 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 "<unknown>" (ffErrorLoc x)+ , " Source: " ++ ffErrorSource x+ ])
+ FriendFeed/Publish.hs view
@@ -0,0 +1,85 @@+-------------------------------------------------------------------- +-- | +-- Module : FriendFeed.Publish +-- Description : Posting / publishing to FriendFeed +-- Copyright : (c) Sigbjorn Finne, 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne <sof@forkIO.com> +-- 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)])
+ FriendFeed/Room.hs view
@@ -0,0 +1,42 @@+-------------------------------------------------------------------- +-- | +-- Module : FriendFeed.Room +-- Description : Fetch room-specific FriendFeed info. +-- Copyright : (c) Sigbjorn Finne, 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne <sof@forkIO.com> +-- 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] []
+ FriendFeed/Search.hs view
@@ -0,0 +1,35 @@+-------------------------------------------------------------------- +-- | +-- Module : FriendFeed.Search +-- Description : Search FriendFeed entries +-- Copyright : (c) Sigbjorn Finne, 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne <sof@forkIO.com> +-- 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)
+ FriendFeed/Service.hs view
@@ -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 <sof@forkIO.com>+-- 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"] []+
+ FriendFeed/Subscribe.hs view
@@ -0,0 +1,36 @@+--------------------------------------------------------------------+-- |+-- Module : FriendFeed.Subscribe+-- Description : Control subscriptions to users and rooms.+-- Copyright : (c) Sigbjorn Finne, 2008+-- License : BSD3+--+-- Maintainer: Sigbjorn Finne <sof@forkIO.com>+-- 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")]
+ FriendFeed/Types.hs view
@@ -0,0 +1,281 @@+--------------------------------------------------------------------+-- |+-- Module : FriendFeed.Types+-- Description : Types used in the FriendFeed API+-- Copyright : (c) Sigbjorn Finne, 2008+-- License : BSD3+--+-- Maintainer: Sigbjorn Finne <sof@forkIO.com>+-- 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 = []+ }
+ FriendFeed/User.hs view
@@ -0,0 +1,87 @@+-------------------------------------------------------------------- +-- | +-- Module : FriendFeed.User +-- Description : Fetch user-specific FriendFeed info. +-- Copyright : (c) Sigbjorn Finne, 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne <sof@forkIO.com> +-- 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"] []
+ LICENSE view
@@ -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.
+ Main.hs view
@@ -0,0 +1,6 @@+module Main(main) where + +import FriendFeed.User + +main :: IO () +main = return ()
+ README view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,8 @@+module Main(main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain + +
+ Util/Codec/Percent.hs view
@@ -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
+ Util/Codec/URLEncoder.hs view
@@ -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
+ Util/Fetch.hs view
@@ -0,0 +1,134 @@+-------------------------------------------------------------------- +-- | +-- Module : Util.Fetch +-- Copyright : (c) Sigbjorn Finne, 2008 +-- License : BSD3 +-- +-- Maintainer: Sigbjorn Finne <sof@forkIO.com> +-- 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) + +-}
+ examples/ShowPublic.hs view
@@ -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 <your-username> -k <remote-key> \ + -s twitter -l 2 + + showing the last 2 public tweets. + + where <your-username> and <remote-key> 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 ()
+ examples/Util/GetOpts.hs view
@@ -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
+ ffeed.cabal view
@@ -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 +}