hawitter-0.4: Main.hs

-- | Reference: <http://apiwiki.twitter.com/Twitter-API-Documentation>
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
import Data.IORef
import Data.Version
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.TDFA
import Text.Printf
import Text.Parsec.String
import Text.Parsec hiding (Error,Ok)
import qualified Paths_hawitter

consumerKey="lCHiDjvMKkqHIGYTON3Ecw"
consumerSecret="R10OHGwq6XKzXCshkiO4aVWjiKVcUg4DVfPTllIco"

maxTweetsView=200
maxTweetsMemory=1000


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"
    stb<-xmlGetWidget gxml castToStatusbar "statusbar"
    
    (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 []
    pTLM<-newIORef HomeTL
    
    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 insertTL raise ts=do
            t0<-readIORef pTweets
            
            filt<-liftM execTLM $ readIORef pTLM
            let t1=take maxTweetsMemory $ filt $ unifyTL $ t0++ts
            writeIORef pTweets t1
            
            when (length t1/=length t0) $ do
                showTweets $ take maxTweetsView t1
                visible<-get window widgetVisible
                when (raise && not visible) $ statusIconSetFromPixbuf si iconB
        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
    
    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)
    
    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


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

newPopupMenu insTL pIC=do
    gladeFile<-Paths_hawitter.getDataFileName "hawitter.glade"
    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"
    
    -- 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
    
    -- 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
    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 "/1/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.svg"
    dialogRun d
    widgetDestroy d



markupMessage :: String -> String
markupMessage=modifyWithRegex [(rurl,mkLink),(rhash,mkHash),(ruser,mkUser)]
    where
        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 [] 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 "&amp;", keeping > and <
convertMarkup []=[]
convertMarkup ('&':'l':'t':';':xs)="&lt;"++convertMarkup xs
convertMarkup ('&':'g':'t':';':xs)="&gt;"++convertMarkup xs
convertMarkup ('&':xs)="&amp;"++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
    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
    on lbMsg sizeAllocate $ \(Rectangle _ _ w h)-> widgetSetSizeRequest lbMsg w (-1) -- hack
    
    hbTweet<-hBoxNew False 3
    boxPackStart hbTweet im PackNatural 0
    boxPackStart hbTweet vbCont PackGrow 0
    
    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"
    |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



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


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

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
    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 $ 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 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 $ indexJSO "user" x
    return (id,Tweet user source date message)
    where
        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
parseUser ic x=do
    icon<-fetchIconCache ic iconURL
    return $ User icon userId userName
    where
        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
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




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
  

encodeOAuthV :: String -> String
encodeOAuthV=concatMap f
    where
        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
    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
                       Error e -> error e
                       Ok x    -> return $ Just x

-- example:
-- callAPI "http://api.twitter.com/1/account/rate_limit_status.json"
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 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
    
    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

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