hawitter-0.3: Main.hs

-- | Reference: <http://apiwiki.twitter.com/Twitter-API-Documentation>
module Main where
import Control.Monad
import Control.Monad.Trans
import qualified Codec.Binary.UTF8.String as U
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
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Glade
import Network.URI
import Network.HTTP
import Network.HTTP.Auth
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
    
    -- 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"
    men<-xmlGetWidget gxml castToEntry "modifierentry" 
    swt<-xmlGetWidget gxml castToViewport "vptimeline"
    
    (mv,showTweets)<-newMessageView
    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
    pIconCache<-mkIconCache
    
    -- 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 >>= maybe (return ())
        (\x->insertTL False . (:[]) . snd =<< parseTweet pIconCache x)
    onAction "timeline-refresh" $ updateTL True
    onAction "help-about" showAboutDialog
    
    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


{-
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
    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 :: IO (Maybe JSValue)
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
    
    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
    txt<-textBufferGetText buf st en False
    
    labelSetText lb $ show (140-length txt)++" characters left"

showAboutDialog=do
    d<-aboutDialogNew
    aboutDialogSetName d "hawitter"
    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"
    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=\"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


-- | Convert 'Tweet' to 'Widget' using 'IconCache'.
allocTweet :: Tweet -> IO Widget
allocTweet (Tweet user@(User icon id _) (Source srcN srcU) date msg)=do
    t0<-getCurrentTime
    
    im<-imageNewFromPixbuf icon
    set im [miscYalign:=0]
    
    -- begin vbCont
    lbUser<-labelNew Nothing
    let fromLink=case srcU of
                     Nothing -> "<span color=\"lightblue\" underline=\"none\">"++srcN++"</span>"
                     Just  u -> "<a href=\""++u++"\"><span color=\"lightblue\" underline=\"none\">"++srcN++"</span></a>"
    labelSetMarkup lbUser $ unwords ["<b>"++id++"</b>","-",showPastTime t0 date,"-","from",fromLink]
    set lbUser [labelLineWrap:=False,labelSingleLineMode:=True,miscXalign:=0]
    
    lbMsg<-labelNew Nothing
    labelSetMarkup lbMsg $ markupMessage msg
    set lbMsg [labelLineWrap:=True,labelSingleLineMode:=False,labelSelectable:=True,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




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


-- | 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)

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 '<'="&lt;"
        f '>'="&gt;"
        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)
    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=\"([^\"]+)\"[^>]*>([^<]+)<"

-- | 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

-- | 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
        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"
parseDate :: String -> UTCTime
parseDate=readTime defaultTimeLocale "%a %b %e %H:%M:%S %Z %Y"



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)
    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<-pixbufNewFromFileAtSize path 48 48
            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