diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,10 +1,14 @@ +-- | Reference: module Main where import Control.Monad +import Control.Monad.Trans import qualified Codec.Binary.UTF8.String as U -import Data.IORef +import Data.Char import Data.List import Data.Maybe import Data.Ratio +import Data.IORef +import Data.Version import Data.Time.Clock import Data.Time.Format import qualified Data.Map as M @@ -13,50 +17,118 @@ 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 Text.JSON +import Text.Regex +import Text.Parsec.String +import Text.Parsec hiding (Error,Ok) import qualified Paths_hawitter +consumerKey="lCHiDjvMKkqHIGYTON3Ecw" +consumerSecret="R10OHGwq6XKzXCshkiO4aVWjiKVcUg4DVfPTllIco" main=do initGUI - si<-statusIconNewFromFile =<< Paths_hawitter.getDataFileName "hawitter_128sq.svg" - statusIconSetVisible si True - + -- construct GUI from glade file and extract pointers to some widget gladeFile<-Paths_hawitter.getDataFileName "hawitter.glade" Just gxml<-xmlNewWithRootAndDomain gladeFile (Just "mainwindow") Nothing - window<-xmlGetWidget gxml castToWindow "mainwindow" + window<-xmlGetWidget gxml castToWindow "mainwindow" + men<-xmlGetWidget gxml castToEntry "modifierentry" + swt<-xmlGetWidget gxml castToViewport "vptimeline" (mv,showTweets)<-newMessageView - - swt<-xmlGetWidget gxml castToViewport "vptimeline" set swt [containerChild:=mv] + let toggleVisibility=do vis<-get window widgetVisible + (if vis then widgetHideAll else widgetShowAll) window + + -- initialize global state (TODO: make it pure) pTweets<-newIORef [] pLastId<-newIORef Nothing - pImageCache<-newIORef emptyImageCache - let updateTL=update showTweets pTweets pLastId pImageCache + pIconCache<-mkIconCache - -- handlers + -- setup status icon + iconN<-pixbufNewFromFile =<< Paths_hawitter.getDataFileName "hawitter.svg" + 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 + t0<-readIORef pTweets + let (n,t1)=addTL ts t0 + writeIORef pTweets t1 + + when (n>0) $ do + showTweets t1 + visible<-get window widgetVisible + when (raise && not visible) $ statusIconSetFromPixbuf si iconB + updateTL raise=fetchTL pLastId pIconCache >>= insertTL raise + + -- register 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 "timeline-post" $ newPostWindow >>= maybe (return ()) + (\x->insertTL False . (:[]) . snd =<< parseTweet pIconCache x) + onAction "timeline-refresh" $ updateTL True onAction "help-about" showAboutDialog - onDestroy window mainQuit - timeoutAdd (updateTL >> return True) (60*1000) - updateTL - widgetShowAll window + on window deleteEvent $ liftIO $ widgetHideAll window >> return True + timeoutAdd (updateTL True >> return True) (60*1000) + + on si statusIconActivate $ statusIconSetFromPixbuf si iconN >> toggleVisibility + timeoutAdd (statusIconSetVisible si True >> return True) (1*1000) + + -- end initialization and enter idle state + updateTL True mainGUI --- [newest..oldest] + +{- +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 ()) newMessageView=do vb<-vBoxNew False 2 @@ -87,6 +159,7 @@ entryGetText ps >>= gconfSet gconf "/apps/hawitter/basic/pswd" . GConfValueString putStrLn "gconf configuration complete" +newPostWindow :: IO (Maybe JSValue) newPostWindow=do gladeFile<-Paths_hawitter.getDataFileName "hawitter.glade" Just gxml<-xmlNewWithRootAndDomain gladeFile (Just "postdialog") Nothing @@ -97,20 +170,18 @@ 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 () + tw<-if rid==ResponseUser 0 + then do st<-textBufferGetStartIter buf + en<-textBufferGetEndIter buf + txt<-textBufferGetText buf st en False + callJSON POST "/statuses/update" [("status",U.utf8Encode txt)] + else return Nothing widgetDestroy d + return tw + updateTweetInfo buf lb=do st<-textBufferGetStartIter buf en<-textBufferGetEndIter buf @@ -121,10 +192,10 @@ showAboutDialog=do d<-aboutDialogNew aboutDialogSetName d "hawitter" - aboutDialogSetVersion d "0.2" + 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_128sq.svg" + aboutDialogSetLogo d . Just =<< pixbufNewFromFile =<< Paths_hawitter.getDataFileName "hawitter_128.svg" dialogRun d widgetDestroy d @@ -135,12 +206,12 @@ 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_.]+" + 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++"" + mkHash hash=""++hash++"" mkUser user=""++user++"" modifyWithRegex rx f s=case matchRegexAll rx s of @@ -148,8 +219,9 @@ Just (pre,target,post,_) -> pre++f target++modifyWithRegex rx f post +-- | Convert 'Tweet' to 'Widget' using 'IconCache'. allocTweet :: Tweet -> IO Widget -allocTweet (Tweet icon (User id) (Source src) date msg)=do +allocTweet (Tweet user@(User icon id _) (Source srcN srcU) date msg)=do t0<-getCurrentTime im<-imageNewFromPixbuf icon @@ -157,21 +229,15 @@ -- begin vbCont lbUser<-labelNew Nothing - let - (cname,curl)=extractClientName src - fromLink - |null curl = ""++cname++"" - |otherwise = ""++cname++"" + let fromLink=case srcU of + Nothing -> ""++srcN++"" + Just u -> ""++srcN++"" labelSetMarkup lbUser $ unwords [""++id++"","-",showPastTime t0 date,"-","from",fromLink] - labelSetLineWrap lbUser False - labelSetSingleLineMode lbUser True - set lbUser [miscXalign:=0] + set lbUser [labelLineWrap:=False,labelSingleLineMode:=True,miscXalign:=0] lbMsg<-labelNew Nothing labelSetMarkup lbMsg $ markupMessage msg - labelSetLineWrap lbMsg True - labelSetSingleLineMode lbMsg False - set lbMsg [miscXalign:=0] + set lbMsg [labelLineWrap:=True,labelSingleLineMode:=False,labelSelectable:=True,miscXalign:=0] vbCont<-vBoxNew False 1 boxPackStart vbCont lbUser PackNatural 0 @@ -184,22 +250,8 @@ 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" @@ -210,53 +262,106 @@ 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) +-- | single tweet +data Tweet=Tweet User Source UTCTime String +instance Eq Tweet where + (Tweet u0 _ d0 msg0)==(Tweet u1 _ d1 msg1)=(d0,u0,msg0)==(d1,u1,msg1) -update showTweets ts li ic=do +instance Ord Tweet where + compare (Tweet u0 _ d0 msg0) (Tweet u1 _ d1 msg1)=compare (d0,u0,msg0) (d1,u1,msg1) + +-- | client name and its URL +data Source=Source String (Maybe String) deriving(Show,Eq,Ord) + +-- | icon, id and name +data User=User Pixbuf String String + +instance Show User where + show (User _ id name)=id++" | "++name + +instance Eq User where + (User _ i0 _)==(User _ i1 _)=i0==i1 + +instance Ord User where + compare (User _ i0 _) (User _ i1 _)=compare i0 i1 + + + + + + +escapeBracket :: String -> String +escapeBracket=concatMap f + where + f '<'="<" + f '>'=">" + f x=[x] + + +fetchTL :: IORef (Maybe Int) -> IconCache -> IO [Tweet] +fetchTL 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 + xs<-case resp of + Nothing -> print "couldn't fetch TL" >> return [] + Just (JSArray ss) -> mapM (parseTweet ic) ss + let (ids,ts)=unzip xs + unless (null ids) $ writeIORef li $ Just $ maximum ids + return ts +-- | 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=\"([^\"]+)\"[^>]*>([^<]+)<" -updateWithTL showTweets ts li ic (JSArray ss)=do - unless (null ids) $ writeIORef li $ Just $ maximum ids +-- | Use 'IconCache' to create 'User' from 'JSValue'. +parseTweet :: IconCache -> JSValue -> IO (Int,Tweet) +parseTweet ic x=do + user<-parseUser ic $ indexJSA "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 - 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 +-- | Use 'IconCache' to create 'User' from 'JSValue'. +parseUser :: IconCache -> JSValue -> IO User +parseUser ic x=do + icon<-fetchIconCache ic iconURL + return $ User icon userId userName 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 - + iconURL =fromJSS $ indexJSA "profile_image_url" x + userId =fromJSS $ indexJSA "screen_name" x + userName=fromJSS $ indexJSA "name" x -- example: "Wed Nov 18 18:54:12 +0000 2009" -readDate :: String -> UTCTime -readDate=readTime defaultTimeLocale "%a %b %e %H:%M:%S %Z %Y" +parseDate :: String -> UTCTime +parseDate=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 +type IconCache=IORef (M.Map String Pixbuf) +mkIconCache :: IO IconCache +mkIconCache=newIORef M.empty +fetchIconCache :: IconCache -> String -> IO Pixbuf +fetchIconCache c url=do + c1<-insertIconCache url =<< readIORef c + writeIORef c c1 + return $ c1 M.! url + +insertIconCache :: String -> M.Map String Pixbuf -> IO (M.Map String Pixbuf) +insertIconCache url m + |M.member url m = return m + |otherwise = liftM (\x->M.insert url x m) $ pixbufNewFromURL url + pixbufNewFromURL :: String -> IO Pixbuf pixbufNewFromURL url=do r<-simpleHTTP (getRequest url) @@ -266,7 +371,7 @@ (path,h)<-openBinaryTempFile "/tmp" "hawitter" hPutStr h $ rspBody x hFlush h - n<-pixbufNewFromFile path + n<-pixbufNewFromFileAtSize path 48 48 hClose h return n diff --git a/README.en b/README.en --- a/README.en +++ b/README.en @@ -1,7 +1,7 @@ -Hawitter 0.2 +Hawitter 0.3 == Installation == -It should be possible to run 'cabal install hawitter'. +It should be possible to install by running 'cabal install hawitter'. == Technical Notes == @@ -14,3 +14,4 @@ * email: xanxys at gmail dot com * twitter: @xanxys_ + diff --git a/README.ja b/README.ja --- a/README.ja +++ b/README.ja @@ -1,4 +1,4 @@ -Hawitter 0.2 +Hawitter 0.3 == インストール == 'cabal install hawitter'で動くはず。動かない場合は連絡を。 @@ -13,4 +13,5 @@ * email: xanxys at gmail dot com * twitter: @xanxys_ -* ブログの該当記事のコメント欄(初期バージョンのみ) +* ブログの該当記事のコメント欄(バージョン1未満のみ) + diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,3 +1,4 @@ import Distribution.Simple + main=defaultMain diff --git a/hawitter.cabal b/hawitter.cabal --- a/hawitter.cabal +++ b/hawitter.cabal @@ -1,24 +1,25 @@ name: hawitter cabal-version: >=1.2 -version: 0.2 +version: 0.3 author: Daiki Handa maintainer: Daiki Handa -synopsis: A twitter client for GTK+. Alpha version. +synopsis: A twitter client for GTK+. Beta version. license: BSD3 license-file: LICENSE category: Web +homepage: http://d.hatena.ne.jp/xanxys/20100318/1268917714 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'. + A slick twitter client for GTK. Features syntax highlighting of tweets, URL linking. + Automatic URL shortening and 'timeline modifier' will be implemented in future versions. build-type: Simple -data-files: hawitter.glade hawitter_128sq.svg README.en README.ja +data-files: hawitter.glade hawitter.svg hawitter_busy.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, + 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 diff --git a/hawitter.glade b/hawitter.glade --- a/hawitter.glade +++ b/hawitter.glade @@ -4,7 +4,7 @@ hawitter - hawitter_128sq.svg + hawitter.svg True @@ -106,7 +106,7 @@ - + True True ● @@ -140,6 +140,16 @@ 2 + + + True + 2 + + + False + 3 + + @@ -148,6 +158,7 @@ hawitter - account False True + hawitter.svg normal False @@ -406,6 +417,7 @@ 5 hawitter - tweet False + hawitter.svg normal False diff --git a/hawitter.svg b/hawitter.svg new file mode 100644 --- /dev/null +++ b/hawitter.svg @@ -0,0 +1,110 @@ + + + + + + image/svg+xml + + + + + + + + + + + + + + + + + + + + diff --git a/hawitter_128sq.svg b/hawitter_128sq.svg deleted file mode 100644 --- a/hawitter_128sq.svg +++ /dev/null @@ -1,110 +0,0 @@ - - - - - - image/svg+xml - - - - - - - - - - - - - - - - - - - - diff --git a/hawitter_busy.svg b/hawitter_busy.svg new file mode 100644 --- /dev/null +++ b/hawitter_busy.svg @@ -0,0 +1,110 @@ + + + + + + image/svg+xml + + + + + + + + + + + + + + + + + + + +