follower.hs

{-# LANGUAGE ScopedTypeVariables #-}
{--
 Copyright (c) 2009, eagletmt
 Released under the MIT License <http://opensource.org/licenses/mit-license.php>
--}

-- | This program checks if newly followed or removed.
-- Please install the following libraries on ahead:
--   json <http://hackage.haskell.org/package/json>
--   base64-string <http://hackage.haskell.org/package/base64-string>
--   ConfigFile <http://hackage.haskell.org/package/ConfigFile>
--   ansi-terminal <http://hackage.haskell.org/package/ansi-terminal>

module Main where

import Network.URI (URI)
import Network.HTTP (getRequest, rspBody)
import Network.Browser (browse, request, setAuthorityGen, setOutHandler)
import System.IO (openFile, IOMode(ReadMode,WriteMode), hClose, hGetLine, hPrint)
import System.Directory (doesFileExist, getHomeDirectory)
import Control.Monad ((>=>), when)
import Control.Exception (bracket)
import Text.JSON
import Data.Ratio (numerator)
import Data.ConfigFile (readfile, emptyCP, get)
import System.Console.ANSI (setSGR, Color(..), ColorIntensity(..), ConsoleLayer(Foreground), SGR(SetColor,Reset))
import Data.IntSet (IntSet)
import qualified Data.IntSet as S

type Auth = URI -> String -> IO (Maybe (String, String))

-- | load ids from file
loadIds :: String -> IO IntSet
loadIds path = bracket (openFile path ReadMode) hClose (fmap (S.fromList . read) . hGetLine)

-- | store ids into file
storeIds :: String -> IntSet -> IO ()
storeIds path ids = bracket (openFile path WriteMode) hClose (\h -> hPrint h $ S.toList ids)

-- | authority generator
genAuthority user pass = const $ const $ return $ Just (user,pass)

-- | retrieve user information via <http://twitter.com/users/show/USER.json>
userInfo :: Auth -> Int -> IO String
userInfo auth u = browse $ do
  setAuthorityGen auth
  setOutHandler $ const $ return ()
  (_, res) <- request $ getRequest $ "http://twitter.com/users/show/" ++ show u ++ ".json"
  let Ok (obj :: JSObject JSValue) = decodeStrict $ rspBody res
  let a = valFromObj "screen_name" obj
  return $ case a of
    Ok (name :: JSString) -> "http://twitter.com/" ++ fromJSString name
    Error _ -> let Ok (err :: JSString) = valFromObj "error" obj in "ERROR id=" ++ (show u) ++ ": " ++ fromJSString err

-- | get follower ids via <http://twitter.com/followers/ids.json>
getFollowerIds :: Auth -> IO (Either String IntSet)
getFollowerIds auth = browse $ do
  setAuthorityGen auth
  setOutHandler $ const $ return ()
  (_, res) <- request $ getRequest "http://twitter.com/followers/ids.json"
  return $ case decodeStrict (rspBody res) of
    Ok (JSArray ary) -> Right $ S.fromList $ map (\(JSRational _ i) -> fromIntegral $ numerator i) ary
    Error str -> Left $ str ++ "\nBODY\n" ++ rspBody res

main = do
  home <- getHomeDirectory
  let configPath = home ++ "/.twitterrc"
  Right cp <- readfile emptyCP configPath
  let Right name = get cp "user" "name"
  let Right pass = get cp "user" "pass"
  let auth = genAuthority name pass

  idsE <- getFollowerIds auth
  exists <- doesFileExist savePath
  case idsE of
    Left err -> print err
    Right ids -> do
      when exists $ do
        oldIds <- loadIds savePath
        when (ids /= oldIds) $ do
          putStrLn "follow"
          setSGR [SetColor Foreground Dull Green]
          mapM_ (userInfo auth >=> putStrLn) $ S.difference ids oldIds
          setSGR [Reset]
          putStrLn "remove"
          setSGR [SetColor Foreground Dull Red]
          mapM_ (userInfo auth >=> putStrLn) $ S.difference oldIds ids
          setSGR [Reset]
          putStrLn $ "followed by " ++ show (S.size ids) ++ " people"
      storeIds savePath ids
  where
    mapM_ :: (Monad m) => (Int -> m b) -> IntSet -> m ()
    mapM_ f = S.fold ((>>) . f) (return ())
    savePath = "/path/to/file"