diff --git a/Commands.hs b/Commands.hs --- a/Commands.hs +++ b/Commands.hs @@ -18,7 +18,7 @@ {- | Module : Commands - Copyright : Copyright (C) 2006-2008 John Goerzen + Copyright : Copyright (C) 2006-2010 John Goerzen License : GNU GPL, version 2 or above Maintainer : John Goerzen @@ -35,7 +35,7 @@ import Types import Config -import qualified Commands.Follow +import qualified Commands.FollowBlock import qualified Commands.Ls import qualified Commands.Setup import qualified Commands.Update @@ -43,17 +43,23 @@ --allCommands :: [(String, Command)] allCommands = [Commands.Update.dmsend, - Commands.Follow.follow, + Commands.FollowBlock.block, + Commands.FollowBlock.follow, Commands.Ls.lsarchive, lscommands, Commands.Ls.lsdm, Commands.Ls.lsdmarchive, + Commands.Ls.lsblocking, Commands.Ls.lsfollowers, Commands.Ls.lsfollowing, Commands.Ls.lsrecent, Commands.Ls.lsreplies, + Commands.Ls.lsrt, + Commands.Ls.lsrtarchive, + Commands.Ls.lsrtreplies, Commands.Setup.setup, - Commands.Follow.unfollow, + Commands.FollowBlock.unblock, + Commands.FollowBlock.unfollow, Commands.Update.update ] diff --git a/Commands/Follow.hs b/Commands/Follow.hs deleted file mode 100644 --- a/Commands/Follow.hs +++ /dev/null @@ -1,60 +0,0 @@ -{- -Copyright (C) 2006-2008 John Goerzen - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or -(at your option) any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module Commands.Follow(follow, unfollow) where -import Utils -import System.Log.Logger -import Data.List -import Download - -i = infoM "follow" - -follow = simpleCmd "follow" "Start following someone" - follow_help - [] follow_worker - -follow_worker _ cp ([], [user]) = - do xmlstr <- sendAuthRequest cp ("/friendships/create/" ++ user ++ ".xml") [] [("id", user)] - debugM "follow" $ "Got doc: " ++ xmlstr - -- let doc = getContent . xmlParse "follow" . stripUnicodeBOM $ xmlstr - -- return () - -follow_worker _ _ _ = - permFail "follow: syntax error; see twidge follow --help" - -follow_help = - "Usage: twidge follow username\n\n\ - \will add username to your list of people you follow.\n\n" - - -unfollow = simpleCmd "unfollow" "Stop following someone" - unfollow_help - [] unfollow_worker - -unfollow_worker _ cp ([], [user]) = - do xmlstr <- sendAuthRequest cp ("/friendships/destroy/" ++ user ++ ".xml") [] [("id", user)] - debugM "unfollow" $ "Got doc: " ++ xmlstr - -- let doc = getContent . xmlParse "follow" . stripUnicodeBOM $ xmlstr - -- return () - -unfollow_worker _ _ _ = - permFail "unfollow: syntax error; see twidge unfollow --help" - -unfollow_help = - "Usage: twidge unfollow username\n\n\ - \will remove username from the list of people you follow.\n" diff --git a/Commands/FollowBlock.hs b/Commands/FollowBlock.hs new file mode 100644 --- /dev/null +++ b/Commands/FollowBlock.hs @@ -0,0 +1,64 @@ +{- +Copyright (C) 2006-2009 John Goerzen + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Commands.FollowBlock(follow, unfollow, block, unblock) where +import Utils +import System.Log.Logger +import Data.List +import Download + +i = infoM "followblock" + +follow = simpleCmd "follow" "Start following someone" + follow_help + [] follow_worker +follow_worker = generic_worker "/friendships/create/" "follow" +follow_help = generic_add_help "follow" + +unfollow = simpleCmd "unfollow" "Stop following someone" + unfollow_help + [] unfollow_worker +unfollow_worker = generic_worker "/friendships/destroy/" "unfollow" +unfollow_help = generic_rm_help "follow" + +block = simpleCmd "block" "Start blocking someone" + block_help [] block_worker +block_worker = generic_worker "/blocks/create/" "block" +block_help = generic_add_help "block" + +unblock = simpleCmd "unblock" "Stop blocking someone" + unblock_help [] unblock_worker +unblock_worker = generic_worker "/blocks/destroy/" "unblock" +unblock_help = generic_rm_help "block" + +generic_worker urlbase cmdname _ cp ([], [user]) = + do xmlstr <- sendAuthRequest cp (urlbase ++ user ++ ".xml") [] [("id", user)] + debugM cmdname $ "Got doc: " ++ xmlstr + -- let doc = getContent . xmlParse "follow" . stripUnicodeBOM $ xmlstr + -- return () + +generic_worker _ cmdname _ _ _ = + permFail $ "follow: syntax error; see twidge " ++ cmdname ++ " --help" + +generic_add_help cmd = + "Usage: twidge " ++ cmd ++ " username\n\n\ + \will add username to your list of people you " ++ cmd ++ ".\n\n" + +generic_rm_help cmd = + "Usage: twidge un" ++ cmd ++ " username\n\n\ + \will remove username from the list of people you " ++ cmd ++ ".\n" diff --git a/Commands/Ls.hs b/Commands/Ls.hs --- a/Commands/Ls.hs +++ b/Commands/Ls.hs @@ -16,7 +16,9 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} -module Commands.Ls(lsrecent, lsreplies, lsfollowing, lsfollowers, lsarchive, lsdm, lsdmarchive) where +module Commands.Ls(lsrecent, lsreplies, lsblocking, + lsfollowing, lsfollowers, lsarchive, + lsrt, lsrtreplies, lsrtarchive, lsdm, lsdmarchive) where import Utils import System.Log.Logger import Types @@ -33,17 +35,24 @@ import Control.Monad(when) import HSH import System.Console.GetOpt.Utils -import qualified System.IO.UTF8 as UTF8 +import Network.URI +import Data.Maybe (isJust) i = infoM "ls" +defaultWidth = 80 + stdopts = [Option "a" ["all"] (NoArg ("a", "")) "Show ALL results, not just 1st page\n\ \WARNING: may generate excessive traffic. \ \Use with caution!", Option "l" ["long"] (NoArg ("l", "")) "Long format output -- more info and \ - \tab-separated columns"] + \tab-separated columns", + Option "w" ["width"] (ReqArg (stdRequired "w") "WIDTH") + ("Set the margin at which word-wrapping occurs.\n\ + \Ignored in long format mode. Default is " + ++ show defaultWidth ++ ".")] sinceopts = [ Option "e" ["exec"] (ReqArg (stdRequired "e") "COMMAND") @@ -62,17 +71,6 @@ Option "u" ["unseen"] (NoArg ("u", "")) "Show only items since the last use of --saveid"] -paginated workerfunc cppath cp (args, remainder) - | lookup "a" args == Nothing = - do workerfunc cppath cp (args, remainder) 1 - return () - | otherwise = paginateloop 1 - where paginateloop page = - do r <- workerfunc cppath cp (args, remainder) page - if null r - then return () - else paginateloop (page + 1) - maybeSaveList section cpath cp args [] = return () maybeSaveList section cpath cp args newids = do debugM section $ "maybeSaveList called for " ++ section ++ ": " @@ -81,12 +79,14 @@ where theid = maximum . map (read::String -> Integer) $ newids maybeSave section cpath cp args newid = - case (lookup "s" args, get cp section "lastid") of - (Nothing, _) -> do debugM "maybeSave" "maybeSave: No -s in args" - return () - (_, Left _) -> do debugM "maybeSave" "maybeSave: Will add ID" - saveid - (_, Right x) -> + let sArg = isJust $ lookup "s" args + sConf = isRight True $ get cp "DEFAULT" "savelast" + in case (any id [sArg,sConf], get cp section "lastid") of + (False, _) -> do debugM "maybeSave" "maybeSave: No -s nor savelast" + return () + (True, Left _) -> do debugM "maybeSave" "maybeSave: Will add ID" + saveid + (True, Right x) -> if (read x) > (newid::Integer) then return () else saveid @@ -97,6 +97,8 @@ else add_section cp section cp2 <- set cp2 section "lastid" (show newid) return cp2 + isRight _ (Left _) = False + isRight v1 (Right v2) = v1 == v2 sinceArgs section cp args = case (lookup "u" args, get cp section "lastid") of @@ -105,8 +107,13 @@ (_, Right a) -> [("since_id", strip a)] +screenNameArgs args = + case lookup "U" args of + Nothing -> [] + Just username -> [("screen_name", username)] + -------------------------------------------------- --- lsrecent +-- lsrecent & friends -------------------------------------------------- lsrecent = simpleCmd "lsrecent" "List recent updates from those you follow" @@ -121,9 +128,19 @@ lsarchive = simpleCmd "lsarchive" "List recent status updates you posted yourself" lsarchive_help - (stdopts ++ sinceopts) (paginated (statuses_worker "lsarchive" - "/statuses/user_timeline")) + (stdopts ++ sinceopts ++ usernameopts) + (paginated (statuses_worker "lsarchive" + "/statuses/user_timeline")) + where + usernameopts = [ + Option "U" ["username"] (ReqArg (stdRequired "U") "USERNAME") + "Instead of showing your own updates, show\n\ + \those of the given username." + ] + + + lsdm = simpleCmd "lsdm" "List recent direct messages to you" lsdm_help (stdopts ++ sinceopts) (paginated (dm_worker "lsdm" @@ -134,12 +151,28 @@ (stdopts ++ sinceopts) (paginated (dm_worker "lsdmarchive" "/direct_messages/sent")) +lsrt = simpleCmd "lsrt" "List recent retweets from those you follow" + lsrt_help + (stdopts ++ sinceopts) (paginated (statuses_worker "lsrt" + "/statuses/retweeted_to_me")) + +lsrtarchive = simpleCmd "lsrtarchive" "List recent retweets you made yourself" + lsrtarchive_help + (stdopts ++ sinceopts) (paginated (statuses_worker "lsrtarchive" + "/statuses/retweeted_by_me")) + +lsrtreplies = simpleCmd "lsrtreplies" "List others' retweets of your statuses" + lsrtreplies_help + (stdopts ++ sinceopts) (paginated (statuses_worker "lsrtreplies" + "/statuses/retweets_of_me")) + statuses_worker = generic_worker handleStatus dm_worker = generic_worker handleDM generic_worker procfunc section command cpath cp (args, _) page = do xmlstr <- sendAuthRequest cp (command ++ ".xml") - (("page", show page) : sinceArgs section cp args) + (("page", show page) : sinceArgs section cp args + ++ screenNameArgs args) [] debugM section $ "Got doc: " ++ xmlstr results <- procfunc section cp args xmlstr @@ -174,6 +207,31 @@ \refer to the examples under twidge lsrecent --help, which also pertain\n\ \to lsarchive.\n" +lsrt_help = + "Usage: twidge lsrt [options]\n\n\ + \You can see the 20 most recent retweets posted by those you follow with:\n\n\ + \ twidge lsrt\n\n\ + \For more examples, including how to see only unseen retweets, please\n\ + \refer to the examples under twidge lsrecent --help, which also pertain\n\ + \to lsreplies.\n" + +lsrtreplies_help = + "Usage: twidge lsrtreplies [options]\n\n\ + \You can see the 20 most retweets made of your statuses with:\n\n\ + \ twidge lsrtreplies\n\n\ + \For more examples, including how to see only unseen retweets, please\n\ + \refer to the examples under twidge lsrecent --help, which also pertain\n\ + \to lsreplies.\n" + +lsrtarchive_help = + "Usage: twidge lsrt [options]\n\n\ + \You can see the 20 most recent retweets you made:\n\n\ + \ twidge lsrtarchive\n\n\ + \For more examples, including how to see only unseen retweets, please\n\ + \refer to the examples under twidge lsrecent --help, which also pertain\n\ + \to lsreplies.\n" + + lsdm_help = "Usage: twidge lsdm [options]\n\n\ \You can see the 20 most recent direct messages to you with:\n\n\ @@ -204,7 +262,7 @@ Message {sId = s (tag "id") item, sSender = s (tag "user" /> tag "screen_name") item, sRecipient = "", - sText = s (tag "text") item, + sText = unEsc $ s (tag "text") item, sDate = s (tag "created_at") item} s f item = sanitize $ contentToString (keep /> f /> txt $ item) @@ -214,7 +272,7 @@ Message {sId = s (tag "id") item, sSender = s (tag "sender_screen_name") item, sRecipient = s (tag "recipient_screen_name") item, - sText = s (tag "text") item, + sText = unEsc $ s (tag "text") item, sDate = s (tag "created_at") item} getStatuses = tag "statuses" /> tag "status" @@ -223,20 +281,20 @@ longStatus :: Message -> String longStatus m = printf "%s\t%s\t%s\t%s\t%s\t\n" (sId m) (sSender m) (sRecipient m) (sText m) (sDate m) -shortStatus :: Message -> String -shortStatus m = +shortStatus :: Int -> Message -> String +shortStatus width m = (printf "%-22s %s\n" ("<" ++ sSender m ++ ">") (head wrappedtext)) ++ concatMap (printf "%-22s %s\n" "") (tail wrappedtext) - where wrappedtext = map unwords $ wrapLine (80 - 22 - 2) (words (sText m)) + where wrappedtext = map unwords $ wrapLine (width - 22 - 2) (words (sText m)) -shortDM :: Message -> String -shortDM m = +shortDM :: Int -> Message -> String +shortDM width m = (printf "%-22s %-22s %s\n" ("<" ++ sSender m ++ ">") ("<" ++ sRecipient m ++ ">") (head wrappedtext)) ++ concatMap (printf "%-22s %-22s %s\n" "" "") (tail wrappedtext) - where wrappedtext = map unwords $ wrapLine (80 - 22 - 22 - 3) (words (sText m)) + where wrappedtext = map unwords $ wrapLine (width - 22 - 22 - 3) (words (sText m)) printStatus section cp args m = printGeneric shortStatus longStatus section cp args m @@ -251,8 +309,10 @@ (Just cmd, _) -> runIO $ (cmd, [sId m, sSender m, sRecipient m, sText m, sDate m]) - (Nothing, Nothing) -> UTF8.putStr (shortfunc m) - (Nothing, Just _) -> UTF8.putStr (longfunc m) + (Nothing, Nothing) -> putStr (shortfunc (case lookup "w" args of + Just ws -> read ws + Nothing -> defaultWidth) m) + (Nothing, Just _) -> putStr (longfunc m) Just recipient -> mailto section cp args m recipient where msgid = genMsgId section m cp @@ -278,8 +338,21 @@ "", sText m, "", - "(from " ++ sSender m ++ ")"] + "(from " ++ sSender m ++ ")" + ,"" + ,"Tweet URL: http://twitter.com/" ++ sSender m ++ + "/status/" ++ sId m + ,"Reply URL: http://twitter.com/home?status=@" ++ + escapeURIString isUnreserved (sSender m ++ " ") ++ + "&in_reply_to_status_id=" ++ sId m ++ "&in_reply_to=" ++ + escapeURIString isUnreserved (sSender m) + ,"User home: http://twitter.com/" ++ sSender m + ] +---------------------------------------------------------------------- +-- Follow/block type commands +---------------------------------------------------------------------- + -------------------------------------------------- -- lsfollowing -------------------------------------------------- @@ -287,32 +360,7 @@ lsfollowing = simpleCmd "lsfollowing" "List people you are following" lsfollowing_help stdopts (paginated lsfollowing_worker) - -lsfollowing_worker _ cp (args, user) page = - do xmlstr <- sendAuthRequest cp url [("page", show page)] [] - debugM "lsfollowing" $ "Got doc: " ++ xmlstr - let doc = getContent . xmlParse "lsfollowing" . stripUnicodeBOM $ xmlstr - let users = map procUsers . getUsers $ doc - mapM_ (printUser args) users - return users - - where url = case user of - [] -> "/statuses/friends.xml" - [x] -> "/statuses/friends/" ++ x ++ ".xml" - _ -> error "Invalid args to lsfollowing; see twidge lsfollowing --help" - -printUser args (name, userid) = - case lookup "l" args of - Nothing -> putStrLn name - Just _ -> printf "%s\t%s\n" userid name - -getUsers = tag "users" /> tag "user" - -procUsers :: Content -> (String, String) -procUsers item = - (sanitize $ contentToString (keep /> tag "screen_name" /> txt $ item), - sanitize $ contentToString (keep /> tag "id" /> txt $ item)) - +lsfollowing_worker = genericfb_worker "lsfollowing" "/statuses/friends" lsfollowing_help = "Usage: twidge lsfollowing [options] [username]\n\n\ \If username is given, list the twitter accounts that user is following.\n\ @@ -325,21 +373,81 @@ lsfollowers = simpleCmd "lsfollowers" "List people that follow you" lsfollowers_help stdopts (paginated lsfollowers_worker) +lsfollowers_worker = genericfb_worker "lsfollowers" "/statuses/followers" +lsfollowers_help = + "Usage: twidge lsfollowers [options] [username]\n\n\ + \If username is given, list the twitter accounts that follow the user.\n\ + \Otherwise, list the twitter accounts that follow you.\n" -lsfollowers_worker _ cp (args, user) page = +-------------------------------------------------- +-- lsblocking +-------------------------------------------------- + +lsblocking = simpleCmd "lsblocking" "List people you are blocking" + lsblocking_help + stdopts (paginated lsblocking_worker) +lsblocking_worker = genericfb_worker "lsblocking" "/blocks/blocking" +lsblocking_help = + "Usage: twidge lsblocking [options]\n\n\ + \List the twitter accounts that your account is blocking.\n" + +------------------------------------------------------------ +-- Generic follow/block support +-- urlbase should be "/statuses/followers" or "/statuses/friends" +------------------------------------------------------------ + +genericfb_worker cmdname urlbase _ cp (args, user) page = do xmlstr <- sendAuthRequest cp url [("page", show page)] [] - debugM "lsfollowers" $ "Got doc: " ++ xmlstr - let doc = getContent . xmlParse "lsfollowers" . stripUnicodeBOM $ xmlstr + debugM cmdname $ "Got doc: " ++ xmlstr + let doc = getContent . xmlParse cmdname . stripUnicodeBOM $ xmlstr let users = map procUsers . getUsers $ doc mapM_ (printUser args) users return users where url = case user of - [] -> "/statuses/followers.xml" - [x] -> "/statuses/followers/" ++ x ++ ".xml" - _ -> error "Invalid args to lsfollowers; see twidge lsfollowers --help" + [] -> urlbase ++ ".xml" + [x] -> urlbase ++ "/" ++ x ++ ".xml" + _ -> error $ "Invalid args to " ++ cmdname ++ + "; see twidge " ++ cmdname ++ " --help" + printUser args (name, userid) = + case lookup "l" args of + Nothing -> putStrLn name + Just _ -> printf "%s\t%s\n" userid name -lsfollowers_help = - "Usage: twidge lsfollowers [options] [username]\n\n\ - \If username is given, list the twitter accounts that follow the user.\n\ - \Otherwise, list the twitter accounts that follow you.\n" + getUsers = tag "users" /> tag "user" + + procUsers :: Content -> (String, String) + procUsers item = + (sanitize $ contentToString (keep /> tag "screen_name" /> txt $ item), + sanitize $ contentToString (keep /> tag "id" /> txt $ item)) + +---------------------------------------------------------------------- +-- Generic Utilities +---------------------------------------------------------------------- + +{- | Calls the workerfunc once if --all wasn't given, to load page 1. + +Otherwise, calls workerfunc repeatedly to load all pages, one after another, as +long as it continues to return data. + +Used to wrap around worker functions where multiple pages of data can be +returned. -} +paginated workerfunc cppath cp (args, remainder) + | lookup "a" args == Nothing = + do workerfunc cppath cp (args, remainder) 1 + return () + | otherwise = paginateloop 1 + where paginateloop page = + do r <- workerfunc cppath cp (args, remainder) page + if null r + then return () + else paginateloop (page + 1) + +{- | Twitter has an additional level of escaping for < and > only. +Sigh. -} +unEsc :: String -> String +unEsc [] = [] +unEsc x + | "<" `isPrefixOf` x = '<' : unEsc (drop 4 x) + | ">" `isPrefixOf` x = '>' : unEsc (drop 4 x) + | otherwise = head x : unEsc (tail x) diff --git a/Commands/Setup.hs b/Commands/Setup.hs --- a/Commands/Setup.hs +++ b/Commands/Setup.hs @@ -1,5 +1,5 @@ {- -Copyright (C) 2006-2008 John Goerzen +Copyright (C) 2010 John Goerzen This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -26,50 +26,116 @@ import Data.Char import Config import Control.Monad(when) +import Network.OAuth.Consumer +import Data.Maybe +import Network.OAuth.Http.Request +import Network.OAuth.Http.HttpClient +import OAuth +import Data.Binary(encode) +import Control.Monad.Trans +import qualified Control.Monad.State.Class as M i = infoM "setup" +d = debugM "setup" -------------------------------------------------- --- lscasts +-- setup -------------------------------------------------- setup = simpleCmd "setup" "Interactively configure twidge for first-time use" - setup_help - [] setup_worker + setup_help + [] setup_worker setup_worker cpath cp _ = - do when (has_option cp "DEFAULT" "username" || - has_option cp "DEFAULT" "password") - (confirmSetup) - hSetBuffering stdout NoBuffering - putStrLn "\nWelcome to twidge. We will now configure twidge for your" - putStrLn "use. This will be quick and easy!\n" - putStrLn "First, what is your usename?\n" - putStr "Username: " - username <- getLine - putStrLn $ "\nWelcome, " ++ username ++ "! Now I'll need your password.\n" - putStr "Password: " - hSetEcho stdin False - password <- getLine - hSetEcho stdin True - let newcp = forceEither $ set cp "DEFAULT" "username" (esc username) - let newcp' = forceEither $ set newcp "DEFAULT" "password" (esc password) - - writeCP cpath newcp' + do hSetBuffering stdout NoBuffering + when (has_option cp "DEFAULT" "oauthdata") + confirmSetup + putStrLn "\nWelcome to twidge. We will now configure twidge for your" + putStrLn "use with Twitter (or a similar service). This will be quick and easy!\n" + putStrLn "\nPlease wait a moment while I query the server...\n\n" - putStrLn "\n\ntwidge has now been configured for you.\n" + app <- case getApp cp of + Nothing -> fail $ "Error: must specify oauthconsumerkey and oauthconsumersecret for non-default host " ++ (serverHost cp) + Just x -> return x + + let reqUrlBase = forceEither $ get cp "DEFAULT" "oauthrequesttoken" + let accUrlBase = forceEither $ get cp "DEFAULT" "oauthaccesstoken" + let authUrlBase = forceEither $ get cp "DEFAULT" "oauthauthorize" + let reqUrl = fromJust . parseURL $ reqUrlBase + let accUrl = fromJust . parseURL $ accUrlBase + let authUrl = ((authUrlBase ++ "?oauth_token=") ++ ) . + findWithDefault ("oauth_token", "") . + oauthParams + + let CurlM resp = + runOAuth $ + do ignite app + liftIO $ d "ignite done. trying request 1." + reqres1 <- tryRequest reqUrl + case reqres1 of + Left x -> -- hack around hoauth bug for identica + do liftIO $ d "request 1 failed. attempting workaround." + putToken $ AccessToken {application = app, + oauthParams = empty} + reqres2 <- tryRequest reqUrl + case reqres2 of + Left x -> fail $ "Error from oauthRequest: " ++ show x + Right _ -> return () + Right _ -> return () + twidgeAskAuthorization authUrl + oauthRequest HMACSHA1 Nothing accUrl + tok <- getToken + return (twoLegged tok, threeLegged tok, tok) + (leg2, leg3, response) <- resp + -- on successful auth, leg3 is True. Otherwise, it is False. + -- leg1 is always false and r appears to not matter. + d $ show (leg2, leg3, oauthParams response) + if leg3 + then do let newcp = forceEither $ set cp "DEFAULT" "oauthdata" . + esc . show . fixIdentica . toList . oauthParams $ response + writeCP cpath newcp + putStrLn $ "Successfully authenticated!" + putStrLn "Twidge has now been configured for you and is ready to use." + else putStrLn "Authentication failed; please try again" where confirmSetup = - do putStrLn "\nIt looks like you have already configured twidge." + do putStrLn "\nIt looks like you have already authenticated twidge." putStrLn "If we continue, I may remove your existing" - putStrLn "configuration. Would you like to proceed?" + putStrLn "authentication. Would you like to proceed?" putStr "\nYES or NO: " c <- getLine if (map toLower c) == "yes" then return () - else permFail "Aborting configuration at user request." + else permFail "Aborting setup at user request." + tryRequest reqUrl = + do reqres <- oauthRequest HMACSHA1 Nothing reqUrl + liftIO $ d $ "reqres params: " ++ case reqres of + Left x -> " error " ++ x + Right y -> show (oauthParams y) + return reqres + -- Work around a hoauth bug - identica doesn't return + -- oauth_callback_confirmed + fixIdentica :: [(String, String)] -> [(String, String)] + fixIdentica inp = + case lookup "oauth_callback_confirmed" inp of + Nothing -> ("oauth_callback_confirmed", "true") : inp + Just _ -> inp esc x = concatMap fix x fix '%' = "%%" fix x = [x] +twidgeAskAuthorization :: MonadIO m => (Token -> String) -> OAuthMonad m () +twidgeAskAuthorization getUrl = + do token <- M.get + answer <- liftIO $ do putStrLn "OK, next I need you to authorize Twidge to access your account." + putStrLn "Please cut and paste this URL and open it in a web browser:\n" + putStrLn (getUrl token) + putStrLn "\nClick Allow when prompted. You will be given a numeric" + putStrLn "key in your browser window. Copy and paste it here." + putStrLn "(NOTE: some non-Twitter services supply no key; just leave this blank" + putStrLn "if you don't get one.)\n" + putStr "Authorization key: " + getLine + M.put (injectOAuthVerifier answer token) + setup_help = - "Usage: twidge setup\n\n" + "Usage: twidge setup\n\n" diff --git a/Commands/Update.hs b/Commands/Update.hs --- a/Commands/Update.hs +++ b/Commands/Update.hs @@ -21,6 +21,7 @@ import System.Log.Logger import Types import System.Console.GetOpt +import System.Console.GetOpt.Utils import Data.List import Download import Control.Monad(when) @@ -28,13 +29,19 @@ import Data.ConfigFile import MailParser(message) import Text.ParserCombinators.Parsec +#ifdef USE_BITLY +import Network.Bitly (Account(..),bitlyAccount,jmpAccount,shorten) +#endif i = infoM "update" update = simpleCmd "update" "Update your status" update_help [Option "r" ["recvmail"] (NoArg ("m", "")) - "Receive update as body of email on stdin"] + "Receive update as body of email on stdin", + Option "i" ["inreplyto"] (ReqArg (stdRequired "i") "MSGID") + "Indicate this message is in reply to MSGID" + ] update_worker update_worker x cp ([("m", "")], []) = @@ -59,9 +66,21 @@ ([("source", "twidge"), ("status", poststatus)] ++ irt) debugM "update" $ "Got doc: " ++ xmlstr + update_worker x cp ([], []) = do l <- getLine update_worker x cp ([], [l]) + +update_worker x cp ([("i", id )], []) = + do l <- getLine + update_worker x cp ([("i", id)], [l]) + +update_worker _ cp ([("i", id)], [status]) = + do poststatus <- procStatus cp "update" status + xmlstr <- sendAuthRequest cp "/statuses/update.xml" [] + [("source", "Twidge"), ("status", poststatus), ("in_reply_to_status_id", id)] + debugM "update" $ "Got doc: " ++ xmlstr + update_worker _ cp ([], [status]) = do poststatus <- procStatus cp "update" status xmlstr <- sendAuthRequest cp "/statuses/update.xml" [] @@ -72,7 +91,8 @@ procStatus cp section status = do poststatus <- case get cp section "shortenurls" of - Right True -> shortenUrls status + Right True | length status > 140 + -> shortenUrls cp status _ -> return status when (length poststatus > 140) (permFail $ "Your status update was " ++ @@ -96,23 +116,53 @@ debugM "dmsend" $ "Got doc: " ++ xmlstr dmsend_worker _ _ _ = permFail "Syntax error; see twidge dmsend --help" -shortenUrls "" = return "" -shortenUrls status = +shortenUrls _ "" = return "" +shortenUrls cp status = do debugM "update" $ "shortenUrls considering: " ++ show status + shortURL <- chooseShortener cp if match == "" then return before -- No match means no "after" - else do tiny <- mkTinyURL match + else do tiny <- shortURL match debugM "update" $ "Got tinyurl: " ++ show tiny - rest <- shortenUrls after + rest <- shortenUrls cp after return $ before ++ (if (length tiny < length match) then tiny else match) ++ rest where (before, match, after) = status =~ pat - pat = "(http|ftp)://[^ ]+" + pat = "(http|https|ftp)\\://[a-zA-Z0-9\\-\\.]+(:[a-zA-Z0-9]*)?/?([-a-zA-Z0-9:\\._\\?\\,\\'/\\\\\\+&%\\$#\\=~])*" +#ifdef USE_BITLY +chooseShortener cp = do + -- look either for [bitly] or [jmp] section in config + let (sec, newAccount) = if has_section cp "bitly" + then ("bitly", bitlyAccount) + else ("jmp", jmpAccount) + -- [bitly] or [jmp] section should define both login and apikey + let acc = get cp sec "login" >>= \l -> + get cp sec "apikey" >>= \k -> + return $ newAccount { login=l, apikey=k } + return $ case acc of + Left _ -> mkTinyURL -- use default + Right a -> mkBitlyURL a + +mkBitlyURL acc url = do + r <- shorten acc url + case r of + Left e -> permFail e -- report bit.ly errors + Right shorturl -> return shorturl +#else +chooseShortener _ = return mkTinyURL +#endif + mkTinyURL url = - simpleDownload $ "http://tinyurl.com/api-create.php?url=" ++ url + simpleDownload . concat $ "http://is.gd/api.php?longurl=" : map escapeHashes url + where + -- NOTE: This technique works with the is.gd "API" + -- but does not work with the tinyurl.com "API" + escapeHashes :: Char -> String + escapeHashes '#' = "%23" + escapeHashes c = [c] update_help = "Usage: twidge update [status]\n\n\ diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -1,5 +1,5 @@ {- hpodder component -Copyright (C) 2006-2008 John Goerzen +Copyright (C) 2006-2010 John Goerzen This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -18,7 +18,7 @@ {- | Module : Config - Copyright : Copyright (C) 2006-2008 John Goerzen + Copyright : Copyright (C) 2006-2010 John Goerzen License : GNU GPL, version 2 or above Maintainer : John Goerzen @@ -36,10 +36,14 @@ import Data.Either.Utils import Data.String.Utils(strip, split) import System.Posix.Files(rename, setFileCreationMask) +import System.Log.Logger getDefaultCP = do return $ forceEither $ do cp <- set startingcp "DEFAULT" "urlbase" "https://twitter.com" + cp <- set cp "DEFAULT" "oauthrequesttoken" "%(urlbase)s/oauth/request_token" + cp <- set cp "DEFAULT" "oauthaccesstoken" "%(urlbase)s/oauth/access_token" + cp <- set cp "DEFAULT" "oauthauthorize" "%(urlbase)s/oauth/authorize" cp <- set cp "DEFAULT" "sendmail" "/usr/sbin/sendmail" cp <- set cp "DEFAULT" "shortenurls" "yes" return cp @@ -50,16 +54,19 @@ do appdir <- getUserDocumentsDirectory return $ appdir ++ "/.twidgerc" -loadCP cpgiven = +loadCP useDefaultIfMissing cpgiven = do cpname <- case cpgiven of Nothing -> getCPName Just x -> return x defaultcp <- getDefaultCP dfe <- doesFileExist cpname + debugM "Config" $ "CP " ++ cpname ++ " exists? " ++ show dfe if dfe then do cp <- readfile defaultcp cpname return $ forceEither cp - else do fail $ "No config file found at " ++ cpname ++ + else if useDefaultIfMissing + then return defaultcp + else do fail $ "No config file found at " ++ cpname ++ "\nRun twidge setup to configure twidge for use." writeCP cpgiven cp = diff --git a/Download.hs b/Download.hs --- a/Download.hs +++ b/Download.hs @@ -1,5 +1,5 @@ {- hpodder component -Copyright (C) 2006-2007 John Goerzen +Copyright (C) 2006-2010 John Goerzen This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -18,7 +18,7 @@ {- | Module : Download - Copyright : Copyright (C) 2006-2008 John Goerzen + Copyright : Copyright (C) 2006-2010 John Goerzen License : GNU GPL, version 2 or above Maintainer : John Goerzen @@ -32,45 +32,58 @@ module Download(sendAuthRequest, simpleDownload) where import System.Log.Logger import Data.ConfigFile -import HSH -import Data.Either.Utils(forceEither) -import Network.URI import Data.List -import Control.Exception(evaluate) +import Network.URI +import Data.Either.Utils(forceEither) +import Data.Maybe +import Network.OAuth.Http.Request +import Network.OAuth.Http.Response +import Network.OAuth.Consumer +import Network.OAuth.Http.HttpClient(request) +import TwidgeHttpClient +import OAuth +import Data.ByteString.Lazy.UTF8(toString) d = debugM "download" i = infoM "download" -curl = "curl" -curlopts = ["-A", "twidge v1.0.0; Haskell; GHC", -- Set User-Agent - "-s", -- Silent mode - "-S", -- Still show error messages - "-L", -- Follow redirects - "-y", "60", "-Y", "1", -- Timeouts - "--retry", "2", -- Retry twice - "-f" -- Fail on server errors - ] - simpleDownload :: String -> IO String -simpleDownload url = run (curl, curlopts ++ [url]) +simpleDownload url = + do r <- resp + d $ "simpleDownload response from URL " ++ show url ++ ": " ++ show r + return . toString . rspPayload $ r + where CurlM resp = request (fromJust $ parseURL url) sendAuthRequest :: ConfigParser -> String -> [(String, String)] -> [(String, String)] -> IO String sendAuthRequest cp url getopts postoptlist = - do -- Force this to be evaluated in the parent process - authopts <- evaluate (getAuthOpts cp) - run (curl, curlopts ++ authopts ++ postopts ++ [urlbase ++ url ++ optstr]) + do app <- case getApp cp of + Nothing -> fail $ "Error: auth not set up for this host" + Just x -> return x + oauthdata <- case get cp "DEFAULT" "oauthdata" of + Left x -> fail $ "Need to (re-)run twidge setup to configure auth: " + ++ show x + Right y -> return y + + let parsedUrl = fromJust . parseURL $ urlbase ++ url ++ optstr + + -- add to the request the POST headers + let request = parsedUrl {reqHeaders = + fromList (toList (reqHeaders parsedUrl) ++ + postoptlist) + } + + let CurlM resp = runOAuth $ + do ignite app + putToken $ AccessToken + {application = app, + oauthParams = fromList (read oauthdata) + } + serviceRequest HMACSHA1 Nothing request + r <- resp + d $ "response: " ++ show r + return . toString . rspPayload $ r where urlbase = forceEither $ get cp "DEFAULT" "urlbase" optstr = case getopts of [] -> "" _ -> "?" ++ (concat . intersperse "&" . map conv $ getopts) conv (k, v) = k ++ "=" ++ escapeURIString isUnreserved v - postopts = concatMap postopt postoptlist - postopt (k, v) = ["-d", escapeURIString isUnreserved k ++ "=" ++ - escapeURIString isUnreserved v] - -getAuthOpts :: ConfigParser -> [String] -getAuthOpts cp = - case (get cp "DEFAULT" "username", get cp "DEFAULT" "password") of - (Right user, Right pass) -> - ["--user", user ++ ":" ++ pass] - _ -> error "Missing username or password option in config file" diff --git a/doc/twidge-manpage.sgml b/doc/twidge-manpage.sgml --- a/doc/twidge-manpage.sgml +++ b/doc/twidge-manpage.sgml @@ -96,7 +96,7 @@ seen already and suppress those updates in future runs. - Optional automatic shortening of long URLs via tinyurl.com + Optional automatic shortening of long URLs via is.gd Optional integration with your email system -- send and receive updates via email. @@ -143,7 +143,7 @@ To get started, simply run twidge setup at your shell prompt. &twidge; will lead you through the first-time - configuration -- which is only two questions and completely + configuration -- which is very quick and completely self-explanatory! @@ -266,7 +266,9 @@ They all share a common syntax and common set of options. The commands are lsarchive, lsdm, lsdmarchive, - lsrecent, and lsreplies. + lsrecent, lsreplies, + lsrt, lsrtarchive, + and lsrtreplies. Here are the common options: @@ -392,12 +394,6 @@ of -s with this particular command. If -s has never before been used with this command, has no effect. - - As of September 2008, Identi.ca does not support the - since_id parameter that is required for this option to be - effective. A future version of &twidge; may implement a - workaround. - @@ -411,8 +407,21 @@ lsarchive - Lists your own posts. + Lists your own posts. With the one + lsarchive option, you can also list the + posts of a specific other user: + + + -U USERNAME + --username=USERNAME + + Instead of showing your own updates, instead show those of + a differerent user. + + + + @@ -447,6 +456,40 @@ to you. + + + lsrt + + Lists new-style retweets made by those that you follow. + + + Note: identi.ca doesn't support new-style retweets and will + return an error on this command. + + + + + lsrtarchive + + Lists the new-style retweets you made yourself. + + + Note: identi.ca doesn't support new-style retweets and will + return an error on this command. + + + + + lsrtreplies + + List retweets of your statuses made by others. + + + Note: identi.ca doesn't support new-style retweets and will + return an error on this command. + + + @@ -516,7 +559,7 @@ By default, Twidge will attempt to shorten URLs in your - updates via the TinyURL.com service. You can disable this by + updates via the is.gd service. You can disable this by setting shortenurls = no in the [DEFAULT] or [dmsend] section of your configuration file. @@ -562,6 +605,8 @@ update twidge update + -i MSGID | + --inreplyto MSGID status @@ -607,6 +652,11 @@ your signature as well. &twidge; will convert newline characters to spaces when processing your message body. + + When -i is given, the internal Twitter ID of a message is + expected to be passed. This sets the "in reply to" flag on + Twitter appropriately. + @@ -640,8 +690,8 @@ The section named DEFAULT is special in that it provides defaults that will be used whenever an option can't be found under a different section. If you specify no section names, - DEFAULT is the assumed section. Some items, such as username, - password, and urlbase are assumed to be in DEFAULT. + DEFAULT is the assumed section. Some items, such as urlbase, + are assumed to be in DEFAULT. Let's start by looking at an example file, and then proceed to @@ -650,11 +700,6 @@ DEFAULT section. If it still doesn't find an - answer, it consults its built-in defaults. The only built-in - default at present is urlbase. + answer, it consults its built-in defaults. General Options @@ -684,16 +728,6 @@ section. - username - - Your username on the microblogging site. No default. - - - password - - Your password on the microblogging site. No default. - - urlbase The URL to access the API of the microblogging site. @@ -703,6 +737,50 @@ trailing slash on this option. + oauthrequesttoken + + The URL to access the oAuth request token interface. The + default, + %(urlbase)s/oauth/request_token, will + work with most environments. + + + + oauthaccesstoken + + The oAuth access token URL. Default is + %(urlbase)s/oauth/access_token. + + + oauthauthorize + + The oAuth authorize URL. Default is + %(urlbase)s/oauth/authorize. + + + + oauthconsumerkey + + The oAuth consumer key. Twidge is registered with + Twitter and identi.ca and will supply a reasonable + default for those two based on the content of urlbase. + + + + oauthconsumersecret + + The oAuth consumer secret. A default is provided as + with oauthconsumerkey. + + + + oauthdata + + Automatically written by twidge + setup. Do not alter. + + + @@ -742,6 +820,16 @@ + savelast + + For one of the "ls" class of commands, implies -s on + every invocation, rather than require it to be manually + given. This option need only be present; the value you + give it doesn't mater. + + + + sendmail Stores the path to the sendmail executable on your @@ -766,6 +854,36 @@ + + URL Shortening Options + + To enable the bit.ly or j.ump URL shorteners, you must add a + [bitly] or [jmp] section + to the configuration file. This should contain two entries: + login and apikey as + found in . For + example: + + +[jmp] +login: bitlyapidemo +apikey: R_0da49e0a9118ff35f52f629d2d71bf07 + + + + + Aliases + + You can add an [alias] section to the + config file which will effectively create new commands. For + example: + + +[alias] +recent: lsrecent -u +replies: lsreplies -u + + diff --git a/twidge.bash_completion b/twidge.bash_completion new file mode 100644 --- /dev/null +++ b/twidge.bash_completion @@ -0,0 +1,31 @@ +#-*- mode: shell-script;-*- + +# twidge command line completion. +# Copyright 2010 Ernesto Hernández-Novich +# Licensed under the GNU General Public License, version 2 + +have twidge && +_twidge() +{ + local cur + cur=${COMP_WORDS[COMP_CWORD]} + + COMPREPLY=() + + if (($COMP_CWORD == 1)); then + COMPREPLY=( $( twidge lscommands | tail --lines=+4 | cut -f1 -d' '| grep "^$cur" ) ) + return 0 + fi + + local i=${#COMPREPLY[*]} + local colonprefixes=${cur%"${cur##*:}"} + while [ $((--i)) -ge 0 ]; do + COMPREPLY[$i]=`printf %q "${COMPREPLY[$i]}"` + + COMPREPLY[$i]=${COMPREPLY[$i]#"$colonprefixes"} + done + return 0 + +} +[ "$have" ] && complete -F _twidge -o default twidge + diff --git a/twidge.cabal b/twidge.cabal --- a/twidge.cabal +++ b/twidge.cabal @@ -1,5 +1,5 @@ Name: twidge -Version: 0.99.3 +Version: 1.0.0 License: GPL Maintainer: John Goerzen Author: John Goerzen @@ -11,7 +11,8 @@ doc/man.twidge.sgml, doc/printlocal.dsl, doc/sgml-common/COPYING, doc/sgml-common/COPYRIGHT, doc/sgml-common/ChangeLog, doc/sgml-common/Makefile.common, doc/sgml-common/SConstruct, - doc/sgml-common/ps2epsi + doc/sgml-common/ps2epsi, + twidge.bash_completion homepage: http://software.complete.org/twidge Build-type: Simple Category: Network @@ -38,15 +39,27 @@ how to use it, can be found at the twidge website at http://software.complete.org/twidge. -Build-Depends: network, unix, parsec, MissingH>=1.0.0, - mtl, base, HaXml>=1.13.2, HaXml<1.19, hslogger, - ConfigFile, directory, HSH, regex-posix, utf8-string +Cabal-Version: >=1.2.3 -Executable: twidge -Main-Is: twidge.hs -Other-Modules: Commands, Commands.Follow, Commands.Ls, +Flag withBitly + description: Enable bit.ly and j.mp shorteners (requires Bitly module) + default: False + + +Executable twidge + Build-Depends: network, unix, parsec, MissingH>=1.0.0, + mtl, base >= 4 && < 5, HaXml>=1.13.2, HaXml<1.19, hslogger, hoauth, + ConfigFile, directory, HSH, regex-posix, utf8-string, binary, + bytestring, curl + + if flag(withBitly) + Build-Depends: Bitly + CPP-OPTIONS: USE_BITLY + + Main-Is: twidge.hs + Other-Modules: Commands, Commands.FollowBlock, Commands.Ls, Commands.Setup, Commands.Update, Config, Download, FeedParser, MailParser, Types, Utils -GHC-Options: -O2 -Extensions: ExistentialQuantification, OverlappingInstances, - UndecidableInstances + GHC-Options: -O2 + Extensions: ExistentialQuantification, OverlappingInstances, + UndecidableInstances, CPP diff --git a/twidge.hs b/twidge.hs --- a/twidge.hs +++ b/twidge.hs @@ -40,7 +40,7 @@ import Commands import Types import Control.Monad -import Data.ConfigFile(emptyCP) +import Data.ConfigFile(emptyCP,get) import System.IO import Paths_twidge(version) import Data.Version @@ -58,6 +58,8 @@ "Use specified config file", Option "" ["help"] (NoArg ("help", "")) "Display this help"] +expandAlias cp cmd = either (const cmd) id $ get cp "alias" cmd + worker args commandargs = do when (lookup "help" args == Just "") $ usageerror "" when (lookup "d" args == Just "") @@ -65,13 +67,17 @@ handler <- streamHandler stderr DEBUG -- stdout has issues with HSH updateGlobalLogger "" (setHandlers [handler]) let commandname = head cmdargs - case lookup commandname allCommands of - Just command -> - do cp <- if commandname `elem` ["lscommands", "setup"] -- no config file needed - then return emptyCP - else loadCP (lookup "c" args) - execcmd command (tail cmdargs) (lookup "c" args) cp - Nothing -> usageerror ("Invalid command name " ++ commandname) + cp <- if commandname `elem` ["lscommands", "setup"] -- no config file needed + then loadCP True (lookup "c" args) + else loadCP False (lookup "c" args) + let cmdargs' = (words $ expandAlias cp commandname) ++ (tail cmdargs) + let commandname' = head cmdargs' + case lookup commandname' allCommands of + Just command -> execcmd command (tail cmdargs') (lookup "c" args) cp + Nothing -> if commandname == commandname' + then usageerror ("Invalid command name " ++ commandname) + else usageerror ("Invalid command name " ++ commandname + ++ " (aliased to " ++ commandname' ++ ")") where cmdargs = case commandargs of [] -> ["help"] x -> x