diff --git a/Archiver/Options.hs b/Archiver/Options.hs deleted file mode 100644 --- a/Archiver/Options.hs +++ /dev/null @@ -1,55 +0,0 @@ -module Archiver.Options where - -import System.Console.GetOpt -import System.Environment -import System.IO -import System.Exit - - -data Settings = TS { - twitterUsername :: String, - twitterPassword :: Maybe String, - fileName :: String, - sinceId :: Maybe Integer } deriving Show - -defaultSettings = TS { - twitterUsername = "vyom", - twitterPassword = Nothing, - fileName = "vyom.json", - sinceId = Nothing } - -options = [ Option "h" ["help"] - (NoArg - (\_ -> do prg <- getProgName - hPutStrLn stderr (usageInfo prg options) - exitWith ExitSuccess)) - "Show help" - , Option "u" ["username"] - (ReqArg - (\arg opt -> return opt { twitterUsername = arg }) - "vyom") - "Twitter Username" - , Option "f" ["filename"] - (ReqArg - (\arg opt -> return opt { fileName = arg }) - "vyom.json") - "Filename" - , Option "p" ["password"] - (NoArg - (\opt -> do putStr "Enter Twitter Password : " - hFlush stdout - hSetEcho stdout False - password <- hGetLine stdin - hSetEcho stdout True - putStr "\n" - return opt { twitterPassword = Just password })) - "ask for password (private Twitter stream)" - ] - -parseOptions = do args <- getArgs - -- Parse options, getting a list of option actions - let (actions, nonOptions, errors) = getOpt RequireOrder options args - - -- Here we thread startOptions through all supplied option actions - foldl (>>=) (return defaultSettings) actions - diff --git a/Archiver/Twitter.hs b/Archiver/Twitter.hs deleted file mode 100644 --- a/Archiver/Twitter.hs +++ /dev/null @@ -1,97 +0,0 @@ -module Archiver.Twitter where - -import Archiver.Options -import Archiver.Utils - -import Text.JSON -import Text.JSON.Types -import Text.JSON.String -import Text.JSON.Pretty - -import Data.List - -import Control.Applicative -import Control.Monad.Reader - -data Tweet = Tweet { - tweetText :: String, - tweetCreatedAt :: String , - tweetId :: Integer } deriving Show - --- Making Tweet typeclass of JSON to enable decode/encode -instance JSON Tweet where - showJSON (Tweet tweetText tweetCreatedAt tweetId) = makeObj [ ("text", showJSON tweetText), - ("created_at", showJSON tweetCreatedAt), - ("id", showJSON tweetId)] - - readJSON (JSObject obj) = let jsonObjAssoc = fromJSObject obj - mLookup a = maybe (fail $ "No such element: " ++ a) return . lookup a - lookupP p = mLookup p jsonObjAssoc >>= readJSON - in do i <- lookupP "id" - t <- lookupP "text" - c <- lookupP "created_at" - return $ Tweet t c i - -twitterUrl = "http://twitter.com/" - --- extract array of JSON values from a string -readJSONTweets tweetsJSONString = case runGetJSON readJSArray tweetsJSONString of - Right (JSArray xs) -> xs - _ -> [] - - --- read twitter stream page by page -readTwitterStream page tweets - | page >= 21 = return tweets - | otherwise = do fullUrl <- constructFullUrl - tweetsJSON <- readJSONTweets <$> readContentsURL fullUrl - if not (null tweetsJSON) - then readTwitterStream (page + 1) (tweets ++ tweetsJSON) - else return tweets - where url username = twitterUrl ++ "statuses/user_timeline/" ++ username ++ ".json" - - queryParams = [("count", "200"), ("page", show page)] - - concatQueryStr params = intercalate "&" $ map (\(k,v) -> k ++ "=" ++ v) params - - querystring Nothing = concatQueryStr queryParams - querystring (Just tweetId) = concatQueryStr $ queryParams ++ [("since_id", show tweetId)] - - constructFullUrl = do username <- asks twitterUsername - sinceId <- asks sinceId - return $ url username ++ "?" ++ querystring sinceId - --- read contents of URL w/ optional HTTP auth -readContentsURL url = do - liftIO $ putStrLn url - username <- asks twitterUsername - password <- asks twitterPassword - liftIO $ readContentsURLWithAuth url username password - - - -- calculate latest id for since_id param -calculateSinceId pastTweets = if not (null pastTweets) - then - let (Ok tweetids) = forM pastTweets $ liftM tweetId . readJSON - in Just (maximum tweetids) - else Nothing - - --- get past tweets stored in file (if any) -getPastTweets :: ReaderT Settings IO [JSValue] -getPastTweets = do filename <- asks fileName - fileContents <- liftIO $ readContentsArchiveFile filename - return $ readJSONTweets fileContents - - --- read twitter stream -getRecentTweets :: ReaderT Settings IO [JSValue] -getRecentTweets = readTwitterStream 1 [] - - --- write Tweets to file -writeTweetsToFile filename tweetsJSON = let (Ok tweets) = mapM readJSONTweet tweetsJSON - readJSONTweet :: JSValue -> Result Tweet - readJSONTweet = readJSON - tweetsString = render $ pp_value $ showJSON tweets -- Encoding to JSON - in writeToFile filename tweetsString diff --git a/Archiver/Utils.hs b/Archiver/Utils.hs deleted file mode 100644 --- a/Archiver/Utils.hs +++ /dev/null @@ -1,46 +0,0 @@ -module Archiver.Utils where - -import Data.Maybe -import System.IO.Error - -import Network.Browser -import Network.HTTP -import Network.URI - - --- File related functions - -readContentsArchiveFile f = do result <- try (readFile f) - case result of - Right s -> do putStrLn "Reading archive file" - return s - - _ -> do putStrLn "Could not read archive file" - return "" - -writeToFile filename tweetsString = do putStrLn "Writing to file" - writeFile filename tweetsString - --- URL related functions - -readContentsURLWithAuth url username password = - let nullHandler _ = return () - in do (_u, resp) <- browse $ do setOutHandler nullHandler - checkAuth url username password - (request $ getRequest url) - case rspCode resp of - (2,_,_) -> return (rspBody resp) - _ -> fail ("Failed reading URL " ++ show url ++ " code: " ++ show (rspCode resp)) - --- checks if password is provided and sets HTTP auth for request -checkAuth url username password - | password == Nothing = return () - | otherwise = do - ioAction $ putStrLn "Using HTTP Auth" - addAuthority auth -- add auth to request - where auth = AuthBasic { - auUsername = username, - auPassword = fromJust password, - auRealm = "", - auSite = fromJust $ parseAbsoluteURI url } - diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,8 @@ # Introduction -This script will access your Twitter stream and create a text file with all -the past tweets in JSON format. +This script will access your Twitter stream and create a text file with all +the past tweets in JSON format. It also supports updating of the text file in +subsequent runs. The Twitter API currently limits access to a maximum of 3200 tweets in your timeline. Hence if you have tweeted more often than that, you will not be able @@ -22,6 +23,10 @@ when `hs-twitterarchiver` is called without any arguments. runhaskell twitterarchiver.hs -u vyom -f vyom.json + +If a file called `vyom.json` already exists from a previous run, only the +latest Tweets after the previous run will be fetched and the file will be +updated. If you have a private stream, you can call the script with a `-p` argument and you will be prompted for a password. The script will then automatically use diff --git a/hs-twitterarchiver.cabal b/hs-twitterarchiver.cabal --- a/hs-twitterarchiver.cabal +++ b/hs-twitterarchiver.cabal @@ -1,21 +1,27 @@ Name: hs-twitterarchiver -Version: 0.1 +Version: 0.2 License: GPL License-file: LICENSE Author: Deepak Jois Maintainer: deepak.jois@gmail.com -homepage: http://github.com/deepakjois/hs-twitterarchiver +Homepage: https://github.com/deepakjois/hs-twitterarchiver +Bug-Reports: https://github.com/deepakjois/hs-twitterarchiver/issues Build-Type: Simple -synopsis: Commandline Twitter feed archiver -description: `hs-twitterarchiver ` is a tool for generating an archive +Synopsis: Commandline Twitter feed archiver +Description: `hs-twitterarchiver ` is a tool for generating an archive of a user's Twitter feed, in a file on a local computer using JSON format. -category: Network -Cabal-Version: >=1.2 -data-files: README.md +Category: Network +Cabal-Version: >=1.6 +Data-Files: README.md + +Source-Repository head + Type: git + Location: git://github.com/deepakjois/hs-twitterarchiver.git + Executable hs-twitterarchiver - hs-source-dirs: . - main-is: hs-twitterarchiver.hs - other-modules: Archiver.Options, Archiver.Twitter, Archiver.Utils - build-depends: base >=3 && < 5, mtl, network, json, HTTP + Ghc-Options: -Wall + Hs-Source-Dirs: . + Main-Is: hs-twitterarchiver.hs + Build-Depends: base >=3 && < 5, mtl, network, pretty, json, HTTP diff --git a/hs-twitterarchiver.hs b/hs-twitterarchiver.hs --- a/hs-twitterarchiver.hs +++ b/hs-twitterarchiver.hs @@ -1,11 +1,163 @@ -import Archiver.Options -import Archiver.Twitter +-- | Module providing the main hs-twitterarichiver program +-- +-- Install the program by running +-- +-- @ +-- % cabal install hs-twitterarchiver +-- @ +-- +-- Then run the program with no arguments for help info +-- @ +-- % hs-twitterarchiver +-- @ +-- +module Main (main) where -import Control.Monad.Reader +import Data.Either (rights) +import Data.List (intercalate) +import Control.Applicative ((<$>)) +import System.IO.Error (try) +import Network.HTTP (Response(..), simpleHTTP, getRequest, rspBody) +import System.Environment (getProgName, getArgs) -main = do settings <- parseOptions - pastTweets <- runReaderT getPastTweets settings - recentTweets <- runReaderT getRecentTweets (settings { sinceId = calculateSinceId pastTweets}) - let allTweets = recentTweets ++ pastTweets - filename = fileName settings - writeTweetsToFile filename allTweets +import Text.JSON (JSON, readJSON, showJSON, makeObj, resultToEither) +import Text.JSON.Types (JSValue(..), JSObject, fromJSObject) +import Text.JSON (Result(..)) +import Text.JSON.String (runGetJSON, readJSArray) +import Text.JSON.Pretty (pp_value) + +import Text.PrettyPrint (render) + +data Tweet = Tweet String -- text + String -- created at + Integer -- ID, + +tweetId :: Tweet -> Integer +tweetId (Tweet _ _ i) = i + +-- Making Tweet typeclass of JSON to enable decode/encode +instance JSON Tweet where + showJSON (Tweet t c i) = + makeObj [ ("text", showJSON t) + , ("created_at", showJSON c) + , ("id", showJSON i) + ] + + readJSON (JSObject obj) = do + i <- lookupM "id" + t <- lookupM "text" + c <- lookupM "created_at" + return $ Tweet t c i + where + jsonObjAssoc = fromJSObject obj + lookupM k = maybe (Error "Property not found") readJSON $ lookup k jsonObjAssoc + + readJSON _ = undefined + +-- Get array of Tweets from JSON String +readTweetsFromJSON :: String -> [Tweet] +readTweetsFromJSON tweetsJSON = + case runGetJSON readJSArray tweetsJSON of + Right (JSArray xs) -> rights $ map (resultToEither . readJSON) xs + _ -> [] + +-- Return the ID of the latest tweet in a list +sinceId :: [Tweet] -> Integer +sinceId [] = 0 +sinceId tweets = maximum $ map tweetId tweets + +-- Return full URL for user's tweets +twitterUrl :: String -> [(String,String)] -> String +twitterUrl username params + | params == [] = url + | otherwise = url ++ queryString + where + url = "http://twitter.com/" ++ + "statuses/user_timeline/" ++ + username ++ ".json" + + queryString = "?" ++ (intercalate "&" $ map (\(k,v) -> k ++ "=" ++ v) params) + + +-- Return list of tweets read from a file +readTweetsFromFile :: FilePath -> IO [Tweet] +readTweetsFromFile f = do + result <- try (readFile f) + case result of + Right json -> do + putStrLn "Reading archive file" + return $ readTweetsFromJSON json + + Left ex -> do + putStrLn "Could not read archive file." + putStrLn (show ex) + return [] + +-- Write tweets to a given file +writeTweetsToFile :: FilePath -> [Tweet] -> IO () +writeTweetsToFile file tweets = writeFile file $ (render . pp_value . showJSON) tweets + +-- Fetch all newer tweets and return a list of all tweets +fetchTweets :: String -> [Tweet] -> IO [Tweet] +fetchTweets username oldTweets = fetchTweets' oldTweets 1 + + where + additionalParams + | sinceId oldTweets == 0 = [] + | otherwise = [("since_id", show $ sinceId oldTweets)] + + fetchTweets' tweetsSoFar page = do + let params = [("count", "200"), ("page", show page)] + url = twitterUrl username (params ++ additionalParams) + putStrLn $ "Fetching tweets from " ++ url + tweets <- readTweetsFromJSON <$> fetchUrlResponse url + case tweets of + [] -> return tweetsSoFar -- Return all tweets found so far + _ -> fetchTweets' (tweetsSoFar ++ tweets) (page + (1 :: Integer)) -- Fetch next page + +fetchUrlResponse :: String -> IO String +fetchUrlResponse url = do + resp <- simpleHTTP (getRequest url) + case resp of + Left err -> error (show err) + Right result@(Response (2,_,_) _ _ _) -> return $ rspBody result + Right (Response code _ _ _) -> error $ "Unknown Response " ++ show code + +-- Show usage information. +help :: IO () +help = do + name <- getProgName + mapM_ putStrLn + [ "ABOUT" + , "" + , "This is a Twitter stream archiver program." + , "" + , "It will try to read a JSON file in the current" + , "folder and then fetch all newer tweets from Twtter" + , "and store them in the same file." + , "" + , "For example usage, check https://github.com/deepakjois/TwitterArchive" + , "" + , "USAGE" + , "" + , name ++ " Fetch and store tweets for given handle " + , "" + ] + +-- Archive tweets of a user +archive :: String -> IO () +archive username = do + oldTweets <- readTweetsFromFile $ file + allTweets <- fetchTweets username oldTweets + putStrLn "Writing to archive file" + writeTweetsToFile file allTweets + where + file = username ++ ".json" + +-- | Main +main :: IO () +main = do + args <- getArgs + case args of + [username] -> archive username + _ -> help