diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +Copyright (c) 2010 Daiki Handa +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. 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. +3. The name of the author may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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. + diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,333 @@ +module Main where +import Control.Monad +import qualified Codec.Binary.UTF8.String as U +import Data.IORef +import Data.List +import Data.Maybe +import Data.Ratio +import Data.Time.Clock +import Data.Time.Format +import qualified Data.Map as M +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Glade +import Network.URI +import Network.HTTP +import Network.HTTP.Auth +import Text.JSON +import Text.Regex +import System.IO +import System.Locale +import System.Gnome.GConf +import qualified Paths_hawitter + + +main=do + initGUI + + si<-statusIconNewFromFile =<< Paths_hawitter.getDataFileName "hawitter_128sq.svg" + statusIconSetVisible si True + + gladeFile<-Paths_hawitter.getDataFileName "hawitter.glade" + Just gxml<-xmlNewWithRootAndDomain gladeFile (Just "mainwindow") Nothing + window<-xmlGetWidget gxml castToWindow "mainwindow" + + (mv,showTweets)<-newMessageView + + swt<-xmlGetWidget gxml castToViewport "vptimeline" + set swt [containerChild:=mv] + + pTweets<-newIORef [] + pLastId<-newIORef Nothing + pImageCache<-newIORef emptyImageCache + let updateTL=update showTweets pTweets pLastId pImageCache + + -- handlers + let onAction name f=xmlGetWidget gxml castToMenuItem name >>= flip onActivateLeaf f + + onAction "file-account" newAccountDialog + onAction "file-quit" mainQuit + onAction "timeline-post" newPostWindow + onAction "timeline-refresh" updateTL + onAction "help-about" showAboutDialog + onDestroy window mainQuit + timeoutAdd (updateTL >> return True) (60*1000) + + updateTL + widgetShowAll window + mainGUI + +-- [newest..oldest] +newMessageView :: IO (Widget,[Tweet] -> IO ()) +newMessageView=do + vb<-vBoxNew False 2 + let + append x=boxPackStart vb x PackNatural 3 + f ts=do + containerGetChildren vb >>= mapM_ (containerRemove vb) + mapM_ (\t->allocTweet t >>= append) ts + widgetShowAll vb + return (castToWidget vb,f) + +newAccountDialog=do + gladeFile<-Paths_hawitter.getDataFileName "hawitter.glade" + gconf<-gconfGetDefault + Just gxml<-xmlNewWithRootAndDomain gladeFile (Just "accountdialog") Nothing + + d<-xmlGetWidget gxml castToDialog "accountdialog" + 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" + + 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" + +newPostWindow=do + gladeFile<-Paths_hawitter.getDataFileName "hawitter.glade" + Just gxml<-xmlNewWithRootAndDomain gladeFile (Just "postdialog") Nothing + d<-xmlGetWidget gxml castToDialog "postdialog" + lb<-xmlGetWidget gxml castToLabel "remaining" + tv<-xmlGetWidget gxml castToTextView "tweetbody" + + buf<-textViewGetBuffer tv + onBufferChanged buf $ updateTweetInfo buf lb + + + rid<-dialogRun d + + + when (rid==ResponseUser 0) $ do + st<-textBufferGetStartIter buf + en<-textBufferGetEndIter buf + txt<-textBufferGetText buf st en False + + let txtU8=U.utf8Encode txt + callJSON POST "/statuses/update" [("status",txtU8)] + return () + widgetDestroy d + +updateTweetInfo buf lb=do + st<-textBufferGetStartIter buf + en<-textBufferGetEndIter buf + txt<-textBufferGetText buf st en False + + labelSetText lb $ show (140-length txt)++" characters left" + +showAboutDialog=do + d<-aboutDialogNew + aboutDialogSetName d "hawitter" + aboutDialogSetVersion d "0.2" + aboutDialogSetComments d "Hawitter is a twitter client for GTK, written in Haskell." + aboutDialogSetAuthors d ["xanxys "] + aboutDialogSetLogo d . Just =<< pixbufNewFromFile =<< Paths_hawitter.getDataFileName "hawitter_128sq.svg" + dialogRun d + widgetDestroy d + + + +-- URL -> hashtag -> users +-- URL may contain # +markupMessage :: String -> String +markupMessage=modifyWithRegex ruser mkUser . modifyWithRegex rhash mkHash . modifyWithRegex rurl mkLink + where + rurl=mkRegex "http://[-a-zA-Z0-9_./#]+" + rhash=mkRegex "#[-a-zA-Z0-9_.]+" + ruser=mkRegex "@[-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 + + +allocTweet :: Tweet -> IO Widget +allocTweet (Tweet icon (User id) (Source src) date msg)=do + t0<-getCurrentTime + + im<-imageNewFromPixbuf icon + set im [miscYalign:=0] + + -- begin vbCont + lbUser<-labelNew Nothing + let + (cname,curl)=extractClientName src + fromLink + |null curl = ""++cname++"" + |otherwise = ""++cname++"" + labelSetMarkup lbUser $ unwords [""++id++"","-",showPastTime t0 date,"-","from",fromLink] + labelSetLineWrap lbUser False + labelSetSingleLineMode lbUser True + set lbUser [miscXalign:=0] + + lbMsg<-labelNew Nothing + labelSetMarkup lbMsg $ markupMessage msg + labelSetLineWrap lbMsg True + labelSetSingleLineMode lbMsg False + set lbMsg [miscXalign:=0] + + vbCont<-vBoxNew False 1 + boxPackStart vbCont lbUser PackNatural 0 + boxPackStart vbCont lbMsg PackGrow 0 + + hbTweet<-hBoxNew False 3 + boxPackStart hbTweet im PackNatural 0 + boxPackStart hbTweet vbCont PackGrow 0 + + return $ castToWidget hbTweet + + +-- example: +-- TwitterClient +-- -> +-- ("TwitterClient","http://example.com") +extractClientName :: String -> (String,String) +extractClientName s=case matchRegex rx s of + Just [u,n] -> (escapeBRs n,escapeBRs u) + _ -> (escapeBRs s,"") + where + rx=mkRegex "href=\"([^\"]+)[^>]*>([^<]+)<" + escapeBRs=concatMap f + f '<'="<" + f '>'=">" + f x=[x] + + +showPastTime now past + |ss<60 = show ss++" seconds before" + |ms<60 = show ms++" minutes before" + |hs<24 = show hs++" hours before" + |otherwise = formatTime defaultTimeLocale "%Y/%m/%d %H:%M:%S %Z" past + where + ss=ceiling $ now `diffUTCTime` past + ms=ss `div` 60 + hs=ms `div` 60 + +data Tweet=Tweet Pixbuf User Source UTCTime String + +newtype Source=Source String deriving(Show,Eq,Ord) +newtype User=User String deriving(Show,Eq,Ord) + + +update showTweets ts li ic=do + last_id<-readIORef li + resp<-callJSON GET "/statuses/home_timeline" (maybe [] (\x->[("since_id",show x)]) last_id) + case resp of + Nothing -> print "couldn't fetch TL" + Just rb -> updateWithTL showTweets ts li ic rb + + +updateWithTL showTweets ts li ic (JSArray ss)=do + unless (null ids) $ writeIORef li $ Just $ maximum ids + + imgCache<-updateImageCache (zip users icons) =<< readIORef ic + writeIORef ic imgCache + + let tweets=zipWith4 (\u m d s->Tweet (imgCache M.! u) u s d m) users msgs dates sources + modifyIORef ts (tweets++) + + readIORef ts >>= showTweets + where + ids=map (fromJSI . indexJSA "id") ss + msgs=map (fromJSS . indexJSA "text") ss + dates=map (readDate . fromJSS . indexJSA "created_at") ss + users=map (User . fromJSS . indexJSA "screen_name" . indexJSA "user") ss + icons=map (fromJSS . indexJSA "profile_image_url" . indexJSA "user") ss + sources=map (Source . fromJSS . indexJSA "source") ss + + +-- example: "Wed Nov 18 18:54:12 +0000 2009" +readDate :: String -> UTCTime +readDate=readTime defaultTimeLocale "%a %b %e %H:%M:%S %Z %Y" + + +emptyImageCache=M.empty + +updateImageCache :: [(User,String)] -> M.Map User Pixbuf -> IO (M.Map User Pixbuf) +updateImageCache uss m=do + imgs<-mapM pixbufNewFromURL $ map snd nus + return $! M.fromList (zip (map fst nus) imgs) `M.union` m + where nus=filter (flip M.notMember m . fst) $ nubBy (\x y->fst x==fst y) uss + + +pixbufNewFromURL :: String -> IO Pixbuf +pixbufNewFromURL url=do + r<-simpleHTTP (getRequest url) + case r of + Left x -> pixbufNew ColorspaceRgb False 8 73 73 + Right x -> do + (path,h)<-openBinaryTempFile "/tmp" "hawitter" + hPutStr h $ rspBody x + hFlush h + n<-pixbufNewFromFile path + hClose h + return n + + + + +indexJSA :: String -> JSValue -> JSValue +indexJSA key (JSObject o)=fromJust $ lookup key $ fromJSObject o + +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) + where + c=Unauthenticated consumerKey consumerSecret +-} + + +-- 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 + case x of + Nothing -> return Nothing + Just y -> case decode y of + Error e -> error e + Ok x -> return $ Just x + +-- 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"] + + let au=AuthBasic undefined user pswd undefined + let rq=Request (fromJust $ parseURI url) met [] "" + let rq'=insertHeader HdrAuthorization (withAuthority au rq) rq + + 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 + +gconfGetString gconf key=catch (liftM unpack $ gconfGet gconf key) (const $ return "") + where unpack (GConfValueString s)=s + + diff --git a/README.en b/README.en new file mode 100644 --- /dev/null +++ b/README.en @@ -0,0 +1,16 @@ +Hawitter 0.2 + +== Installation == +It should be possible to run 'cabal install hawitter'. + + +== Technical Notes == +This application uses following gconf keys. +* /apps/hawitter/basic/user :: str +* /apps/hawitter/basic/pswd :: str + +== Contact == +If you encounter errors or have suggentions, contact me with: + +* email: xanxys at gmail dot com +* twitter: @xanxys_ diff --git a/README.ja b/README.ja new file mode 100644 --- /dev/null +++ b/README.ja @@ -0,0 +1,16 @@ +Hawitter 0.2 + +== インストール == +'cabal install hawitter'で動くはず。動かない場合は連絡を。 + +== 技術的メモ == +gconfの次のキーを使っています。 +* /apps/hawitter/basic/user :: str +* /apps/hawitter/basic/pswd :: str + +== 連絡先 == +問題/提案がある場合は、 + +* email: xanxys at gmail dot com +* twitter: @xanxys_ +* ブログの該当記事のコメント欄(初期バージョンのみ) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main=defaultMain + diff --git a/hawitter.cabal b/hawitter.cabal new file mode 100644 --- /dev/null +++ b/hawitter.cabal @@ -0,0 +1,24 @@ +name: hawitter +cabal-version: >=1.2 +version: 0.2 +author: Daiki Handa +maintainer: Daiki Handa +synopsis: A twitter client for GTK+. Alpha version. +license: BSD3 +license-file: LICENSE +category: Web +description: + THIS SOFTWARE IS STILL IN ALPHA STATE. + A slick twitter client for GTK. Features syntax highlighting of tweets, URL linking/shortening and + 'timeline modifier'. + +build-type: Simple +data-files: hawitter.glade hawitter_128sq.svg README.en README.ja +tested-with: GHC==6.10.4 +executable hawitter + main-is: Main.hs + build-depends: + base>=3, base<5, containers>=0.2, regex-compat>=0.7, time>=1.1.4, old-locale>=1, + gtk>=0.10, glade>=0.10, gconf>=0.10, + network>=2.2, HTTP>=4000, json>=0.4, utf8-string>=0.3 + diff --git a/hawitter.glade b/hawitter.glade new file mode 100644 --- /dev/null +++ b/hawitter.glade @@ -0,0 +1,472 @@ + + + + + + hawitter + hawitter_128sq.svg + + + True + vertical + + + True + + + True + _File + True + + + True + + + True + _Account + True + + + + + True + _Quit + True + + + + + + + + + + True + _Timeline + True + + + True + + + True + _Post + True + + + + + + True + _Refresh + True + + + + + + + + + + True + _Help + True + + + True + + + True + _About + True + + + + + + + + + False + 0 + + + + + True + + + True + modifier: + + + False + 0 + + + + + True + True + ● + + + 1 + + + + + False + 1 + + + + + True + True + never + + + True + queue + + + + + + + + 2 + + + + + + + 5 + hawitter - account + False + True + normal + False + + + True + vertical + 2 + + + True + vertical + + + OAuth(recommended) + True + False + True + False + True + + + False + 0 + + + + + True + 20 + + + True + False + 4 + 2 + 1 + 2 + + + True + 1 + step 1: + + + GTK_FILL + GTK_FILL + + + + + True + follow the link and click accept + + + 1 + 2 + GTK_FILL + + + + + True + 1 + 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 + + + + + True + 50 + 50 + + + save token + True + True + True + + + + + 1 + 2 + 3 + 4 + GTK_FILL + GTK_FILL + + + + + + + + + + + + + 1 + + + + + unencrypted authentication + True + True + False + True + True + radiobutton2 + + + False + 2 + + + + + True + 20 + + + True + 2 + 2 + 1 + 2 + + + True + 1 + user id: + + + GTK_FILL + GTK_FILL + + + + + True + 1 + password: + + + 1 + 2 + GTK_FILL + GTK_FILL + + + + + True + True + ● + + + 1 + 2 + GTK_FILL + GTK_FILL + + + + + True + True + ● + + + 1 + 2 + 1 + 2 + GTK_FILL + GTK_FILL + + + + + + + 3 + + + + + 1 + + + + + True + end + + + gtk-close + True + True + True + True + + + False + False + 0 + + + + + False + end + 0 + + + + + + + 400 + 150 + 5 + hawitter - tweet + False + normal + False + + + True + vertical + 2 + + + True + vertical + + + True + 140 characters left + + + False + 0 + + + + + True + True + + + 1 + + + + + 1 + + + + + True + end + + + send + True + True + True + 0.50999999046325684 + + + False + False + 0 + + + + + False + end + 0 + + + + + + diff --git a/hawitter_128sq.svg b/hawitter_128sq.svg new file mode 100644 --- /dev/null +++ b/hawitter_128sq.svg @@ -0,0 +1,110 @@ + + + + + + image/svg+xml + + + + + + + + + + + + + + + + + + + +