WhoShouldIFollow.hs

{-# LANGUAGE PatternGuards #-}
module Main where

import Control.Applicative
import Data.Ord
import Directory
import IO
import List
import Monad
import Network.HTTP
import System
import Time
import Text.XML.HXT.DOM.TypeDefs
import Text.XML.HXT.DOM.XmlNode
import Text.XML.HXT.Parser.XmlParsec

addDays :: Int -> ClockTime -> ClockTime
addDays days = addToClockTime (TimeDiff { tdYear = 0, tdMonth = 0, tdDay = days, tdHour = 0, tdMin = 0, tdSec = 0, tdPicosec = 0 })

cleanCache :: IO ()
cleanCache = do oneDayAgo <- addDays (-1) <$> getClockTime
                allFiles <- getDirectoryContents "cache"
                oldFiles <- filterM (\path -> (< oneDayAgo) <$> getModificationTime path) [ "cache/" ++ path | path <- allFiles, path /= ".", path /= ".." ]
                mapM_ (\path -> do hPutStrLn stderr ("Deleting " ++ path)
                                   removeFile path) oldFiles

initCache :: IO ()
initCache = catch (createDirectory "cache")
                  (const cleanCache)

fetchString :: String -> IO (FilePath, String)
fetchString uri = catch (do s <- readFile filename
                            hPutStrLn stderr ("Cached " ++ uri)
                            return (filename, s))
                        (\_ -> do hPutStrLn stderr ("Fetching " ++ uri)
                                  s <- getResponseBody =<< simpleHTTP (getRequest uri)
                                  writeFile filename s
                                  return (filename, s))
                  where filename = "cache/" ++ map safeChar uri
                        safeChar '/' = '-'
                        safeChar ':' = '-'
                        safeChar chr = chr

fetchXml :: String -> IO XmlTrees
fetchXml uri = do (filename, s) <- fetchString uri
                  let xml = parseXmlDocument uri s
                      errorMessage = do hashElem <- [ t | NTree (XTag qn _) t <- xml, localPart qn == "hash" ]
                                        [ s | NTree (XTag qn _) [ NTree (XText s) _ ] <- hashElem, localPart qn == "error" ]
                  case errorMessage of
                    s:_ -> do removeFile filename
                              fail ("Twitter API error: " ++ s)
                    [ ] -> return xml

fetchFriends :: String -> IO [ String ]
fetchFriends id = catch (do xml <- fetchXml ("http://twitter.com/statuses/friends/" ++ id ++ ".xml")
                            return (do usersElem <- [ t | NTree (XTag qn _) t <- xml, localPart qn == "users" ]
                                       userElem <- [ t | NTree (XTag qn _) t <- usersElem, localPart qn == "user" ]
                                       [ s | NTree (XTag qn _) [ NTree (XText s) _ ] <- userElem, localPart qn == "screen_name" ]))
                        catchError
                  where catchError e | isUserError e, ioeGetErrorString e == "Twitter API error: Not authorized" = return [ ]
                        catchError e | isUserError e, ioeGetErrorString e == "Twitter API error: Not found" = return [ ]
                        catchError e = ioError e
                        

main' :: String -> IO ()
main' id = do initCache
              myFriends <- fetchFriends id
              theirFriends <- mapM fetchFriends myFriends
              putStrLn "You should follow:"
              mapM_ print $ take 20
                          $ sortBy (comparing (negate . fst))
                          $ filter (flip notElem myFriends . snd)
                          $ map (\group -> (length group, head group))
                          $ group
                          $ sort
                          $ filter (/= id)
                          $ concat theirFriends

main :: IO Int
main = do catch (do args <- getArgs
                    case args of
                      [ id ] -> do main' id
                                   return 0
                      _ -> fail "Please provide a Twitter screen name on the command line")
                (\e -> do hPutStrLn stderr (show e)
                          return 1)