diff --git a/COPYRIGHT b/COPYRIGHT --- a/COPYRIGHT +++ b/COPYRIGHT @@ -1,4 +1,4 @@ -Copyright (C) 2006-2008 John Goerzen +Copyright (C) 2006-2010 John Goerzen All code, documentation, and build scripts are under the following license unless otherwise noted: diff --git a/Commands/FollowBlock.hs b/Commands/FollowBlock.hs --- a/Commands/FollowBlock.hs +++ b/Commands/FollowBlock.hs @@ -21,38 +21,39 @@ 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 = diff --git a/Commands/Ls.hs b/Commands/Ls.hs --- a/Commands/Ls.hs +++ b/Commands/Ls.hs @@ -37,6 +37,7 @@ import System.Console.GetOpt.Utils import Network.URI import Data.Maybe (isJust) +import Network.OAuth.Http.Request i = infoM "ls" @@ -170,7 +171,7 @@ 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 @@ ------------------------------------------------------------ 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 diff --git a/Commands/Update.hs b/Commands/Update.hs --- a/Commands/Update.hs +++ b/Commands/Update.hs @@ -30,11 +30,13 @@ 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 @@ 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 @@ 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, 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 diff --git a/Download.hs b/Download.hs --- a/Download.hs +++ b/Download.hs @@ -54,8 +54,8 @@ 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 @@ 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 $ diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,30 @@ +# arch-tag: Primary makefile +# Copyright (c) 2004-2006 John Goerzen +# + +all: setup # GHC build + ./setup configure + ./setup build + +doc: lib/dfs.html/index.html lib/dfs.pdf lib/dfs.ps lib/dfs.txt + +hugsbuild: setup + ./setup configure --hugs + ./setup build + +setup: Setup.lhs twidge.cabal + ghc -package Cabal Setup.lhs -o setup + +clean: clean-code clean-doc + +clean-code: + -./setup clean + -cd libsrc && ../setup clean + -rm -rf dist libsrc/dist *.ho *.hi *.o *.a setup *~ + -rm -f `find . -name "*~"` `find . -name "*.o"` + -rm -f `find . -name "*.cm*"` + +clean-doc: + -cd doc && scons -c && scons -c html pdf text ps + -rm -rf doc/.sconsign* .depend test + -rm -f doc/manpage* doc/*.1 diff --git a/OAuth.hs b/OAuth.hs new file mode 100644 --- /dev/null +++ b/OAuth.hs @@ -0,0 +1,65 @@ +{- hpodder component +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 +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 : OAuth + Copyright : Copyright (C) 2010 John Goerzen + License : GNU GPL, version 2 or above + + Maintainer : John Goerzen + Stability : provisional + Portability: portable + +Written by John Goerzen, jgoerzen\@complete.org + +-} +module OAuth where + +import Network.OAuth.Consumer +import Data.Maybe +import Network.OAuth.Http.Request +import Network.OAuth.Http.HttpClient +import Data.ConfigFile +import Utils +import Data.Either.Utils + +twitterKeys = ("t5TWz01unNDrmwngl4fQ", + "QR2RJVx8R6zdxWybdGDaLlPMqdRrhZDwO7Kn1uoZUc") +identicaKeys = ("f027d666f9d0e7b80beaed528aec473c", + "d84c9b3dafb14becb5e05a002886b60c") + +getDefaultKeys :: ConfigParser -> Maybe (String, String) +getDefaultKeys cp = + case serverHost cp of + "twitter.com" -> Just twitterKeys + "identi.ca" -> Just identicaKeys + +getApp :: ConfigParser -> Maybe Application +getApp cp = + if (has_option cp "DEFAULT" "oauthconsumerkey" && + has_option cp "DEFAULT" "oauthconsumersecret") + then Just $ Application + {consKey = + forceEither $ get cp "DEFAULT" "oauthconsumerkey", + consSec = + forceEither $ get cp "DEFAULT" "oauthconsumersecret", + callback = OOB} + else case getDefaultKeys cp of + Just (k, s) -> Just $ Application {consKey = k, consSec = s, + callback = OOB} + Nothing -> Nothing diff --git a/TwidgeHttpClient.hs b/TwidgeHttpClient.hs new file mode 100644 --- /dev/null +++ b/TwidgeHttpClient.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- 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 + unlift = unCurlM + + 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/twidge.cabal b/twidge.cabal --- a/twidge.cabal +++ b/twidge.cabal @@ -1,17 +1,17 @@ Name: twidge -Version: 1.0.1 +Version: 1.0.2 License: GPL Maintainer: John Goerzen Author: John Goerzen Stability: Stable -Copyright: Copyright (c) 2006-2008 John Goerzen +Copyright: Copyright (c) 2006-2010 John Goerzen license-file: COPYRIGHT extra-source-files: COPYING, INSTALL, doc/SConstruct, doc/twidge-manpage.sgml, doc/twidge.sgml, doc/local.dsl, 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, Makefile, twidge.bash_completion homepage: http://software.complete.org/twidge Build-type: Simple @@ -54,12 +54,12 @@ if flag(withBitly) Build-Depends: Bitly - CPP-OPTIONS: USE_BITLY + CPP-OPTIONS: -DUSE_BITLY Main-Is: twidge.hs Other-Modules: Commands, Commands.FollowBlock, Commands.Ls, Commands.Setup, Commands.Update, Config, Download, FeedParser, - MailParser, Types, Utils + MailParser, Types, Utils, OAuth, TwidgeHttpClient GHC-Options: -O2 Extensions: ExistentialQuantification, OverlappingInstances, UndecidableInstances diff --git a/twidge.hs b/twidge.hs --- a/twidge.hs +++ b/twidge.hs @@ -88,7 +88,7 @@ putStrLn "Run \"twidge lscommands\" for a list of available commands.\n\ \Run \"twidge command --help\" for help on a particular command.\n" putStr $ "This is Twidge, version " ++ showVersion version - putStrLn $ ". Copyright (c) 2008 John Goerzen" + putStrLn $ ". Copyright (c) 2008-2010 John Goerzen" exitFailure header = "Usage: twidge [global-options] command [command-options]\n\n\