diff --git a/Commands.hs b/Commands.hs new file mode 100644 --- /dev/null +++ b/Commands.hs @@ -0,0 +1,14 @@ +module Commands where + +data Command = Down | Up | Refresh | Reply | First | Last | Unknown + | Insert | Command + +charToCmd 'i' = Insert +charToCmd 'j' = Down +charToCmd 'k' = Up +charToCmd 'r' = Reply +charToCmd 'R' = Refresh +charToCmd 'g' = First +charToCmd 'G' = Last +charToCmd ':' = Command +charToCmd _ = Unknown diff --git a/Gui/Terminal.hs b/Gui/Terminal.hs new file mode 100644 --- /dev/null +++ b/Gui/Terminal.hs @@ -0,0 +1,120 @@ +-- Copied from the Nethask project +module GUI.Terminal ( + move, move_up, move_down, move_forward, move_back + , clr, clear, clear_eol, reset, blinkRed, big, Color (..), color, geometry + , hideCursor, showCursor + ) where + +import Control.Monad (liftM, liftM2) +import Data.List (intercalate) +import System.Environment (getEnvironment) + +--------[ ansi escape sequence generation ]------------------------------------ + +-- Generic function for producing ANSI escape sequences. +esc :: String -> String -> [String] -> String +esc a b arg = concat ["\ESC[", a, intercalate ";" $ arg, b] + +-- Move the cursor to the specified row and column. +move col row = esc "" "H" [show row, show col] + +showCursor = esc "" "l" ["25"] +hideCursor = esc "" "l" ["25"] + +move_up rows = esc "" "A" [show rows] +move_down rows = esc "" "B" [show rows] +move_back rows = esc "" "D" [show rows] +move_forward rows = esc "" "C" [show rows] + +-- Load and store the current cursor position. +save = esc "s" "" [] +load = esc "u" "" [] + +-- Generic function for creating (forground) color sequences. +clr attr fg = esc "" "m" [attr, fg] + +-- Clear screen and end-of-line +clear = esc "2J" "" [] ++ move 1 1 +clear_eol = esc "K" "" [] + +reset = clear ++ color Reset + +blinkRed = esc "" "m" ["1", "5", "31"] + +big s = + "\ESC#3" ++ s + ++ move_back (length s) + ++ move_down 1 + ++ "\ESC#4" ++ s ++ "\n" + +--------[ ansi color listing ]------------------------------------------------- + +data Color = + Black | Black_b | Black_bl | Black_bg + | Red | Red_b | Red_bl | Red_bg + | Green | Green_b | Green_bl | Green_bg + | Yellow | Yellow_b | Yellow_bl | Yellow_bg + | Blue | Blue_b | Blue_bl | Blue_bg + | Magenta | Magenta_b | Magenta_bl | Magenta_bg + | Cyan | Cyan_b | Cyan_bl | Cyan_bg + | White | White_b | White_bl | White_bg + | Reset | Reset_b | Reset_bl | Reset_bg + deriving (Show, Eq) + +-- List of foreground color sequences. +color Black = clr "0" "30" +color Red = clr "0" "31" +color Green = clr "0" "32" +color Yellow = clr "0" "33" +color Blue = clr "0" "34" +color Magenta = clr "0" "35" +color Cyan = clr "0" "36" +color White = clr "0" "37" +color Reset = clr "0" "39" + +-- List of bold foreground color sequences. +color Black_b = clr "1" "30" +color Red_b = clr "1" "31" +color Green_b = clr "1" "32" +color Yellow_b = clr "1" "33" +color Blue_b = clr "1" "34" +color Magenta_b = clr "1" "35" +color Cyan_b = clr "1" "36" +color White_b = clr "1" "37" +color Reset_b = clr "1" "39" + +-- List of background color sequences. +color Black_bg = clr "1" "40" +color Red_bg = clr "1" "41" +color Green_bg = clr "1" "42" +color Yellow_bg = clr "1" "43" +color Blue_bg = clr "1" "44" +color Magenta_bg = clr "1" "45" +color Cyan_bg = clr "1" "46" +color White_bg = clr "1" "47" +color Reset_bg = clr "1" "49" + +-- List of background color sequences. +color Black_bl = esc "" "m" ["5", "30"] +color Red_bl = esc "" "m" ["5", "31"] +color Green_bl = esc "" "m" ["5", "32"] +color Yellow_bl = esc "" "m" ["5", "33"] +color Blue_bl = esc "" "m" ["5", "34"] +color Magenta_bl = esc "" "m" ["5", "35"] +color Cyan_bl = esc "" "m" ["5", "36"] +color White_bl = esc "" "m" ["5", "37"] +color Reset_bl = esc "" "m" ["5", "39"] + +--------[ terminal geometry ]-------------------------------------------------- + +-- Try to read terminal width from environment variable. +width :: IO Int +width = liftM (maybe 80 read . lookup "COLUMNS") getEnvironment + +-- Try to read terminal height from environment variable. +height :: IO Int +height = liftM (maybe 24 read . lookup "LINES") getEnvironment + +-- Try to read terminal width and height from environment variables. +geometry :: IO (Int, Int) +geometry = liftM2 (,) width height diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2008 Tupil + +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. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS OR CONTRIBUTORS 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/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,10 @@ +Create a file ~/.twitter and run the program. + +Commands: + i = Insert + j = Down + k = Up + R = Refresh + g = Select first message + G = Select last message + :q quits diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/State.hs b/State.hs new file mode 100644 --- /dev/null +++ b/State.hs @@ -0,0 +1,32 @@ +module State where +import Control.Monad.State +import Twitter.Client (Tweet) + +data Mode = NormalMode | InsertMode | CommandMode +data AppState = AppState { tweets :: [Tweet] + , active_tweet :: Int + , scroll :: Int + , geom :: (Int, Int) + , mode :: Mode + , auth :: String + } + +getActiveTweet :: State AppState Int +getActiveTweet = get >>= return . active_tweet +setActiveTweet x = modifyActiveTweet (const x) +modifyActiveTweet f = do st <- get + tweets <- getTweets + let at' = f (active_tweet st) + newAt = max 0 (min at' $ length tweets - 1) + put $ st {active_tweet = newAt} + +getTweets :: State AppState [Tweet] +getTweets = get >>= return . tweets + +getAuth :: State AppState String +getAuth = get >>= return . auth + + +setMode x = modifyMode (const x) +modifyMode f = do st <- get + put $ st {mode = f (mode st)} diff --git a/Twitter.hs b/Twitter.hs new file mode 100644 --- /dev/null +++ b/Twitter.hs @@ -0,0 +1,118 @@ +module Main where + +import GUI.Terminal +import Twitter.Client hiding (getTweets) +import qualified Twitter.Client as Client +import Control.Monad.State +import Commands +import State +import System.Console.Readline hiding (message) +import System.IO +import Data.List (intercalate) +import Data.Maybe (maybeToList) +import System.Directory (getHomeDirectory, doesFileExist) +import System.FilePath (combine) + +initialState :: AppState +initialState = AppState [] 0 0 (80,25) NormalMode "" + +main = do + g <- geometry + homeDir <- getHomeDirectory + let filename = combine homeDir ".twitter" + exists <- doesFileExist filename + if not exists + then showAuthError + else do authorization <- readFile filename + s <- refresh $ initialState {geom = g, auth = takeWhile (/= '\n') authorization} + hSetBuffering stdin NoBuffering + mainLoop s + +showAuthError = putStrLn "Please create a file in your home-directory called .twitter with the contents username:password" + +mainLoop :: AppState -> IO () +mainLoop initState = do + let (output, state) = runState drawScreen initState + (width, height) = geom state + putStrLn output + putStr $ move 0 height + putStr hideCursor + case mode state of + NormalMode -> do let tweet = activeTweet state + putStr $ intercalate " | " $ [ show $ time tweet + , "@" ++ (screenName . user) tweet + ] ++ maybeToList (url $ user tweet) + + putStr $ move 0 (height) + input <- getChar + processChar input state + InsertMode -> do putStr showCursor + input <- readline "say: " + processInsert input state + CommandMode -> do putStr showCursor + input <- readline ":" + processCommand input state + +drawScreen :: State AppState String +drawScreen = do + tweets' <- getTweets + let tweets = zip tweets' [0..] + formattedTweets <- mapM formatTweet tweets + return $ clear ++ header ++ unlines formattedTweets + +header = [] + +quit = putStr (clear ++ showCursor ++ color Reset) + +formatTweet (tweet, idx) = + do + activeIdx <- getActiveTweet + let + name' = (name . user) tweet + msg = message tweet + time' = time tweet + active = activeIdx == idx + (start_active, end_active) | active = (color Blue_bg, color Reset_bg) + | otherwise = ([], []) + return $ start_active ++ color Cyan_b ++ name' ++ color Reset_b + ++ ": " ++ msg ++ end_active + +processCommand (Just "q") state = quit +processCommand _ state = mainLoop (normal state) + +normal state = state {mode=NormalMode} + +processInsert Nothing state = mainLoop $ normal state +processInsert (Just "") state = mainLoop $ normal state +processInsert (Just input) state = do + when (length input > 140) $ do + putStrLn "Your input exceeds 140 characters." + getChar >> return () + + addHistory input + say (auth state) input + state' <- refresh state + mainLoop $ normal state' + +processChar input state = + case charToCmd input of + Up -> mod $ modifyActiveTweet (\x -> x - 1) + Down -> mod $ modifyActiveTweet (+1) + Reply -> putStrLn "TODO" >> getLine >> mainLoop state + First -> mod $ setActiveTweet 0 + Last -> mod $ do tw <- getTweets + setActiveTweet (length tw - 1) + Refresh -> refresh state >>= mainLoop + Unknown -> mainLoop state + Insert -> mod $ setMode InsertMode + Command -> mod $ setMode CommandMode + where mod f = mainLoop $ execState f state + +refresh :: AppState -> IO AppState +refresh s = do maybeTw <- Client.getTweets (auth s) + case maybeTw of + Just tw -> return $ s {tweets = tw} + _ -> return s + + +activeTweet state = tweets state !! (active_tweet state) diff --git a/Twitter/Client.hs b/Twitter/Client.hs new file mode 100644 --- /dev/null +++ b/Twitter/Client.hs @@ -0,0 +1,57 @@ +module Twitter.Client where + +import Network.Curl +import Text.JSON +import Text.JSON.String +import Data.Time.Format +import Data.Time.Clock +import Data.Time.LocalTime +import System.Locale +import Data.Maybe (fromJust) + +timeline_url = "http://twitter.com/statuses/friends_timeline.json" +post_url = "http://twitter.com/statuses/update.xml" +options auth = [CurlUserPwd auth, CurlVerbose False] + +data Tweet = Tweet { user :: TwitterUser + , message :: String + , time :: LocalTime + } + deriving Show +data TwitterUser = TwitterUser {name :: String, screenName :: String, url :: Maybe String} + deriving Show + +getTweets :: String -> IO (Maybe [Tweet]) +getTweets auth = do + (code, feed) <- curlGetString timeline_url (options auth) + tz <- getCurrentTimeZone + return $ case runGetJSON readJSArray feed of + (Right (JSArray tweets')) -> Just $ map (processTweet tz) tweets' + _ -> Nothing + +processTweet tz (JSObject o) = Tweet user msg time + where + user = parseUser $ "user" `lookup` obj + time = pTime tz $ cleanString "created_at" obj + msg = cleanString "text" obj + obj = fromJSObject o + +pTime :: TimeZone -> String -> LocalTime +pTime tz s = utcToLocalTime tz $ fromJust $ parseTime defaultTimeLocale "%c" s + +parseUser (Just (JSObject o)) = TwitterUser name screenName url + where name = cleanString "name" obj + screenName = cleanString "screen_name" obj + url = cleanMaybeString "url" obj + obj = fromJSObject o + +cleanString s obj = fromJSString msg + where (Just (JSString msg)) = s `lookup` obj + +cleanMaybeString s obj = + case s `lookup` obj of + (Just (JSString msg)) -> Just $ fromJSString msg + _ -> Nothing + +say :: String -> String -> IO () +say auth msg = curlMultiPost post_url (options auth) [multiformString "status" msg] diff --git a/twitter.cabal b/twitter.cabal new file mode 100644 --- /dev/null +++ b/twitter.cabal @@ -0,0 +1,16 @@ +Name: twitter +Version: 0.1 +Synopsis: A Haskell-based CLI Twitter client +Description: A really basic twitter client. +License: BSD3 +License-file: LICENSE +Author: Chris Eidhof +Maintainer: Chris Eidhof +Build-Depends: base, filepath, curl, directory, xml, readline, old-locale, + time, json, mtl +build-type: Simple +category: Network + +Executable: twitter +Main-is: Twitter.hs +