Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Corrected problem with update and other similar "modify" commands

They were being sent as GET instead of POST.

Changed sendAuthRequest to take an explicit method parameter and
updated the commands to use it.

Fixed TwidgeHttpClient to properly send stuff for POST.

Fixes #11
  • Loading branch information...
commit 0a87c1b18ada43f0a94e435ac8f317883d7b6db7 1 parent df83a79
@jgoerzen authored
View
15 Commands/FollowBlock.hs
@@ -21,38 +21,39 @@ import Utils
import System.Log.Logger
import Data.List
import Download
+import Network.OAuth.Http.Request
i = infoM "followblock"
follow = simpleCmd "follow" "Start following someone"
follow_help
[] follow_worker
-follow_worker = generic_worker "/friendships/create/" "follow"
+follow_worker = generic_worker POST "/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_worker = generic_worker POST "/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_worker = generic_worker POST "/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_worker = generic_worker POST "/blocks/destroy/" "unblock"
unblock_help = generic_rm_help "block"
-generic_worker urlbase cmdname _ cp ([], [user]) =
- do xmlstr <- sendAuthRequest cp (urlbase ++ user ++ ".xml") [] [("id", user)]
+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
-- return ()
-generic_worker _ cmdname _ _ _ =
+generic_worker _ _ cmdname _ _ _ =
permFail $ "follow: syntax error; see twidge " ++ cmdname ++ " --help"
generic_add_help cmd =
View
5 Commands/Ls.hs
@@ -37,6 +37,7 @@ import HSH
import System.Console.GetOpt.Utils
import Network.URI
import Data.Maybe (isJust)
+import Network.OAuth.Http.Request
i = infoM "ls"
@@ -170,7 +171,7 @@ 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")
+ do xmlstr <- sendAuthRequest GET cp (command ++ ".xml")
(("page", show page) : sinceArgs section cp args
++ screenNameArgs args)
[]
@@ -397,7 +398,7 @@ lsblocking_help =
------------------------------------------------------------
genericfb_worker cmdname urlbase _ cp (args, user) page =
- do xmlstr <- sendAuthRequest cp url [("page", show 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
View
31 Commands/Update.hs
@@ -30,11 +30,13 @@ import Text.Regex.Posix
import Data.ConfigFile
import MailParser(message)
import Text.ParserCombinators.Parsec
+import Network.OAuth.Http.Request
#ifdef USE_BITLY
import Network.Bitly (Account(..),bitlyAccount,jmpAccount,shorten)
#endif
i = infoM "update"
+d = debugM "update"
update = simpleCmd "update" "Update your status"
update_help
@@ -43,10 +45,15 @@ update = simpleCmd "update" "Update your status"
Option "i" ["inreplyto"] (ReqArg (stdRequired "i") "MSGID")
"Indicate this message is in reply to MSGID"
]
- update_worker
+ 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 ([("m", "")], []) =
- do c <- getContents
+ do d "Reading mail message"
+ c <- getContents
case parse message "(stdin)" c of
Left x -> permFail $ "Couldn't parse mail: " ++ show x
Right (refs, body) ->
@@ -63,28 +70,32 @@ update_worker x cp ([("m", "")], []) =
else []
status = body
in do poststatus <- procStatus cp "update" status
- xmlstr <- sendAuthRequest cp "/statuses/update.xml" []
+ xmlstr <- sendAuthRequest POST cp "/statuses/update.xml" []
([("source", "twidge"), ("status", poststatus)] ++
irt)
debugM "update" $ "Got doc: " ++ xmlstr
update_worker x cp ([], []) =
- do l <- getLine
+ do d "No args reading line"
+ l <- getLine
update_worker x cp ([], [l])
update_worker x cp ([("i", id )], []) =
- do l <- getLine
+ do d "-i reading line"
+ 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" []
+ 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
update_worker _ cp ([], [status]) =
- do poststatus <- procStatus cp "update" status
- xmlstr <- sendAuthRequest cp "/statuses/update.xml" []
+ 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
update_worker _ _ _ =
@@ -111,7 +122,7 @@ dmsend_worker x cp ([], [r]) =
dmsend_worker x cp ([], [r, l])
dmsend_worker x cp ([], [recipient, status]) =
do poststatus <- procStatus cp "dmsend" status
- xmlstr <- sendAuthRequest cp "/direct_messages/new.xml" []
+ xmlstr <- sendAuthRequest POST cp "/direct_messages/new.xml" []
[("source", "Twidge"),
("text", poststatus), ("user", recipient)]
debugM "dmsend" $ "Got doc: " ++ xmlstr
View
11 Download.hs
@@ -54,8 +54,8 @@ simpleDownload url =
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 =
+sendAuthRequest :: Method -> ConfigParser -> String -> [(String, String)] -> [(String, String)] -> IO String
+sendAuthRequest mth cp url getopts postoptlist =
do app <- case getApp cp of
Nothing -> fail $ "Error: auth not set up for this host"
Just x -> return x
@@ -66,10 +66,11 @@ sendAuthRequest cp url getopts postoptlist =
let parsedUrl = fromJust . parseURL $ urlbase ++ url ++ optstr
- -- add to the request the POST headers
- let request = parsedUrl {reqHeaders =
- fromList (toList (reqHeaders parsedUrl) ++
+ -- add to the request the GET/POST headers
+ let request = parsedUrl {qString =
+ fromList (toList (qString parsedUrl) ++
postoptlist)
+ ,method = mth
}
let CurlM resp = runOAuth $
View
23 TwidgeHttpClient.hs
@@ -37,8 +37,12 @@ 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)
@@ -48,7 +52,14 @@ instance Network.OAuth.Http.HttpClient.HttpClient CurlM where
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)
@@ -56,6 +67,15 @@ instance Network.OAuth.Http.HttpClient.HttpClient CurlM where
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]
@@ -65,9 +85,6 @@ instance Network.OAuth.Http.HttpClient.HttpClient CurlM where
other -> if (B.null.reqPayload $ req)
then [CurlHttpGet True,CurlCustomRequest (show other)]
else [CurlPost True,CurlCustomRequest (show other)]
- curlPostData = if (B.null.reqPayload $ req)
- then []
- else [CurlPostFields [map (chr.fromIntegral).B.unpack.reqPayload $ req]]
curlHeaders = let headers = (map (\(k,v) -> k++": "++v).toList.reqHeaders $ req)
in [CurlHttpHeaders $"Expect: "
:("Content-Length: " ++ (show.B.length.reqPayload $ req))
Please sign in to comment.
Something went wrong with that request. Please try again.