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 <xanxys@gmail.com>"]
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="<a href=\""++url++"\"><span underline=\"none\">"++url++"</span></a>"
mkHash hash="<span color=\"brown\">"++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
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 = "<span color=\"lightblue\" underline=\"none\">"++cname++"</span>"
|otherwise = "<a href=\""++curl++"\"><span color=\"lightblue\" underline=\"none\">"++cname++"</span></a>"
labelSetMarkup lbUser $ unwords ["<b>"++id++"</b>","-",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:
-- <a href="http://example.com" rel="nofollow">TwitterClient</a>
-- ->
-- ("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