diff --git a/Main.hs b/Main.hs
--- a/Main.hs
+++ b/Main.hs
@@ -2,8 +2,10 @@
module Main where
import Control.Monad
import Control.Monad.Trans
+import qualified Codec.Binary.Base64.String as B64
import qualified Codec.Binary.UTF8.String as U
import Data.Char
+import Data.Digest.Pure.SHA
import Data.List
import Data.Maybe
import Data.Ratio
@@ -12,16 +14,22 @@
import Data.Time.Clock
import Data.Time.Format
import qualified Data.Map as M
+import qualified Data.ByteString.Lazy as BS
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Glade
+import Graphics.UI.Gtk.General.Enums
import Network.URI
import Network.HTTP
import Network.HTTP.Auth
+import qualified Network.Protocol.OAuth.Consumer as A
+import qualified Network.Protocol.OAuth.Request as A
import System.IO
import System.Locale
import System.Gnome.GConf
+import System.Posix.Clock
import Text.JSON
-import Text.Regex
+import Text.Regex.TDFA
+import Text.Printf
import Text.Parsec.String
import Text.Parsec hiding (Error,Ok)
import qualified Paths_hawitter
@@ -29,6 +37,10 @@
consumerKey="lCHiDjvMKkqHIGYTON3Ecw"
consumerSecret="R10OHGwq6XKzXCshkiO4aVWjiKVcUg4DVfPTllIco"
+maxTweetsView=200
+maxTweetsMemory=1000
+
+
main=do
initGUI
@@ -36,8 +48,9 @@
gladeFile<-Paths_hawitter.getDataFileName "hawitter.glade"
Just gxml<-xmlNewWithRootAndDomain gladeFile (Just "mainwindow") Nothing
window<-xmlGetWidget gxml castToWindow "mainwindow"
- men<-xmlGetWidget gxml castToEntry "modifierentry"
+ men<-xmlGetWidget gxml castToEntry "modifierentry"
swt<-xmlGetWidget gxml castToViewport "vptimeline"
+ stb<-xmlGetWidget gxml castToStatusbar "statusbar"
(mv,showTweets)<-newMessageView
set swt [containerChild:=mv]
@@ -47,6 +60,8 @@
-- initialize global state (TODO: make it pure)
pTweets<-newIORef []
+ pTLM<-newIORef HomeTL
+
pLastId<-newIORef Nothing
pIconCache<-mkIconCache
@@ -55,21 +70,29 @@
iconB<-pixbufNewFromFile =<< Paths_hawitter.getDataFileName "hawitter_busy.svg"
si<-statusIconNewFromPixbuf iconN
-
- let -- apply filter here? -> no. more general framework needed.
- addTL delta ts=(length d',d'++ts)
- where d'=(reverse $ sort delta) \\ ts
- insertTL raise ts=do
+
+ let insertTL raise ts=do
t0<-readIORef pTweets
- let (n,t1)=addTL ts t0
+
+ filt<-liftM execTLM $ readIORef pTLM
+ let t1=take maxTweetsMemory $ filt $ unifyTL $ t0++ts
writeIORef pTweets t1
- when (n>0) $ do
- showTweets t1
+ when (length t1/=length t0) $ do
+ showTweets $ take maxTweetsView t1
visible<-get window widgetVisible
when (raise && not visible) $ statusIconSetFromPixbuf si iconB
- updateTL raise=fetchTL pLastId pIconCache >>= insertTL raise
-
+ updateTL raise=do
+ liftM compileTLM (readIORef pTLM) >>= execRS pLastId pIconCache >>= insertTL raise
+ updateSTB
+ updateSTB=
+ callJSON GET "/1/account/rate_limit_status" [] >>=
+ statusbarPush stb 0 . maybe "no info available" genLimitMsg >>
+ return ()
+ genLimitMsg x=printf "remaining %d of %d requests"
+ (fromJSI $ indexJSO "remaining_hits" x)
+ (fromJSI $ indexJSO "hourly_limit" x)
+
-- register handlers
let onAction name f=xmlGetWidget gxml castToMenuItem name >>= flip onActivateLeaf f
@@ -86,47 +109,25 @@
on si statusIconActivate $ statusIconSetFromPixbuf si iconN >> toggleVisibility
timeoutAdd (statusIconSetVisible si True >> return True) (1*1000)
+ onEditableChanged men $ do
+ t<-liftM parseTLM $ entryGetText men
+ case t of
+ Nothing -> widgetModifyBase men StateNormal (Color 0xffff 0xdddd 0xdddd)
+ Just x -> widgetModifyBase men StateNormal (Color 0xdddd 0xdddd 0xffff) >> writeIORef pTLM x >> insertTL True []
+
+ on si statusIconPopupMenu $ \btn ts->do
+ case btn of
+ Just RightButton -> do
+ menu<-newPopupMenu insertTL pIconCache
+ menuPopup menu (Just (RightButton,ts))
+ _ -> return ()
+
+
-- end initialization and enter idle state
updateTL True
mainGUI
-{-
-data MExpr
- =MAdd MExpr MExpr -- plus
- |MSub MExpr MExpr -- minus
- |MAnd MExpr MExpr -- and
- |MXor MExpr MExpr -- hat
- |Hash String
- |Gen UExpr
-
-data UExpr
- =Primitive String
- |Follower UExpr
- |Followee UExpr
-
-parseMExpr :: Parser MExpr
-parseMExpr=between (char '(') (char ')') parseMExpr <|> parseHash <|> parseMArith
-
-parseMArith :: Parser MExpr
-parseMArith=do
- x<-parseMExpr
- op<-oneOf (map fst table)
- y<-parseMExpr
- return $! (fromJust $ lookup op table) x y
- where table=[('+',MAdd),('-',MSub),('&',MAnd),('^',MXor)]
-
-
-parseHash :: Parser MExpr
-parseHash=do
- x<-char '#'
- xs<-many1 $ satisfy (\x->isAlphaNum x||x=='_')
- return $ Hash $ x:xs
--}
-
-
-
-
-- | Create message view 'Widget' and return it with updater.
-- 'Tweet's should be in descending order.
newMessageView :: IO (Widget,[Tweet] -> IO ())
@@ -138,26 +139,83 @@
containerGetChildren vb >>= mapM_ (containerRemove vb)
mapM_ (\t->allocTweet t >>= append) ts
widgetShowAll vb
+ resetRSMsg=containerGetChildren vb >>= mapM_ resetTweetSize
+
+ -- TODO: good implementation: if window resize don't happen in 1 second after last resize, exec this routine
+ timeoutAdd (resetRSMsg >> return True) (10*1000)
+
return (castToWidget vb,f)
-newAccountDialog=do
+newPopupMenu insTL pIC=do
gladeFile<-Paths_hawitter.getDataFileName "hawitter.glade"
- gconf<-gconfGetDefault
+ Just gxml<-xmlNewWithRootAndDomain gladeFile (Just "smenu") Nothing
+ let onAction name f=xmlGetWidget gxml castToMenuItem name >>= flip onActivateLeaf f
+
+ onAction "s-post" $ newPostWindow >>= maybe (return ())
+ (\x->insTL False . (:[]) . snd =<< parseTweet pIC x)
+ onAction "s-quit" mainQuit
+
+ xmlGetWidget gxml castToMenu "smenu"
+
+
+newAccountDialog=do
+ -- construct GUI
+ gladeFile<-Paths_hawitter.getDataFileName "hawitter.glade"
Just gxml<-xmlNewWithRootAndDomain gladeFile (Just "accountdialog") Nothing
d<-xmlGetWidget gxml castToDialog "accountdialog"
+ rno<-xmlGetWidget gxml castToRadioButton "norbutton"
+
+ roauth<-xmlGetWidget gxml castToRadioButton "oarbutton"
+ ath<-xmlGetWidget gxml castToLabel "authlabel"
+ pin<-xmlGetWidget gxml castToEntry "pinentry"
+ stk<-xmlGetWidget gxml castToButton "savetokenbutton"
+
+ rbasic<-xmlGetWidget gxml castToRadioButton "barbutton"
id<-xmlGetWidget gxml castToEntry "identry"
ps<-xmlGetWidget gxml castToEntry "pswdentry"
-
- entrySetText id =<< gconfGetString gconf "/apps/hawitter/basic/user"
- entrySetText ps =<< gconfGetString gconf "/apps/hawitter/basic/pswd"
+ -- set initial value
+ clearOthers
+ atype<-configGet "/auth-type"
+ case atype of
+ "basic" -> toggleButtonSetActive rbasic True
+ "oauth" -> toggleButtonSetActive roauth True
+ _ -> toggleButtonSetActive rno True
+
+ entrySetText id =<< configGet "/basic/user"
+ entrySetText ps =<< configGet "/basic/pswd"
+
+ -- prepare oauth token
+ tok<-oauthRequestToken
+ let url="http://twitter.com/oauth/authorize?oauth_token="++A.oauth_token tok
+ labelSetMarkup ath $ printf "follow this link." url
+ onClicked stk $ do
+ tok<-entryGetText pin >>= oauthAccessToken tok
+ configSet "/oauth/token" $ A.oauth_token tok
+ configSet "/oauth/token_secret" $ A.oauth_token_secret tok
+
dialogRun d
widgetDestroy d
- entryGetText id >>= gconfSet gconf "/apps/hawitter/basic/user" . GConfValueString
- entryGetText ps >>= gconfSet gconf "/apps/hawitter/basic/pswd" . GConfValueString
- putStrLn "gconf configuration complete"
+ -- fetch value
+ toggleButtonGetActive rno >>= flip when (configSet "/auth-type" "")
+ toggleButtonGetActive roauth >>= flip when (configSet "/auth-type" "oauth")
+ toggleButtonGetActive rbasic >>= flip when (configSet "/auth-type" "basic")
+
+ entryGetText id >>= configSet "/basic/user"
+ entryGetText ps >>= configSet "/basic/pswd"
+ clearOthers
+ where
+ clearOthers=do
+ atype<-configGet "/auth-type"
+ case atype of
+ "basic" -> mapM_ (flip configSet "") oauthKeys
+ "oauth" -> mapM_ (flip configSet "") basicKeys
+ _ -> mapM_ (flip configSet "") $ ["/auth-type"]++oauthKeys++basicKeys
+ oauthKeys=["/oauth/token","/oauth/token_secret"]
+ basicKeys=["/basic/user","/basic/pswd"]
+
newPostWindow :: IO (Maybe JSValue)
newPostWindow=do
@@ -176,7 +234,7 @@
then do st<-textBufferGetStartIter buf
en<-textBufferGetEndIter buf
txt<-textBufferGetText buf st en False
- callJSON POST "/statuses/update" [("status",U.utf8Encode txt)]
+ callJSON POST "/1/statuses/update" [("status",U.utf8Encode txt)]
else return Nothing
widgetDestroy d
return tw
@@ -195,30 +253,36 @@
aboutDialogSetVersion d $ showVersion Paths_hawitter.version
aboutDialogSetComments d "Hawitter is a twitter client for GTK, written in Haskell."
aboutDialogSetAuthors d ["xanxys "]
- aboutDialogSetLogo d . Just =<< pixbufNewFromFile =<< Paths_hawitter.getDataFileName "hawitter_128.svg"
+ aboutDialogSetLogo d . Just =<< pixbufNewFromFile =<< Paths_hawitter.getDataFileName "hawitter.svg"
dialogRun d
widgetDestroy d
--- URL -> hashtag -> users
--- URL may contain #
markupMessage :: String -> String
-markupMessage=modifyWithRegex ruser mkUser . modifyWithRegex rhash mkHash . modifyWithRegex rurl mkLink
+markupMessage=modifyWithRegex [(rurl,mkLink),(rhash,mkHash),(ruser,mkUser)]
where
- rurl=mkRegex "http://[-a-zA-Z0-9_./#?&=]+"
- rhash=mkRegex "#[a-zA-Z0-9_]+"
- ruser=mkRegex "@[a-zA-Z0-9_]+"
+ rurl="http://([-a-zA-Z0-9_./#?&=~]|%[0-9a-fA-F][0-9a-fA-F])+"
+ rhash="#[a-zA-Z0-9_]+"
+ ruser="@[a-zA-Z0-9_]+"
mkLink url=""++url++""
mkHash hash=""++hash++""
mkUser user=""++user++""
-modifyWithRegex rx f s=case matchRegexAll rx s of
- Nothing -> s
- Just (pre,target,post,_) -> pre++f target++modifyWithRegex rx f post
+modifyWithRegex [] s=convertMarkup s
+modifyWithRegex ps0@((rx,f):ps) s=case s =~~ rx of
+ Nothing -> modifyWithRegex ps s
+ Just (pre,target,post) -> modifyWithRegex ps pre++f target++modifyWithRegex ps0 post
+-- | Convert "&" to "&", keeping > and <
+convertMarkup []=[]
+convertMarkup ('&':'l':'t':';':xs)="<"++convertMarkup xs
+convertMarkup ('&':'g':'t':';':xs)=">"++convertMarkup xs
+convertMarkup ('&':xs)="&"++convertMarkup xs
+convertMarkup (x:xs)=x:convertMarkup xs
+
-- | Convert 'Tweet' to 'Widget' using 'IconCache'.
allocTweet :: Tweet -> IO Widget
allocTweet (Tweet user@(User icon id _) (Source srcN srcU) date msg)=do
@@ -242,6 +306,7 @@
vbCont<-vBoxNew False 1
boxPackStart vbCont lbUser PackNatural 0
boxPackStart vbCont lbMsg PackGrow 0
+ on lbMsg sizeAllocate $ \(Rectangle _ _ w h)-> widgetSetSizeRequest lbMsg w (-1) -- hack
hbTweet<-hBoxNew False 3
boxPackStart hbTweet im PackNatural 0
@@ -249,9 +314,16 @@
return $ castToWidget hbTweet
+-- | A hack to achive dynamic wrapping of message.
+resetTweetSize :: Widget -> IO ()
+resetTweetSize w=do
+ msg<-unpack 1 =<< unpack 1 w
+ widgetSetSizeRequest msg (-1) (-1)
+ where unpack ix=liftM (!!ix) . containerGetChildren . castToContainer
+
showPastTime now past
|ss<60 = show ss++" seconds before"
|ms<60 = show ms++" minutes before"
@@ -289,46 +361,90 @@
+parseTLM :: String -> Maybe TLM
+parseTLM xs=liftM (foldr ($) HomeTL) $ mapM gen $ words xs
+ where
+ gen ('+':'#':xs)=return $ WithHash xs
+ gen ('-':'#':xs)=return $ WithoutHash xs
+ gen _=Nothing
+-- | Core strucuture of the timeline modifier.
+-- Two (symmetric) functions 'compileTLM' and 'execTLM' exist based on this.
+data TLM
+ =HomeTL
+ |WithHash String TLM
+ |WithoutHash String TLM
+data TwitterRequest
+ =RHomeTL
+ |RSearch String
-escapeBracket :: String -> String
-escapeBracket=concatMap f
- where
- f '<'="<"
- f '>'=">"
- f x=[x]
+-- currently one-dimensional -> no useful optimization exist (unless the user is stupid...)
+-- future: 2- or n- dimensional -> optimization desirable
+compileTLM :: TLM -> [TwitterRequest]
+compileTLM HomeTL=[RHomeTL]
+compileTLM (WithHash f x)=RSearch ('#':f):compileTLM x
+compileTLM (WithoutHash f x)=compileTLM x
-fetchTL :: IORef (Maybe Int) -> IconCache -> IO [Tweet]
-fetchTL li ic=do
+execTLM :: TLM -> [Tweet] -> [Tweet]
+execTLM (WithoutHash hash x) ts=filter (not . containHash hash) $ execTLM x ts
+execTLM _ ts=ts
+
+
+
+-- | hash starts from #
+containHash :: String -> Tweet -> Bool
+containHash h (Tweet _ _ _ msg)=h `isInfixOf` msg
+
+
+
+unifyTL :: [Tweet] -> [Tweet]
+unifyTL=reverse . sort . nub
+
+
+execRS :: IORef (Maybe Int) -> IconCache -> [TwitterRequest] -> IO [Tweet]
+execRS li ic rs=do
last_id<-readIORef li
- resp<-callJSON GET "/statuses/home_timeline" (maybe [] (\x->[("since_id",show x)]) last_id)
- xs<-case resp of
- Nothing -> print "couldn't fetch TL" >> return []
- Just (JSArray ss) -> mapM (parseTweet ic) ss
- let (ids,ts)=unzip xs
+ let decorateParam xs=maybe xs (\x->("since_id",show x):xs) last_id
+ translate RHomeTL=do
+ x<-callJSON GET "/1/statuses/home_timeline" $ decorateParam []
+ case x of
+ Nothing -> return Nothing
+ Just y -> liftM Just $ mapM (parseTweet ic) $ fromJSA y
+ translate (RSearch x)=do
+ x<-callJSON GET "/search" $ decorateParam [("q",x)]
+ let x'=liftM (map (fromJSI . indexJSO "id") . fromJSA . indexJSO "results") x
+
+ case x' of
+ Nothing -> return Nothing
+ Just y -> liftM Just $ mapM (parseTweet ic) =<< mapM fetchTweetPre y
+
+ xs<-sequence $ map translate rs
+ let (ids,ts)=unzip $ concat $ catMaybes xs
unless (null ids) $ writeIORef li $ Just $ maximum ids
- return ts
+
+ return $ unifyTL ts
+fetchTweetPre :: Int -> IO JSValue
+fetchTweetPre ix=liftM fromJust $ callJSON GET ("/1/statuses/show/"++show ix) []
+
-- | parse /source/ parameter
parseSource :: String -> Source
-parseSource s=case matchRegex rx s of
- Just [u,n] -> Source (escapeBracket n) $ Just $ escapeBracket u
- _ -> Source (escapeBracket s) Nothing
- where
- rx=mkRegex "href=\"([^\"]+)\"[^>]*>([^<]+)<"
+parseSource s=case s =~ "href=\"([^\"]+)\"[^>]*>([^<]+)<" of
+ [_:u:n:_] -> Source (escapeMarkup n) $ Just $ escapeMarkup u
+ _ -> Source (escapeMarkup s) Nothing
-- | Use 'IconCache' to create 'User' from 'JSValue'.
parseTweet :: IconCache -> JSValue -> IO (Int,Tweet)
parseTweet ic x=do
- user<-parseUser ic $ indexJSA "user" x
+ user<-parseUser ic $ indexJSO "user" x
return (id,Tweet user source date message)
where
- id=fromJSI $ indexJSA "id" x
- source=parseSource $ fromJSS $ indexJSA "source" x
- date=parseDate $ fromJSS $ indexJSA "created_at" x
- message=fromJSS $ indexJSA "text" x
+ id=fromJSI $ indexJSO "id" x
+ source=parseSource $ fromJSS $ indexJSO "source" x
+ date=parseDate $ fromJSS $ indexJSO "created_at" x
+ message=fromJSS $ indexJSO "text" x
-- | Use 'IconCache' to create 'User' from 'JSValue'.
parseUser :: IconCache -> JSValue -> IO User
@@ -336,9 +452,9 @@
icon<-fetchIconCache ic iconURL
return $ User icon userId userName
where
- iconURL =fromJSS $ indexJSA "profile_image_url" x
- userId =fromJSS $ indexJSA "screen_name" x
- userName=fromJSS $ indexJSA "name" x
+ iconURL =fromJSS $ indexJSO "profile_image_url" x
+ userId =fromJSS $ indexJSO "screen_name" x
+ userName=fromJSS $ indexJSO "name" x
-- example: "Wed Nov 18 18:54:12 +0000 2009"
parseDate :: String -> UTCTime
@@ -374,35 +490,48 @@
n<-pixbufNewFromFileAtSize path 48 48
hClose h
return n
-
-indexJSA :: String -> JSValue -> JSValue
-indexJSA key (JSObject o)=fromJust $ lookup key $ fromJSObject o
+indexJSO :: String -> JSValue -> JSValue
+indexJSO key (JSObject o)=maybe (error $ "indexJSO: "++key++"\n"++show o) id $
+ lookup key $ fromJSObject o
+
+fromJSA :: JSValue -> [JSValue]
+fromJSA (JSArray x)=x
+
fromJSS :: JSValue -> String
fromJSS (JSString x)=fromJSString x
fromJSI :: JSValue -> Int
fromJSI (JSRational False x)=fromIntegral $ numerator x
-
+
-{-
-oauthRequestToken=do
- Request (fromJust $ parseURI "http://twitter.com/oauth/request_token") GET [] ""
- request c (hmacsha1_signature c)
+encodeOAuthV :: String -> String
+encodeOAuthV=concatMap f
where
- c=Unauthenticated consumerKey consumerSecret
--}
+ f x|'a'<=x && x<='z' = [x]
+ |'A'<=x && x<='Z' = [x]
+ |'0'<=x && x<='9' = [x]
+ |x=='-' || x=='.' || x=='_' || x=='~' = [x]
+ |n>256 = error "encodeOAuthV: out of range character"
+ |otherwise = ['%',g $ n `div` 16,g $ n `mod` 16]
+ where n=ord x
+ g x|x<10 = chr $ x+ord '0'
+ |otherwise = chr $ x+ord 'A'-10
-- example:
-- callJSON GET "/account/rate_limit_status"
callJSON :: RequestMethod -> String -> [(String,String)] -> IO (Maybe JSValue)
callJSON met cmd args=do
- print $ "http://api.twitter.com/1"++cmd++".json"++"?"++urlEncodeVars args
- x<-callAPI met $ "http://api.twitter.com/1"++cmd++".json"++"?"++urlEncodeVars args
+ let pre|cmd=="/search" = "http://search.twitter.com"
+ |otherwise = "http://api.twitter.com"
+ fu=pre++cmd++".json"
+
+ print fu
+ x<-callAPI met (fromJust $ parseURI fu) args
case x of
Nothing -> return Nothing
Just y -> case decode y of
@@ -411,28 +540,141 @@
-- example:
-- callAPI "http://api.twitter.com/1/account/rate_limit_status.json"
-callAPI :: RequestMethod -> String -> IO (Maybe String)
-callAPI met url=do
- gconf<-gconfGetDefault
- user<-gconfGetString gconf "/apps/hawitter/basic/user"
- pswd<-gconfGetString gconf "/apps/hawitter/basic/pswd"
- let clearUserData=mapM_ (gconfUnset gconf) ["/apps/hawitter/basic/user","/apps/hawitter/basic/pswd"]
+callAPI :: RequestMethod -> URI -> [(String,String)] -> IO (Maybe String)
+callAPI met url params=do
+ auth<-configGet "/auth-type"
+ case auth of
+ "basic" -> basic
+ "oauth" -> oauth
+ _ -> return Nothing
+ where
+ basic=basicResource met (show url) params
+ oauth=oauthResource met (show url) params
+
+-- | Returns request_token.
+oauthRequestToken :: IO A.Token
+oauthRequestToken=do
+ r1<-A.nonce_and_timestamp $ A.HTTP False A.GET domain 80 path [("oauth_callback",Just "oob")]
+ let r2=A.request c (A.hmacsha1_signature c) r1
+ hdrc=bstringToString $ A.show_oauthheader realm r2
- let au=AuthBasic undefined user pswd undefined
- let rq=Request (fromJust $ parseURI url) met [] ""
- let rq'=insertHeader HdrAuthorization (withAuthority au rq) rq
+ let hr=Request (fromJust $ parseURI full) GET [Header HdrAuthorization hdrc] BS.empty
+ Right resp<-simpleHTTP hr
+ case A.response c (rspBody resp) of
+ Just (A.Authenticated _ _ tok) -> return tok
+ where
+ c=A.Unauthenticated consumerKey consumerSecret
+ domain="twitter.com"
+ path="/oauth/request_token"
+ realm="Twitter API"
+ full="http://"++domain++path
+
+-- | Supply request_token and PIN. Returns access_token.
+oauthAccessToken :: A.Token -> String -> IO A.Token
+oauthAccessToken tok pin=do
+ r1<-A.nonce_and_timestamp $ A.HTTP False A.POST domain 80 path [("oauth_verifier",Just pin)]
+ let r2=A.request c (A.hmacsha1_signature c) r1
+ hdrc=map (chr . fromIntegral) $ BS.unpack $ A.show_oauthheader realm r2
- if null user
- then return Nothing
- else do rs<-simpleHTTP rq'
- case rs of
- Left er -> error $ show er
- Right q -> case rspCode q of
- (2,0,0) -> return $ Just $ rspBody q
- (4,0,1) -> print "401" >> clearUserData >> return Nothing
- _ -> print rs >> return Nothing
+ let hr=Request (fromJust $ parseURI full) POST [Header HdrAuthorization hdrc] BS.empty
+ Right resp<-simpleHTTP hr
+ print resp
+ putStrLn $ bstringToString (rspBody resp)
+ case A.response c (rspBody resp) of
+ Just (A.Authenticated _ _ tok) -> return tok
+ where
+ c=A.Authenticated consumerKey consumerSecret tok
+ domain="twitter.com"
+ path="/oauth/access_token"
+ realm="Twitter API"
+ full="http://"++domain++path
-gconfGetString gconf key=catch (liftM unpack $ gconfGet gconf key) (const $ return "")
- where unpack (GConfValueString s)=s
+oauthResource :: RequestMethod -> String -> [(String,String)] -> IO (Maybe String)
+oauthResource met url aparams=do
+ oauth_token<-configGet "/oauth/token"
+ oauth_token_secret<-configGet "/oauth/token_secret"
+ timestamp<-liftM (formatTime defaultTimeLocale "%s") getCurrentTime
+ nonce<-liftM (showDigest . sha1 . stringToBString . show . nsec) $ getTime Monotonic
+
+ let oauthParams=
+ [("oauth_consumer_key",consumerKey)
+ ,("oauth_token",oauth_token)
+ ,("oauth_signature_method","HMAC-SHA1")
+ ,("oauth_timestamp",timestamp)
+ ,("oauth_nonce",nonce)
+ ,("oauth_version","1.0")
+ ]
+ params=oauthParams++aparams
+
+ let params'=map (\(x,y)->(encodeOAuthV x,encodeOAuthV y)) params
+ params''=concat $ intersperse "&" $ map (\(x,y)->x++"="++y) $ sort params'
+ basestring=show met++"&"++encodeOAuthV url++"&"++encodeOAuthV params''
+ secret=encodeOAuthV consumerSecret++"&"++encodeOAuthV oauth_token_secret
+ signature=B64.encode $ bstringToString $ bytestringDigest $ hmacSha1 (stringToBString secret) (stringToBString basestring)
+
+ let paramsFinal=params++[("oauth_signature",signature)]
+ urlFin=url++"?"++urlEncodeVars paramsFinal
+
+ let rq=Request (fromJust $ parseURI urlFin) met [] ""
+
+ {-
+ print "==== oauthResource ===="
+ print params
+ print url
+ print basestring
+ print secret
+ print signature
+ print paramsFinal
+ print urlFin
+ -}
+
+ rs<-simpleHTTP rq
+ case rs of
+ Left er -> error $ show er
+ Right q -> case rspCode q of
+ (2,0,0) -> return $ Just $ rspBody q
+ (4,0,1) -> print "401" >> print (rs,rspBody q) >> return Nothing
+ _ -> print (rs,rspBody q) >> return Nothing
+
+
+
+
+basicResource :: RequestMethod -> String -> [(String,String)] -> IO (Maybe String)
+basicResource met url params=do
+ user<-configGet "/basic/user"
+ pswd<-configGet "/basic/pswd"
+ let au=AuthBasic undefined user pswd undefined
+ rq=Request (fromJust $ parseURI $ url++"?"++urlEncodeVars params) met [] ""
+ rs<-simpleHTTP $ insertHeader HdrAuthorization (withAuthority au rq) rq
+ case rs of
+ Left er -> error $ show er
+ Right q -> case rspCode q of
+ (2,0,0) -> return $ Just $ rspBody q
+ (4,0,1) -> print "401" >> print (rs,rspBody q) >> return Nothing
+ _ -> print (rs,rspBody q) >> return Nothing
+
+
+
+bstringToString :: BS.ByteString -> String
+bstringToString=map (chr . fromIntegral) . BS.unpack
+
+stringToBString :: String -> BS.ByteString
+stringToBString=BS.pack . map (fromIntegral . ord)
+
+gconfRoot :: String
+gconfRoot="/apps/hawitter"
+
+configSet :: String -> String -> IO ()
+configSet path val=do
+ g<-gconfGetDefault
+ if null val
+ then gconfUnset g (gconfRoot++path)
+ else gconfSet g (gconfRoot++path) val
+
+configGet :: String -> IO String
+configGet path=do
+ g<-gconfGetDefault
+ catch (liftM unpack $ gconfGet g $ gconfRoot++path) (const $ return "")
+ where unpack (GConfValueString s)=s
diff --git a/hawitter.cabal b/hawitter.cabal
--- a/hawitter.cabal
+++ b/hawitter.cabal
@@ -1,15 +1,15 @@
name: hawitter
cabal-version: >=1.2
-version: 0.3
+version: 0.4
author: Daiki Handa
maintainer: Daiki Handa
synopsis: A twitter client for GTK+. Beta version.
license: BSD3
license-file: LICENSE
category: Web
-homepage: http://d.hatena.ne.jp/xanxys/20100318/1268917714
+homepage: http://d.hatena.ne.jp/xanxys/20100321/1269137834
description:
- A slick twitter client for GTK. Features syntax highlighting of tweets, URL linking.
+ A slick twitter client for GTK. Features syntax highlighting of tweets and URL linking.
Automatic URL shortening and 'timeline modifier' will be implemented in future versions.
build-type: Simple
@@ -20,6 +20,7 @@
build-depends:
base>=3, base<5, containers>=0.2, mtl>=1, time>=1.1.4, old-locale>=1,
gtk>=0.10, glade>=0.10, gconf>=0.10,
- parsec>=3, regex-compat>=0.7,
- network>=2.2, HTTP>=4000, json>=0.4, utf8-string>=0.3
+ parsec>=3, regex-base>=0.93.1, regex-tdfa>=1,
+ network>=2.2, HTTP>=4000.0.8, json>=0.4, utf8-string>=0.3, bytestring>=0.9, hoauth>=0.1.9,
+ SHA>=1.4, base64-string>=0.2, clock>=0.1.2
diff --git a/hawitter.glade b/hawitter.glade
--- a/hawitter.glade
+++ b/hawitter.glade
@@ -130,6 +130,7 @@
True
queue
+ none
@@ -171,13 +172,13 @@
True
vertical
-
- OAuth(recommended)
+
+ don't login
True
- False
True
False
True
+ radiobutton2
False
@@ -185,14 +186,28 @@
+
+ OAuth(recommended)
+ True
+ True
+ False
+ True
+ True
+ norbutton
+
+
+ False
+ 1
+
+
+
True
20
True
- False
- 4
+ 2
2
1
2
@@ -208,9 +223,11 @@
-
+
True
- follow the link and click accept
+ 0
+ wait a moment...
+ True
1
@@ -225,87 +242,74 @@
step 2:
- 2
- 3
- GTK_FILL
- GTK_FILL
-
-
-
-
- True
- click the 'save token' button
-
-
- 1
- 2
- 2
- 3
- GTK_FILL
-
-
-
-
- True
- http://www.example.com/
-
-
- 1
- 2
1
2
+ GTK_FILL
GTK_FILL
-
+
True
- 50
- 50
-
- save token
+
True
+ PIN:
+
+
+ 0
+
+
+
+
+ True
True
+ ●
+
+
+ 1
+
+
+
+
+ ok
+ True
+ True
True
+
+ 4
+ 2
+
1
2
- 3
- 4
- GTK_FILL
+ 1
+ 2
GTK_FILL
-
-
-
-
-
-
- 1
+ 2
-
+
unencrypted authentication
True
True
False
- True
True
- radiobutton2
+ norbutton
False
- 2
+ 3
@@ -375,7 +379,7 @@
- 3
+ 4
@@ -478,6 +482,23 @@
0
+
+
+
+