diff --git a/Commands.hs b/Commands.hs --- a/Commands.hs +++ b/Commands.hs @@ -33,7 +33,6 @@ import Text.Printf import Utils import Types -import Config import qualified Commands.FollowBlock import qualified Commands.Ls @@ -54,9 +53,8 @@ Commands.Ls.lsfollowing, Commands.Ls.lsrecent, Commands.Ls.lsreplies, - Commands.Ls.lsrt, - Commands.Ls.lsrtarchive, Commands.Ls.lsrtreplies, + Commands.Ls.status, Commands.Setup.setup, Commands.FollowBlock.unblock, Commands.FollowBlock.unfollow, diff --git a/Commands/FollowBlock.hs b/Commands/FollowBlock.hs --- a/Commands/FollowBlock.hs +++ b/Commands/FollowBlock.hs @@ -19,7 +19,6 @@ module Commands.FollowBlock(follow, unfollow, block, unblock) where import Utils import System.Log.Logger -import Data.List import Download import Network.OAuth.Http.Request @@ -28,31 +27,34 @@ follow = simpleCmd "follow" "Start following someone" follow_help [] follow_worker -follow_worker = generic_worker POST "/friendships/create/" "follow" +follow_worker = generic_worker POST "/friendships/create.json" "follow" follow_help = generic_add_help "follow" unfollow = simpleCmd "unfollow" "Stop following someone" unfollow_help [] unfollow_worker -unfollow_worker = generic_worker POST "/friendships/destroy/" "unfollow" +unfollow_worker = generic_worker POST "/friendships/destroy.json" "unfollow" unfollow_help = generic_rm_help "follow" block = simpleCmd "block" "Start blocking someone" block_help [] block_worker -block_worker = generic_worker POST "/blocks/create/" "block" +block_worker = generic_worker POST "/blocks/create.json" "block" block_help = generic_add_help "block" unblock = simpleCmd "unblock" "Stop blocking someone" unblock_help [] unblock_worker -unblock_worker = generic_worker POST "/blocks/destroy/" "unblock" +unblock_worker = generic_worker POST "/blocks/destroy.json" "unblock" unblock_help = generic_rm_help "block" -generic_worker method urlbase cmdname _ cp ([], [user]) = - do xmlstr <- sendAuthRequest method cp (urlbase ++ user ++ ".xml") [] [("id", user)] - debugM cmdname $ "Got doc: " ++ xmlstr - -- let doc = getContent . xmlParse "follow" . stripUnicodeBOM $ xmlstr +generic_worker method url cmdname _ cp ([], [user_string]) = + do let user = strip_at user_string + json <- sendAuthRequest method cp url [] [("screen_name", user)] + debugM cmdname $ "Got doc: " ++ show json -- return () - + + where strip_at ('@':u) = u + strip_at u = u + generic_worker _ _ cmdname _ _ _ = permFail $ "follow: syntax error; see twidge " ++ cmdname ++ " --help" diff --git a/Commands/Ls.hs b/Commands/Ls.hs --- a/Commands/Ls.hs +++ b/Commands/Ls.hs @@ -18,16 +18,13 @@ module Commands.Ls(lsrecent, lsreplies, lsblocking, lsfollowing, lsfollowers, lsarchive, - lsrt, lsrtreplies, lsrtarchive, lsdm, lsdmarchive) where + lsrtreplies, status, lsdm, lsdmarchive) where import Utils import System.Log.Logger import Types import Text.Printf import System.Console.GetOpt -import Data.List -import Text.XML.HaXml hiding (when) import Download -import FeedParser import Data.ConfigFile import Data.String.Utils(strip) import Config @@ -36,8 +33,11 @@ import HSH import System.Console.GetOpt.Utils import Network.URI -import Data.Maybe (isJust) +import Data.Maybe (isJust, isNothing) import Network.OAuth.Http.Request +import Data.Time.Format (formatTime, parseTime) +import Data.Time.LocalTime (ZonedTime) +import System.Locale (defaultTimeLocale, rfc822DateFormat) i = infoM "ls" @@ -50,10 +50,12 @@ Option "l" ["long"] (NoArg ("l", "")) "Long format output -- more info and \ \tab-separated columns", - Option "w" ["width"] (ReqArg (stdRequired "w") "WIDTH") + widthopt] + +widthopt = 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 ++ ".")] + ++ show defaultWidth ++ ".") sinceopts = [ Option "e" ["exec"] (ReqArg (stdRequired "e") "COMMAND") @@ -101,8 +103,9 @@ isRight _ (Left _) = False isRight v1 (Right v2) = v1 == v2 -sinceArgs section cp args = - case (lookup "u" args, get cp section "lastid") of +sinceArgs section cp args maxId = from ++ since where + from = maybe [] (\i -> [("max_id", show i)]) maxId + since = case (lookup "u" args, get cp section "lastid") of (Nothing, _) -> [] (_, Left _) -> [] (_, Right a) -> @@ -117,15 +120,15 @@ -- lsrecent & friends -------------------------------------------------- -lsrecent = simpleCmd "lsrecent" "List recent updates from those you follow" +lsrecent = simpleCmd "lsrecent" "List recent updates from your home timeline" lsrecent_help (stdopts ++ sinceopts) (paginated (statuses_worker "lsrecent" - "/statuses/friends_timeline")) + "/statuses/home_timeline")) -lsreplies = simpleCmd "lsreplies" "List recent replies to you" +lsreplies = simpleCmd "lsreplies" "List recent messages mentioning you" lsreplies_help (stdopts ++ sinceopts) (paginated (statuses_worker "lsreplies" - "/statuses/replies")) + "/statuses/mentions_timeline")) lsarchive = simpleCmd "lsarchive" "List recent status updates you posted yourself" lsarchive_help @@ -139,8 +142,9 @@ \those of the given username." ] - - +status = simpleCmd "status" "Retrieve a single status" + status_help + [widthopt] status_worker lsdm = simpleCmd "lsdm" "List recent direct messages to you" lsdm_help @@ -152,38 +156,45 @@ (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 +statuses_worker = generic_worker handleStatuses dm_worker = generic_worker handleDM -generic_worker procfunc section command cpath cp (args, _) page = - do xmlstr <- sendAuthRequest GET cp (command ++ ".xml") - (("page", show page) : sinceArgs section cp args - ++ screenNameArgs args) - [] - debugM section $ "Got doc: " ++ xmlstr - results <- procfunc section cp args xmlstr - when (page == 1) $ - maybeSaveList section cpath cp args (map sId results) - return results +status_worker _ cp (args, [statusId]) = do + json <- sendAuthRequest GET cp "/statuses/show.json" + [("id", statusId)] [] + debugM "status" $ "Got doc: " ++ show json + let TimelineMessage status = decode_json json + printStatus "status" cp args status +status_worker _ _ _ = error "Invalid args to status; see twidge status --help" + +handleStatuses = handleGeneric (map fromTimeline) printStatus + +generic_worker procfunc section command cpath cp (args, _) maxId = do + json <- sendAuthRequest GET cp (command ++ ".json") + (sinceArgs section cp args maxId + ++ screenNameArgs args) [] + debugM section $ "Got doc: " ++ show json + results <- procfunc section cp args json + when (isNothing maxId) $ + maybeSaveList section cpath cp args (map sId results) + return (results, nextMaxId results) + +nextMaxId :: [Message] -> Maybe Integer +nextMaxId [] = Nothing +nextMaxId r = Just ((minimum $ map (read . sId) r) - 1) + +status_help = + "Usage: twidge status [options] status-id\n" + lsrecent_help = "Usage: twidge lsrecent [options]\n\n\ - \You can see the 20 most recent items from your friends with:\n\n\ + \You can see the 20 most recent items from your timeline with:\n\n\ \ twidge lsrecent\n\n\ \To see items that you haven't seen yet, and remember this for the future,\n\ \use:\n\n\ @@ -194,9 +205,9 @@ lsreplies_help = "Usage: twidge lsreplies [options]\n\n\ - \You can see the 20 most recent @replies from others to you with:\n\n\ + \You can see the 20 most recent @mentions from others of you with:\n\n\ \ twidge lsreplies\n\n\ - \For more examples, including how to see only unseen replies, please\n\ + \For more examples, including how to see only unseen mentions, please\n\ \refer to the examples under twidge lsrecent --help, which also pertain\n\ \to lsreplies.\n" @@ -208,14 +219,6 @@ \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\ @@ -224,15 +227,7 @@ \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\ @@ -249,36 +244,13 @@ \refer to the examples under twidge lsrecent --help, which also pertain\n\ \to lsdmarchive.\n" -handleStatus = handleGeneric (map procStatuses . getStatuses) printStatus -handleDM = handleGeneric (map procDM . getDMs) printDM +handleDM = handleGeneric (map fromDM) printDM -handleGeneric pfunc printfunc section cp args xmlstr = - let doc = getContent . xmlParse section . stripUnicodeBOM $ xmlstr - statuses = pfunc doc +handleGeneric pfunc printfunc section cp args json = + let statuses = pfunc $ decode_json json in do mapM_ (printfunc section cp args) statuses return statuses -procStatuses :: Content -> Message -procStatuses item = - Message {sId = s (tag "id") item, - sSender = s (tag "user" /> tag "screen_name") item, - sRecipient = "", - sText = unEsc $ s (tag "text") item, - sDate = s (tag "created_at") item} - -s f item = sanitize $ contentToString (keep /> f /> txt $ item) - -procDM :: Content -> Message -procDM item = - Message {sId = s (tag "id") item, - sSender = s (tag "sender_screen_name") item, - sRecipient = s (tag "recipient_screen_name") item, - sText = unEsc $ s (tag "text") item, - sDate = s (tag "created_at") item} - -getStatuses = tag "statuses" /> tag "status" -getDMs = tag "direct-messages" /> tag "direct_message" - 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) @@ -315,7 +287,6 @@ Nothing -> defaultWidth) m) (Nothing, Just _) -> putStr (longfunc m) Just recipient -> mailto section cp args m recipient - where msgid = genMsgId section m cp mailto section cp args m recipient = runIO $ echo (message ++ "\n") -|- (sendmail, ["-t"]) @@ -328,6 +299,10 @@ Right x -> ["From: " ++ (sSender m) ++ " <" ++ x ++ ">", "Subject: " ++ subject] ) ++ + (case twitterToRFC822 (sDate m) of + Just d -> [ "Date: " ++ d ] + Nothing -> [] + ) ++ ["Message-ID: " ++ msgid, "X-Twidge-urlbase: " ++ forceEither (get cp "DEFAULT" "urlbase"), "X-Twidge-server-base: " ++ serverHost cp, @@ -349,6 +324,11 @@ escapeURIString isUnreserved (sSender m) ,"User home: http://twitter.com/" ++ sSender m ] + twitterToRFC822 d = + formatTime defaultTimeLocale rfc822DateFormat `fmap` time + where + time :: Maybe ZonedTime + time = parseTime defaultTimeLocale "%a %b %e %H:%M:%S %Z %Y" d ---------------------------------------------------------------------- -- Follow/block type commands @@ -361,7 +341,7 @@ lsfollowing = simpleCmd "lsfollowing" "List people you are following" lsfollowing_help stdopts (paginated lsfollowing_worker) -lsfollowing_worker = genericfb_worker "lsfollowing" "/statuses/friends" +lsfollowing_worker = genericfb_worker "lsfollowing" "/friends/list.json" lsfollowing_help = "Usage: twidge lsfollowing [options] [username]\n\n\ \If username is given, list the twitter accounts that user is following.\n\ @@ -374,7 +354,7 @@ lsfollowers = simpleCmd "lsfollowers" "List people that follow you" lsfollowers_help stdopts (paginated lsfollowers_worker) -lsfollowers_worker = genericfb_worker "lsfollowers" "/statuses/followers" +lsfollowers_worker = genericfb_worker "lsfollowers" "/followers/list.json" lsfollowers_help = "Usage: twidge lsfollowers [options] [username]\n\n\ \If username is given, list the twitter accounts that follow the user.\n\ @@ -387,27 +367,27 @@ lsblocking = simpleCmd "lsblocking" "List people you are blocking" lsblocking_help stdopts (paginated lsblocking_worker) -lsblocking_worker = genericfb_worker "lsblocking" "/blocks/blocking" +lsblocking_worker = genericfb_worker "lsblocking" "/blocks/list.json" 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 GET cp url [("page", show page)] [] - debugM cmdname $ "Got doc: " ++ xmlstr - let doc = getContent . xmlParse cmdname . stripUnicodeBOM $ xmlstr - let users = map procUsers . getUsers $ doc +genericfb_worker cmdname url _ cp (args, user) page = + do json <- sendAuthRequest GET cp url params [] + debugM cmdname $ "Got doc: " ++ show json + let UserList doc nextPage = decode_json json + let users = map fromListedUser doc mapM_ (printUser args) users - return users - - where url = case user of - [] -> urlbase ++ ".xml" - [x] -> urlbase ++ "/" ++ x ++ ".xml" + return (users, nextPage) + where params = pageParams ++ targetParams + pageParams = maybe [] (\c -> [("cursor", c)]) page + targetParams = case user of + [] -> [] + [x] -> [("screen_name", x)] _ -> error $ "Invalid args to " ++ cmdname ++ "; see twidge " ++ cmdname ++ " --help" printUser args (name, userid) = @@ -415,13 +395,6 @@ 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)) - ---------------------------------------------------------------------- -- Generic Utilities ---------------------------------------------------------------------- @@ -435,20 +408,11 @@ returned. -} paginated workerfunc cppath cp (args, remainder) | lookup "a" args == Nothing = - do workerfunc cppath cp (args, remainder) 1 + do workerfunc cppath cp (args, remainder) Nothing return () - | otherwise = paginateloop 1 + | otherwise = paginateloop Nothing where paginateloop page = - do r <- workerfunc cppath cp (args, remainder) page + do (r, nextPage) <- 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) + else paginateloop nextPage diff --git a/Commands/Setup.hs b/Commands/Setup.hs --- a/Commands/Setup.hs +++ b/Commands/Setup.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} {- -Copyright (C) 2010 John Goerzen +Copyright (C) 2010-2013 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 @@ -35,6 +35,7 @@ import Data.Binary(encode) import Control.Monad.Trans import qualified Control.Monad.State.Class as M +import Download(twidgeCurlClient) i = infoM "setup" d = debugM "setup" @@ -67,47 +68,34 @@ 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 -#if MIN_VERSION_hoauth(0,2,4) - AccessToken _ _ -> return () - _ -> -- hack around hoauth bug for identica -#else - Left x -> -- hack around hoauth bug for identica -#endif - do liftIO $ d "request 1 failed. attempting workaround." - putToken $ AccessToken {application = app, - oauthParams = empty} - reqres2 <- tryRequest reqUrl - case reqres2 of -#if MIN_VERSION_hoauth(0,2,4) - AccessToken _ _ -> return () - _ -> fail $ "Error from oauthRequest." -#else - Left x -> fail $ "Error from oauthRequest: " ++ show x - Right _ -> return () - Right _ -> return () -#endif + + let resp = + runOAuthM (fromApplication app) $ + do liftIO $ d "Trying first signRq2" + reqres1 <- signRq2 HMACSHA1 Nothing reqUrl + liftIO $ d $ "First signRq2 result: " ++ (show reqres1) + oauthRequest twidgeCurlClient reqres1 + twidgeAskAuthorization authUrl - oauthRequest HMACSHA1 Nothing accUrl + + liftIO $ d "Trying second signRq2" + reqres2 <- signRq2 HMACSHA1 Nothing accUrl + liftIO $ d $ "Second signRq2 result: " ++ show reqres2 + oauthRequest twidgeCurlClient reqres2 + + 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" + return tok + tok <- resp + d $ "Got token: " ++ show tok + case tok of + AccessToken _ _ -> do + let newcp = forceEither $ set cp "DEFAULT" "oauthdata" . + esc . show . toList . oauthParams $ tok + writeCP cpath newcp + putStrLn $ "Successfully authenticated!" + putStrLn "Twidge has now been configured for you and is ready to use." + _ -> putStrLn "Authentication failed; please try again" where confirmSetup = do putStrLn "\nIt looks like you have already authenticated twidge." putStrLn "If we continue, I may remove your existing" @@ -117,30 +105,14 @@ if (map toLower c) == "yes" then return () else permFail "Aborting setup at user request." - tryRequest reqUrl = - do reqres <- oauthRequest HMACSHA1 Nothing reqUrl -#if MIN_VERSION_hoauth(0,2,4) - liftIO $ d $ "reqres params: " ++ (show (oauthParams reqres)) -#else - liftIO $ d $ "reqres params: " ++ case reqres of - Left x -> " error " ++ x - Right y -> show (oauthParams y) -#endif - 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 :: MonadIO m => (Token -> String) -> OAuthMonadT m () twidgeAskAuthorization getUrl = - do token <- M.get + do token <- getToken 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) @@ -150,7 +122,7 @@ putStrLn "if you don't get one.)\n" putStr "Authorization key: " getLine - M.put (injectOAuthVerifier answer token) + putToken (injectOAuthVerifier answer token) setup_help = "Usage: twidge setup\n\n" diff --git a/Commands/Update.hs b/Commands/Update.hs --- a/Commands/Update.hs +++ b/Commands/Update.hs @@ -23,7 +23,6 @@ import Types import System.Console.GetOpt import System.Console.GetOpt.Utils -import Data.List import Download import Control.Monad(when) import Text.Regex.Posix @@ -34,6 +33,7 @@ #ifdef USE_BITLY import Network.Bitly (Account(..),bitlyAccount,jmpAccount,shorten) #endif +import qualified Codec.Binary.UTF8.String as UTF8 i = infoM "update" d = debugM "update" @@ -46,10 +46,11 @@ "Indicate this message is in reply to MSGID" ] update_worker_wrapper - + update_worker_wrapper x cp args = do d $ "Running update_worker with: " ++ show (x, args) - update_worker x cp args + update_worker x cp (newargs args) + where newargs (opts, status) = (opts, map UTF8.decodeString status) update_worker x cp ([("m", "")], []) = do d "Reading mail message" @@ -70,10 +71,9 @@ else [] status = body in do poststatus <- procStatus cp "update" status - xmlstr <- sendAuthRequest POST cp "/statuses/update.xml" [] - ([("source", "twidge"), ("status", poststatus)] ++ - irt) - debugM "update" $ "Got doc: " ++ xmlstr + json <- sendAuthRequest POST cp "/statuses/update.json" [] + ([("status", poststatus)] ++ irt) + debugM "update" $ "Got doc: " ++ show json update_worker x cp ([], []) = do d "No args reading line" @@ -88,24 +88,27 @@ update_worker _ cp ([("i", id)], [status]) = do d "-i have line" poststatus <- procStatus cp "update" status - xmlstr <- sendAuthRequest POST cp "/statuses/update.xml" [] - [("source", "Twidge"), ("status", poststatus), ("in_reply_to_status_id", id)] - debugM "update" $ "Got doc: " ++ xmlstr + json <- sendAuthRequest POST cp "/statuses/update.json" [] + [("status", poststatus), ("in_reply_to_status_id", id)] + debugM "update" $ "Got doc: " ++ show json update_worker _ cp ([], [status]) = do d "no args have line" poststatus <- procStatus cp "update" status - xmlstr <- sendAuthRequest POST cp "/statuses/update.xml" [] - [("source", "Twidge"), ("status", poststatus)] - debugM "update" $ "Got doc: " ++ xmlstr + json <- sendAuthRequest POST cp "/statuses/update.json" [] + [("status", poststatus)] + debugM "update" $ "Got doc: " ++ show json update_worker _ _ _ = permFail "update: syntax error; see twidge update --help" procStatus cp section status = do poststatus <- case get cp section "shortenurls" of - Right True | length status > 140 - -> shortenUrls cp status - _ -> return status + Right True -> case get cp section "shortenall" of + Right True -> shortenUrls cp status + _ | length status > 140 + -> shortenUrls cp status + _ -> return status + _ -> return status when (length poststatus > 140) (permFail $ "Your status update was " ++ show (length poststatus) ++ @@ -122,10 +125,9 @@ dmsend_worker x cp ([], [r, l]) dmsend_worker x cp ([], [recipient, status]) = do poststatus <- procStatus cp "dmsend" status - xmlstr <- sendAuthRequest POST cp "/direct_messages/new.xml" [] - [("source", "Twidge"), - ("text", poststatus), ("user", recipient)] - debugM "dmsend" $ "Got doc: " ++ xmlstr + json <- sendAuthRequest POST cp "/direct_messages/new.json" [] + [("text", poststatus), ("screen_name", recipient)] + debugM "dmsend" $ "Got doc: " ++ show json dmsend_worker _ _ _ = permFail "Syntax error; see twidge dmsend --help" shortenUrls _ "" = return "" @@ -142,7 +144,7 @@ then tiny else match) ++ rest where (before, match, after) = status =~ pat - pat = "(http|https|ftp)\\://[a-zA-Z0-9\\-\\.]+(:[a-zA-Z0-9]*)?/?([-a-zA-Z0-9:\\._\\?\\,\\'/\\\\\\+&%\\$#\\=~])*" + pat = "(http|https|ftp)\\://[a-zA-Z0-9\\-\\.]+(:[a-zA-Z0-9]*)?/?([-a-zA-Z0-9:()\\._\\?\\,\\'/\\\\\\+&%\\$#\\=~])*" #ifdef USE_BITLY chooseShortener cp = do diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -41,12 +41,13 @@ getDefaultCP = do return $ forceEither $ do cp <- set startingcp "DEFAULT" "serverbase" "https://api.twitter.com" - cp <- set cp "DEFAULT" "urlbase" "%(serverbase)s/1" + cp <- set cp "DEFAULT" "urlbase" "%(serverbase)s/1.1" cp <- set cp "DEFAULT" "oauthrequesttoken" "%(serverbase)s/oauth/request_token" cp <- set cp "DEFAULT" "oauthaccesstoken" "%(serverbase)s/oauth/access_token" cp <- set cp "DEFAULT" "oauthauthorize" "%(serverbase)s/oauth/authorize" cp <- set cp "DEFAULT" "sendmail" "/usr/sbin/sendmail" cp <- set cp "DEFAULT" "shortenurls" "yes" + cp <- set cp "DEFAULT" "shortenall" "no" return cp startingcp = emptyCP {accessfunc = interpolatingAccess 10} diff --git a/Download.hs b/Download.hs --- a/Download.hs +++ b/Download.hs @@ -1,5 +1,5 @@ {- hpodder component -Copyright (C) 2006-2010 John Goerzen +Copyright (C) 2006-2013 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-2010 John Goerzen + Copyright : Copyright (C) 2006-2013 John Goerzen License : GNU GPL, version 2 or above Maintainer : John Goerzen @@ -29,7 +29,8 @@ -} -module Download(sendAuthRequest, simpleDownload) where +module Download(sendAuthRequest, simpleDownload, twidgeCurlClient) where +import Control.Monad(unless) import System.Log.Logger import Data.ConfigFile import Data.List @@ -38,23 +39,44 @@ import Data.Maybe import Network.OAuth.Http.Request import Network.OAuth.Http.Response +import Network.OAuth.Http.CurlHttpClient +import Network.OAuth.Http.HttpClient +import Network.Curl import Network.OAuth.Consumer -import Network.OAuth.Http.HttpClient(request) -import TwidgeHttpClient import OAuth +import Data.ByteString.Lazy(ByteString) import Data.ByteString.Lazy.UTF8(toString) d = debugM "download" i = infoM "download" +twidgeCurlClient :: CurlClient +twidgeCurlClient = OptionsCurlClient + [CurlLowSpeedTime 60 + ,CurlLowSpeed 1 + ,CurlUserAgent "twidge v1.1.0; Haskell. GHC" + ,CurlFollowLocation True -- follow redirects + ,CurlFailOnError True -- fail on server errors + ] + +{- | Download a webpage without using oauth. -} simpleDownload :: String -> IO String 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) + where resp = (runClient_ twidgeCurlClient) (fromJust $ parseURL url) -sendAuthRequest :: Method -> ConfigParser -> String -> [(String, String)] -> [(String, String)] -> IO String +needsUpgrade :: String +needsUpgrade = + unlines $ + ["Your configuration needs to be updated to work with changes at Twitter." + ,"Please edit your configuration file and fix the urlbase option. In most" + ,"cases, you can set it like this:" + ,"" + ,"urlbase: %(serverbase)s/1.1"] + +sendAuthRequest :: Method -> ConfigParser -> String -> [(String, String)] -> [(String, String)] -> IO ByteString sendAuthRequest mth cp url getopts postoptlist = do app <- case getApp cp of Nothing -> fail $ "Error: auth not set up for this host" @@ -64,6 +86,8 @@ ++ show x Right y -> return y + unless (urlbase /= "https://api.twitter.com/1") $ + fail $ needsUpgrade let parsedUrl = fromJust . parseURL $ urlbase ++ url ++ optstr -- add to the request the GET/POST headers @@ -72,17 +96,13 @@ postoptlist) ,method = mth } - - let CurlM resp = runOAuth $ - do ignite app - putToken $ AccessToken - {application = app, - oauthParams = fromList (read oauthdata) - } - serviceRequest HMACSHA1 Nothing request + let token = AccessToken app (fromList (read oauthdata)) + let resp = runOAuthM token $ + do r <- signRq2 HMACSHA1 (Just $ Realm "realm") request + serviceRequest twidgeCurlClient r r <- resp d $ "response: " ++ show r - return . toString . rspPayload $ r + return . rspPayload $ r where urlbase = forceEither $ get cp "DEFAULT" "urlbase" optstr = case getopts of [] -> "" diff --git a/FeedParser.hs b/FeedParser.hs deleted file mode 100644 --- a/FeedParser.hs +++ /dev/null @@ -1,70 +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 : FeedParser - Copyright : Copyright (C) 2006-2008 John Goerzen - License : GNU GPL, version 2 or above - - Maintainer : John Goerzen - Stability : provisional - Portability: portable - -Written by John Goerzen, jgoerzen\@complete.org - --} -module FeedParser where - -import Text.XML.HaXml -import Data.Char -import Data.List -import Data.String.Utils(strip) - -{- | Convert [Content] to a printable string, taking care to unescape it. - -An implementation without unescaping would simply be: - -> contentToString = concatMap (show . content) - -Because HaXml's unescaping only works on Elements, we must make sure that -whatever Content we have is wrapped in an Element, then use txt to -pull the insides back out. -} -contentToString :: [Content] -> String -contentToString = - concatMap procContent - where procContent x = - verbatim $ keep /> txt $ CElem (unesc (fakeElem x)) - - fakeElem :: Content -> Element - fakeElem x = Elem "fake" [] [x] - - unesc :: Element -> Element - unesc = xmlUnEscape stdXmlEscaper - -stripUnicodeBOM :: String -> String -stripUnicodeBOM ('\xef':'\xbb':'\xbf':x) = x -stripUnicodeBOM x = x - -{- | Removes potentially problematic or malicious stuff -} -sanitize :: String -> String -sanitize = strip . map sanitizer - where sanitizer c - | c `elem` "\n\r\0\t" = ' ' - | otherwise = c - -getContent (Document _ _ e _) = CElem e diff --git a/MailParser.hs b/MailParser.hs --- a/MailParser.hs +++ b/MailParser.hs @@ -19,7 +19,7 @@ module MailParser where import Text.ParserCombinators.Parsec import Data.String.Utils -import FeedParser(sanitize) +import Types(sanitize) eol = (string "\r\n") <|> string "\n" diff --git a/OAuth.hs b/OAuth.hs --- a/OAuth.hs +++ b/OAuth.hs @@ -48,6 +48,14 @@ twitterDeObfuscator :: String -> String twitterDeObfuscator = reverse . map rot13 +instance Show Application where + show (Application a b c) = "Application " ++ show a ++ " " ++ show b ++ " " ++ show c + +instance Show Token where + show (TwoLegg app oauthp) = "TwoLegg " ++ show app ++ " " ++ show oauthp + show (ReqToken app oauthp) = "ReqToken " ++ show app ++ " " ++ show oauthp + show (AccessToken app oauthp) = "AccessToken " ++ show app ++ " " ++ show oauthp + rot13 :: Char -> Char rot13 x = case lookup x trans of diff --git a/TwidgeHttpClient.hs b/TwidgeHttpClient.hs deleted file mode 100644 --- a/TwidgeHttpClient.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, CPP #-} - --- Copyright (c) 2009, Diego Souza --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- * 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. --- * Neither the name of the nor the names of its contributors --- may be used to endorse or promote products derived from this software --- without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 COPYRIGHT HOLDER 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. - --- | A type class that is able to perform HTTP requests. -module TwidgeHttpClient (CurlM(..) - ) where - -import Network.Curl -import Control.Monad.Fix -import Network.OAuth.Http.Request -import Network.OAuth.Http.Response -import qualified Network.OAuth.Http.HttpClient -import Control.Monad.Trans -import Data.Char (chr,ord) -import System.Log.Logger -import Network.URI -import qualified Data.ByteString.Lazy as B - -d = debugM "TwidgeHttpClient" - --- | The libcurl backend -newtype CurlM a = CurlM { unCurlM :: IO a } - deriving (Monad,MonadIO,MonadFix,Functor) - -instance Network.OAuth.Http.HttpClient.HttpClient CurlM where -#if MIN_VERSION_hoauth(0,2,4) - unpack = unCurlM -#else - unlift = unCurlM -#endif - - request req = CurlM $ withCurlDo $ do c <- initialize - setopts c opts - d $ "Sending request: " ++ show req - rsp <- perform_with_response_ c - d $ "Got response: " ++ show - (respStatus rsp, respStatusLine rsp, - respHeaders rsp, respBody rsp) - if respStatus rsp < 200 || respStatus rsp >= 300 - then fail $ "Bad response: " ++ show (respStatus rsp) - else return () - return $ RspHttp (respStatus rsp) - (respStatusLine rsp) - (fromList.respHeaders $ rsp) - (B.pack.map (fromIntegral.ord).respBody $ rsp) - where httpVersion = case (version req) - of Http10 -> HttpVersion10 - Http11 -> HttpVersion11 - - url = case method req of - POST -> showURL (req {qString = fromList []}) - _ -> showURL req - curlPostData = case method req of - POST -> [CurlPostFields (map postopt . toList . qString $ req)] - _ -> [] - postopt (k, v) = escapeURIString isUnreserved k ++ "=" ++ - escapeURIString isUnreserved v - - curlMethod = case (method req) - of GET -> [CurlHttpGet True] - POST -> [CurlPost True] - PUT -> [CurlPut True] - HEAD -> [CurlNoBody True,CurlCustomRequest "HEAD"] - other -> if (B.null.reqPayload $ req) - then [CurlHttpGet True,CurlCustomRequest (show other)] - else [CurlPost True,CurlCustomRequest (show other)] - curlHeaders = let headers = (map (\(k,v) -> k++": "++v).toList.reqHeaders $ req) - in [CurlHttpHeaders $"Expect: " - :("Content-Length: " ++ (show.B.length.reqPayload $ req)) - :headers - ] - - opts = [CurlURL (showURL req) - ,CurlHttpVersion httpVersion - ,CurlFollowLocation True -- follow redirects - ,CurlFailOnError True -- fail on server errors - ,CurlLowSpeedTime 60 - ,CurlLowSpeed 1 - ,CurlUserAgent "twidge v1.0.0; Haskell; GHC" - ,CurlHeader False - ] ++ curlHeaders - ++ curlMethod - ++ curlPostData - --- vim:sts=2:sw=2:ts=2:et diff --git a/Types.hs b/Types.hs --- a/Types.hs +++ b/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings, CPP #-} {- hpodder component Copyright (C) 2006-2007 John Goerzen @@ -29,8 +30,34 @@ -} module Types where +import Control.Applicative +import Control.Monad (mzero) import Data.ConfigFile +import Data.Aeson +import Data.ByteString.Lazy (ByteString) +import Data.List (isPrefixOf) +import Data.String.Utils (strip) +import Data.Text (unpack) +decode_json :: FromJSON a => ByteString -> a +decode_json = either error id . eitherDecode + +{- | Removes potentially problematic or malicious stuff -} +sanitize :: String -> String +sanitize = strip . map sanitizer + where sanitizer c + | c `elem` "\n\r\0\t" = ' ' + | otherwise = c + +{- | 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) + data Command = Command {cmdname :: String, cmddescrip :: String, @@ -44,3 +71,55 @@ sDate :: String } deriving (Eq, Read, Show, Ord) + +newtype TimelineMessage = TimelineMessage { fromTimeline :: Message } + +instance FromJSON TimelineMessage where + parseJSON j = TimelineMessage <$> parseTimelineMessage j + +parseTimelineMessage (Object v) = Message <$> + s v "id_str" <*> + (v .: "user" >>= extractScreenName) <*> + pure "" <*> + retweetOrText v <*> + s v "created_at" +parseTimelineMessage _ = mzero + +newtype DirectMessage = DirectMessage { fromDM :: Message } + +instance FromJSON DirectMessage where + parseJSON j = DirectMessage <$> parseDirectMessage j + +parseDirectMessage (Object v) = Message <$> + s v "id_str" <*> + s v "sender_screen_name" <*> + s v "recipient_screen_name" <*> + (unEsc <$> s v "text") <*> + s v "created_at" +parseDirectMessage _ = mzero + +extractScreenName (Object v) = s v "screen_name" +extractScreenName _ = mzero + +retweetOrText v = unEsc <$> ((retweet v) <|> (unpack <$> v .: "text")) where + retweet v = do + rt <- v .: "retweeted_status" + user <- rt .: "user" >>= extractScreenName + text <- rt .: "text" + return $ "RT @" ++ user ++ ": " ++ text + +s v name = sanitize <$> v .: name + +data UserList = UserList [ListedUser] (Maybe String) + +newtype ListedUser = ListedUser { fromListedUser :: (String, String) } + +instance FromJSON UserList where + parseJSON (Object v) = UserList <$> v .: "users" <*> v .:? "next_cursor_str" + parseJSON _ = mzero + +instance FromJSON ListedUser where + parseJSON (Object v) = (ListedUser .) . (,) <$> + v .: "screen_name" <*> + v .: "id_str" + parseJSON _ = mzero diff --git a/doc/twidge-manpage.sgml b/doc/twidge-manpage.sgml --- a/doc/twidge-manpage.sgml +++ b/doc/twidge-manpage.sgml @@ -264,10 +264,9 @@ Several commands can display updates from yourself or others. They all share a common syntax and common set of options. The - commands are lsarchive, + commands are lsdm, lsdmarchive, lsrecent, lsreplies, - lsrt, lsrtarchive, and lsrtreplies. Here are the common options: @@ -404,26 +403,6 @@ are undefined if you use such options simultaneously. - - lsarchive - - 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. - - - - - - lsdm @@ -457,28 +436,6 @@ - - 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 @@ -559,10 +516,21 @@ By default, Twidge will attempt to shorten URLs in your - updates via the is.gd service. You can disable this by - setting shortenurls = no in the [DEFAULT] or [dmsend] section of your - configuration file. + updates via an URL shortening service, but only if your + update's length exceeds 140 characters. This means long + URLs shorter than 140 characters WILL NOT be shortened. + + If you want all your URLs to be shortened all the time + regardless of their length, then set shortenall = yes + in the [DEFAULT] or [dmsend] section of your configuration + file. + + + You can disable URL shortening altogether by setting + shortenurls = no in the [DEFAULT] or [dmsend] section of + your configuration file. + @@ -626,11 +594,22 @@ By default, Twidge will attempt to shorten URLs in your - updates via the TinyURL.com service. You can disable this by - setting shortenurls = no in the [DEFAULT] or [update] section of your - configuration file. + updates via an URL shortening service, but only if your + update's length exceeds 140 characters. This means long + URLs shorter than 140 characters WILL NOT be shortened. + If you want all your URLs to be shortened all the time + regardless of their length, then set shortenall = yes + in the [DEFAULT] or [dmsend] section of your configuration + file. + + + You can disable URL shortening altogether by setting + shortenurls = no in the [DEFAULT] or [dmsend] section of + your configuration file. + + When -r is given, &twidge; expects to read an RFC2822 email message in stdin. The body of the message will be used as the content of the update. The References header of the message @@ -709,9 +688,6 @@ ; Last IDs seen by different commands. Written to with -s. -[lsarchive] -lastid = 917383569 - [lsrecent] lastid = 914881241 ]]> @@ -855,17 +831,34 @@ You may specify shortenurls in the [update] section. It defaults to yes. If set to no, will cause &twidge; to omit its attempt to shorten - URLs in your updates via tinyurl.com. + URLs in your updates. If set to yes, will cause &twidge; to + shorten URLs in your updates, only if the latter's length + exceeds 140 characters. See shortenall + shortenall + + + You may specify shortenall in the + [update] section. It defaults to no. If + set to yes, will cause &twidge; to shorten all URLs in + your updates, all the time. It only makes sense if + shortenurls is set to yes. + + + + URL Shortening Options + + &twidge; uses is.gd as its default URL shortening service. + To enable the bit.ly or j.ump URL shorteners, you must add a [bitly] or [jmp] section diff --git a/twidge.bash_completion b/twidge.bash_completion --- a/twidge.bash_completion +++ b/twidge.bash_completion @@ -4,7 +4,9 @@ # Copyright 2010 Ernesto Hernández-Novich # Licensed under the GNU General Public License, version 2 -have twidge && +: ${have=$(command -v twidge)} + +test -n "$have" && _twidge() { local cur @@ -22,10 +24,10 @@ while [ $((--i)) -ge 0 ]; do COMPREPLY[$i]=`printf %q "${COMPREPLY[$i]}"` - COMPREPLY[$i]=${COMPREPLY[$i]#"$colonprefixes"} + COMPREPLY[$i]=${COMPREPLY[$i]#"$colonprefixes"} done return 0 } -[ "$have" ] && complete -F _twidge -o default twidge +test -n "$have" && complete -F _twidge -o default twidge diff --git a/twidge.cabal b/twidge.cabal --- a/twidge.cabal +++ b/twidge.cabal @@ -1,10 +1,10 @@ Name: twidge -Version: 1.0.6.1 +Version: 1.1.0 License: GPL Maintainer: John Goerzen Author: John Goerzen Stability: Stable -Copyright: Copyright (c) 2006-2010 John Goerzen +Copyright: Copyright (c) 2006-2013 John Goerzen license-file: COPYRIGHT extra-source-files: COPYING, INSTALL, doc/SConstruct, doc/twidge-manpage.sgml, doc/twidge.sgml, doc/local.dsl, @@ -48,9 +48,10 @@ Executable twidge Build-Depends: network, unix, parsec, MissingH>=1.0.0, - mtl, base >= 4 && < 5, HaXml>=1.13.2, HaXml<1.19, hslogger, hoauth>=0.2.3 && <0.2.4, + mtl, base >= 4 && < 5, hslogger, hoauth>=0.3.4 && <0.4, ConfigFile, directory, HSH, regex-posix, utf8-string, binary, - bytestring, curl + bytestring, curl, old-locale, time, aeson>=0.6.1.0 && <0.7, + text>=0.11.2.0 && <0.12 if flag(withBitly) Build-Depends: Bitly @@ -58,8 +59,8 @@ Main-Is: twidge.hs Other-Modules: Commands, Commands.FollowBlock, Commands.Ls, - Commands.Setup, Commands.Update, Config, Download, FeedParser, - MailParser, Types, Utils, OAuth, TwidgeHttpClient + Commands.Setup, Commands.Update, Config, Download, + MailParser, Types, Utils, OAuth GHC-Options: -O2 Extensions: ExistentialQuantification, OverlappingInstances, UndecidableInstances