twidge 1.0.1 → 1.0.2
raw patch · 10 files changed
+246/−31 lines, 10 files
Files
- COPYRIGHT +1/−1
- Commands/FollowBlock.hs +8/−7
- Commands/Ls.hs +3/−2
- Commands/Update.hs +21/−10
- Download.hs +6/−5
- Makefile +30/−0
- OAuth.hs +65/−0
- TwidgeHttpClient.hs +106/−0
- twidge.cabal +5/−5
- twidge.hs +1/−1
COPYRIGHT view
@@ -1,4 +1,4 @@-Copyright (C) 2006-2008 John Goerzen <jgoerzen@complete.org>+Copyright (C) 2006-2010 John Goerzen <jgoerzen@complete.org> All code, documentation, and build scripts are under the following license unless otherwise noted:
Commands/FollowBlock.hs view
@@ -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 =
Commands/Ls.hs view
@@ -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
Commands/Update.hs view
@@ -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
Download.hs view
@@ -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 $
+ Makefile view
@@ -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
+ OAuth.hs view
@@ -0,0 +1,65 @@+{- hpodder component+Copyright (C) 2010 John Goerzen <jgoerzen@complete.org>++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 <jgoerzen@complete.org>+ 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
+ TwidgeHttpClient.hs view
@@ -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 <ORGANIZATION> 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
twidge.cabal view
@@ -1,17 +1,17 @@ Name: twidge-Version: 1.0.1+Version: 1.0.2 License: GPL Maintainer: John Goerzen <jgoerzen@complete.org> 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
twidge.hs view
@@ -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\