hawitter 0.3 → 0.4
raw patch · 3 files changed
+449/−185 lines, 3 filesdep +SHAdep +base64-stringdep +bytestringdep −regex-compatdep ~HTTP
Dependencies added: SHA, base64-string, bytestring, clock, hoauth, regex-base, regex-tdfa
Dependencies removed: regex-compat
Dependency ranges changed: HTTP
Files
- Main.hs +368/−126
- hawitter.cabal +6/−5
- hawitter.glade +75/−54
Main.hs view
@@ -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 <a href=\"%s\">this</a> 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 <xanxys@gmail.com>"]- 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="<a href=\""++url++"\"><span underline=\"none\">"++url++"</span></a>" mkHash hash="<span color=\"chocolate\">"++hash++"</span>" mkUser user="<span color=\"aquamarine\">"++user++"</span>" -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
hawitter.cabal view
@@ -1,15 +1,15 @@ name: hawitter cabal-version: >=1.2-version: 0.3+version: 0.4 author: Daiki Handa <xanxys@gmail.com> maintainer: Daiki Handa <xanxys@gmail.com> 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
hawitter.glade view
@@ -130,6 +130,7 @@ <widget class="GtkViewport" id="vptimeline"> <property name="visible">True</property> <property name="resize_mode">queue</property>+ <property name="shadow_type">none</property> <child> <placeholder/> </child>@@ -171,13 +172,13 @@ <property name="visible">True</property> <property name="orientation">vertical</property> <child>- <widget class="GtkRadioButton" id="radiobutton2">- <property name="label" translatable="yes">OAuth(recommended)</property>+ <widget class="GtkRadioButton" id="norbutton">+ <property name="label" translatable="yes">don't login</property> <property name="visible">True</property>- <property name="sensitive">False</property> <property name="can_focus">True</property> <property name="receives_default">False</property> <property name="draw_indicator">True</property>+ <property name="group">radiobutton2</property> </widget> <packing> <property name="expand">False</property>@@ -185,14 +186,28 @@ </packing> </child> <child>+ <widget class="GtkRadioButton" id="oarbutton">+ <property name="label" translatable="yes">OAuth(recommended)</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="receives_default">False</property>+ <property name="active">True</property>+ <property name="draw_indicator">True</property>+ <property name="group">norbutton</property>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="position">1</property>+ </packing>+ </child>+ <child> <widget class="GtkAlignment" id="alignment2"> <property name="visible">True</property> <property name="left_padding">20</property> <child> <widget class="GtkTable" id="table2"> <property name="visible">True</property>- <property name="sensitive">False</property>- <property name="n_rows">4</property>+ <property name="n_rows">2</property> <property name="n_columns">2</property> <property name="column_spacing">1</property> <property name="row_spacing">2</property>@@ -208,9 +223,11 @@ </packing> </child> <child>- <widget class="GtkLabel" id="label4">+ <widget class="GtkLabel" id="authlabel"> <property name="visible">True</property>- <property name="label" translatable="yes">follow the link and click accept</property>+ <property name="xalign">0</property>+ <property name="label" translatable="yes">wait a moment...</property>+ <property name="use_markup">True</property> </widget> <packing> <property name="left_attach">1</property>@@ -225,87 +242,74 @@ <property name="label" translatable="yes">step 2:</property> </widget> <packing>- <property name="top_attach">2</property>- <property name="bottom_attach">3</property>- <property name="x_options">GTK_FILL</property>- <property name="y_options">GTK_FILL</property>- </packing>- </child>- <child>- <widget class="GtkLabel" id="label6">- <property name="visible">True</property>- <property name="label" translatable="yes">click the 'save token' button</property>- </widget>- <packing>- <property name="left_attach">1</property>- <property name="right_attach">2</property>- <property name="top_attach">2</property>- <property name="bottom_attach">3</property>- <property name="y_options">GTK_FILL</property>- </packing>- </child>- <child>- <widget class="GtkLabel" id="label7">- <property name="visible">True</property>- <property name="label" translatable="yes">http://www.example.com/</property>- </widget>- <packing>- <property name="left_attach">1</property>- <property name="right_attach">2</property> <property name="top_attach">1</property> <property name="bottom_attach">2</property>+ <property name="x_options">GTK_FILL</property> <property name="y_options">GTK_FILL</property> </packing> </child> <child>- <widget class="GtkAlignment" id="alignment3">+ <widget class="GtkHBox" id="hbox2"> <property name="visible">True</property>- <property name="left_padding">50</property>- <property name="right_padding">50</property> <child>- <widget class="GtkButton" id="button3">- <property name="label" translatable="yes">save token</property>+ <widget class="GtkLabel" id="label6"> <property name="visible">True</property>+ <property name="label" translatable="yes">PIN:</property>+ </widget>+ <packing>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <widget class="GtkEntry" id="pinentry">+ <property name="visible">True</property> <property name="can_focus">True</property>+ <property name="invisible_char">●</property>+ </widget>+ <packing>+ <property name="position">1</property>+ </packing>+ </child>+ <child>+ <widget class="GtkButton" id="savetokenbutton">+ <property name="label" translatable="yes">ok</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property> <property name="receives_default">True</property> </widget>+ <packing>+ <property name="padding">4</property>+ <property name="position">2</property>+ </packing> </child> </widget> <packing> <property name="left_attach">1</property> <property name="right_attach">2</property>- <property name="top_attach">3</property>- <property name="bottom_attach">4</property>- <property name="x_options">GTK_FILL</property>+ <property name="top_attach">1</property>+ <property name="bottom_attach">2</property> <property name="y_options">GTK_FILL</property> </packing> </child>- <child>- <placeholder/>- </child>- <child>- <placeholder/>- </child> </widget> </child> </widget> <packing>- <property name="position">1</property>+ <property name="position">2</property> </packing> </child> <child>- <widget class="GtkRadioButton" id="radiobutton1">+ <widget class="GtkRadioButton" id="barbutton"> <property name="label" translatable="yes">unencrypted authentication</property> <property name="visible">True</property> <property name="can_focus">True</property> <property name="receives_default">False</property>- <property name="active">True</property> <property name="draw_indicator">True</property>- <property name="group">radiobutton2</property>+ <property name="group">norbutton</property> </widget> <packing> <property name="expand">False</property>- <property name="position">2</property>+ <property name="position">3</property> </packing> </child> <child>@@ -375,7 +379,7 @@ </child> </widget> <packing>- <property name="position">3</property>+ <property name="position">4</property> </packing> </child> </widget>@@ -478,6 +482,23 @@ <property name="position">0</property> </packing> </child>+ </widget>+ </child>+ </widget>+ <widget class="GtkMenu" id="smenu">+ <property name="visible">True</property>+ <child>+ <widget class="GtkMenuItem" id="s-post">+ <property name="visible">True</property>+ <property name="label" translatable="yes">_Post</property>+ <property name="use_underline">True</property>+ </widget>+ </child>+ <child>+ <widget class="GtkMenuItem" id="s-quit">+ <property name="visible">True</property>+ <property name="label" translatable="yes">_Quit</property>+ <property name="use_underline">True</property> </widget> </child> </widget>