--- /dev/null
+GHC_WARNINGS := -Wall
+GHC_WARNINGS += -fwarn-hi-shadowing
+GHC_WARNINGS += -fwarn-missing-signatures
+GHC_WARNINGS += -fwarn-name-shadowing
+GHC_WARNINGS += -fwarn-orphans
+GHC_WARNINGS += -fwarn-type-defaults
+
+BIN=bin/twat
+
+.PHONY : test
+
+all: $(BIN)
+
+$(BIN): src/Twitter/*.hs src/*.hs
+ ghc -O2 $(GHC_WARNINGS) --make -o $(BIN) src/Twitter/*.hs src/*.hs
+
+profile: src/Twitter/*.hs src/*.hs
+ ghc -O2 $(GHC_WARNINGS) -prof -auto-all --make -o $(BIN) src/Twitter/*.hs src/*.hs
+
+clean:
+ rm -f $(BIN)
+ rm -f src/*.hi
+ rm -f src/Twitter/*.hi
+ rm -f src/*.o
+ rm -f src/Twitter/*.o
+ rm -f *.prof
+
+test:
+ runghc -i"src" test/TestSuite.hs
--- /dev/null
+-- The CommandLine module handles parsing of the command-line options.
+-- It should more or less be a black box, providing Main with only the
+-- information it requires.
+
+module CommandLine
+( help_set,
+ help_text,
+ from_email_address,
+ to_email_address,
+ parse_errors,
+ parse_usernames
+) where
+
+import Data.Maybe (isJust, isNothing)
+import System.Console.GetOpt
+import System.Environment (getArgs)
+
+
+
+-- A record containing values for all available options.
+data Options = Options { opt_help :: Bool,
+ opt_from :: Maybe String,
+ opt_to :: Maybe String }
+
+
+-- This constructs an instance of Options, with each of its members
+-- set to default values.
+default_options :: Options
+default_options = Options { opt_help = False,
+ opt_from = Nothing,
+ opt_to = Nothing }
+
+
+-- The options list that we construct associates a function with each
+-- option. This function is responsible for updating an Options record
+-- with the appropriate value.
+--
+-- For more information and an example of this idiom, see,
+--
+-- http://www.haskell.org/haskellwiki/High-level_option_handling_with_GetOpt
+--
+options :: [OptDescr (Options -> IO Options)]
+options =
+ [ Option ['h'][] (NoArg set_help) "Prints this help message.",
+ Option ['t'][] (ReqArg set_to "email_address") "Send tweets TO email_address.",
+ Option ['f'][] (ReqArg set_from "email_address") "Send tweets FROM email_address."
+ ]
+
+
+set_help :: Options -> IO Options
+set_help opts = do
+ return opts { opt_help = True }
+
+set_to :: String -> Options -> IO Options
+set_to arg opts = do
+ return opts { opt_to = Just arg }
+
+set_from :: String -> Options -> IO Options
+set_from arg opts = do
+ return opts { opt_from = Just arg }
+
+
+-- The usage header.
+usage :: String
+usage = "Usage: twat [-t to_address] [-f from_address] <username1> [username2, [username3]...]"
+
+
+-- The usage header, and all available flags (as generated by GetOpt)
+help_text :: String
+help_text = usageInfo usage options
+
+
+-- Return a list of options.
+parse_options :: IO Options
+parse_options = do
+ argv <- getArgs
+ let (actions, _, _) = getOpt Permute options argv
+
+ -- This will execute each of the functions contained in our options
+ -- list, one after another, on a default_options record. The end
+ -- result should be an Options instance with all of its members set
+ -- correctly.
+ opts <- foldl (>>=) (return default_options) actions
+
+ return opts
+
+
+username_errors :: IO [String]
+username_errors = do
+ argv <- getArgs
+ let (_, usernames, _) = getOpt Permute options argv
+
+ if (null usernames)
+ then return ["No usernames provided."]
+ else return []
+
+
+to_errors :: IO [String]
+to_errors = do
+ toaddr <- to_email_address
+ fromaddr <- from_email_address
+ if (isNothing toaddr) && (isJust fromaddr)
+ then return ["\"From\" address specified without \"To\" address."]
+ else return []
+
+from_errors :: IO [String]
+from_errors = do
+ toaddr <- to_email_address
+ fromaddr <- from_email_address
+ if (isJust toaddr) && (isNothing fromaddr)
+ then return ["\"To\" address specified without \"From\" address."]
+ else return []
+
+
+format_error :: String -> String
+format_error err = "ERROR: " ++ err ++ "\n"
+
+
+-- Return a list of errors.
+parse_errors :: IO [String]
+parse_errors = do
+ argv <- getArgs
+ let (_, _, errors) = getOpt Permute options argv
+ errs_username <- username_errors
+ errs_to <- to_errors
+ errs_from <- from_errors
+ return $ map format_error (errors ++ errs_username ++ errs_to ++ errs_from)
+
+-- Is the help option set?
+help_set :: IO Bool
+help_set = do
+ opts <- parse_options
+ return (opt_help opts)
+
+
+to_email_address :: IO (Maybe String)
+to_email_address = do
+ opts <- parse_options
+ return (opt_to opts)
+
+from_email_address :: IO (Maybe String)
+from_email_address = do
+ opts <- parse_options
+ return (opt_from opts)
+
+
+parse_usernames :: IO [String]
+parse_usernames = do
+ argv <- getArgs
+ let (_, usernames, _) = getOpt Permute options argv
+ return usernames
--- /dev/null
+module Mail
+where
+
+import Control.Concurrent
+import Control.Concurrent.MVar
+import Control.Exception (evaluate)
+import Data.List (intercalate)
+import System.Exit
+import System.Process
+import System.IO
+
+type Header = String
+
+data Message = Message { headers :: [Header],
+ subject :: String,
+ body :: String,
+ from :: String,
+ to :: String }
+ deriving (Eq)
+
+instance Show Message where
+ show m =
+ concat [ if (length (headers m) == 0) then "" else (intercalate "\n" (headers m)) ++ "\n",
+ "Subject: " ++ (subject m) ++ "\n",
+ "From: " ++ (from m) ++ "\n",
+ "To: " ++ (to m) ++ "\n",
+ "\n",
+ (body m) ]
+
+
+sendmail :: Message -> IO (String, String, ExitCode)
+sendmail message = do
+ let sendmail_args = ["-f",
+ (from message)]
+
+ (inh, outh, errh, ph) <-
+ runInteractiveProcess "/usr/bin/sendmail" sendmail_args Nothing Nothing
+
+ outm <- newEmptyMVar
+ outs <- hGetContents outh
+
+ errm <- newEmptyMVar
+ errs <- hGetContents errh
+
+ forkIO $ hPutStr inh (show message) >> hClose inh
+ forkIO $ evaluate (length outs) >> putMVar outm ()
+ forkIO $ evaluate (length errs) >> putMVar errm ()
+
+ readMVar outm
+ readMVar errm
+
+ ec <- waitForProcess ph
+ return (outs, errs, ec)
+
+
+print_sendmail_result :: (String, String, ExitCode) -> IO ()
+print_sendmail_result (outs, errs, ec) = do
+ case ec of
+ ExitSuccess -> return ()
+ _ -> putStrLn $ concat ["Output: " ++ outs,
+ "\nErrors: " ++ errs,
+ "\nExit Code: " ++ (show ec)]
--- /dev/null
+module Main
+where
+
+import Control.Concurrent (forkIO, threadDelay)
+import Control.Monad (forever, when)
+import System.Exit (ExitCode(..), exitWith)
+import System.IO (hPutStrLn, stderr)
+
+import CommandLine
+import Mail
+import Twitter.Http
+import Twitter.Status
+import Twitter.User
+
+exit_args_parse_failed :: Int
+exit_args_parse_failed = 1
+
+-- The length of all calls to sleep, in seconds.
+heartbeat :: Int
+heartbeat = 600
+
+thread_sleep :: Int -> IO ()
+thread_sleep microseconds = do
+ let seconds = microseconds * (10 ^ (6 :: Int))
+ threadDelay seconds
+
+
+message_from_status :: Message -> Status -> Message
+message_from_status message status =
+ message { subject = "Twat: " ++ (screen_name (user status)),
+ body = (pretty_print status) }
+
+recurse :: String -> Integer -> (Maybe Message) -> IO ()
+recurse username latest_status_id maybe_message = do
+ thread_sleep heartbeat
+ xmldata <- get_user_new_statuses username latest_status_id
+
+ -- Parsing an empty result can blow up. Just pretend there are
+ -- no new statuses in that case.
+ let new_statuses = case xmldata of
+ Just xml -> parse_statuses xml
+ Nothing -> []
+
+ case (length new_statuses) of
+ 0 ->
+ recurse username latest_status_id maybe_message
+ _ -> do
+ let new_latest_status_id = get_max_status_id new_statuses
+ mapM (putStrLn . pretty_print) new_statuses
+
+ case maybe_message of
+ Nothing -> do
+ recurse username new_latest_status_id maybe_message
+ return ()
+ Just message -> do
+ let messages = map (message_from_status message) new_statuses
+ sendmail_results <- mapM sendmail messages
+ mapM print_sendmail_result sendmail_results
+ recurse username new_latest_status_id maybe_message
+ return ()
+
+
+get_latest_status_id :: String -> IO Integer
+get_latest_status_id username = do
+ xmldata <- get_user_timeline username
+
+ let initial_statuses = case xmldata of
+ Just xml -> parse_statuses xml
+ Nothing -> []
+
+ case (length initial_statuses) of
+ 0 -> do
+ -- If the HTTP part barfs, try again after a while.
+ putStrLn ("Couldn't retrieve " ++ username ++ "'s timeline. Retrying...")
+ thread_sleep heartbeat
+ get_latest_status_id username
+ _ -> return (get_max_status_id initial_statuses)
+
+
+
+run_twat :: Maybe Message -> String -> IO ()
+run_twat message username = do
+ latest_status_id <- get_latest_status_id username
+ recurse username latest_status_id message
+ return ()
+
+
+main :: IO ()
+main = do
+ errors <- parse_errors
+
+ -- If there were errors parsing the command-line options,
+ -- print them and exit.
+ when (not (null errors)) $ do
+ hPutStrLn stderr (concat errors)
+ putStrLn help_text
+ exitWith (ExitFailure exit_args_parse_failed)
+
+ -- Next, check to see if the 'help' option was passed to the
+ -- program. If it was, display the help, and exit successfully.
+ help_opt_set <- help_set
+ when help_opt_set $ do
+ putStrLn help_text
+ exitWith ExitSuccess
+
+ usernames <- parse_usernames
+
+ -- If we have both a "To" and "From" address, we'll create a
+ -- message object to be passed to all of our threads.
+ to_address <- to_email_address
+ from_address <- from_email_address
+ let message = case to_address of
+ Nothing -> Nothing
+ Just toaddr ->
+ case from_address of
+ Nothing -> Nothing
+ Just fromaddr ->
+ Just (Message { headers = [],
+ body = "",
+ subject = "",
+ to = toaddr,
+ from = fromaddr })
+
+ -- Execute run_twat on each username in a new thread.
+ mapM (forkIO . (run_twat message)) usernames
+
+ forever $ do
+ -- This thread (the one executing main) doesn't do anything,
+ -- but when it terminates, so do all the threads we forked.
+ -- As a result, we need to keep this thread on life support.
+ thread_sleep heartbeat
+
+ return ()
--- /dev/null
+module Twitter.Http
+where
+
+import Network.Curl
+import System.IO (hPutStrLn, stderr)
+
+--
+-- http://dev.twitter.com/doc/get/statuses/user_timeline
+--
+user_timeline_url :: String -> String
+user_timeline_url username =
+ concat [ "http://api.twitter.com/1/statuses/user_timeline.xml",
+ "?screen_name=" ++ username,
+ "&include_rts=true",
+ "&count=10" ]
+
+user_new_statuses_url :: String -> Integer -> String
+user_new_statuses_url username last_status_id =
+ concat [ user_timeline_url username,
+ "&since_id=" ++ (show last_status_id) ]
+
+
+get_user_timeline :: String -> IO (Maybe String)
+get_user_timeline username = do
+ let uri = (user_timeline_url username)
+ timeline <- (http_get uri)
+ return timeline
+
+
+get_user_new_statuses :: String -> Integer -> IO (Maybe String)
+get_user_new_statuses username last_status_id = do
+ let uri = (user_new_statuses_url username last_status_id)
+ new_statuses <- (http_get uri)
+ return new_statuses
+
+
+http_get :: String -> IO (Maybe String)
+http_get uri = withCurlDo $ do
+ resp <- curlGetString uri [CurlTimeout 45]
+
+ case resp of
+ (CurlOK, body) -> return (Just body)
+ (code, _) -> do
+ hPutStrLn stderr ("HTTP Error: " ++ (show code))
+ return Nothing
--- /dev/null
+module Twitter.Status
+where
+
+import Data.Maybe
+import Text.XML.HaXml
+
+import Twitter.User
+import Twitter.Xml
+
+data Status = Status { status_id :: Integer,
+ created_at :: String,
+ text :: String,
+ user :: User }
+ deriving (Show, Eq)
+
+
+
+
+status_from_content :: Content -> (Maybe Status)
+status_from_content content =
+
+ if (length status_ids) == 0
+ || (length created_ats) == 0
+ || (length texts) == 0
+ || (length users) == 0
+ then
+ Nothing
+ else
+ case first_status_id of
+ Nothing -> Nothing
+ (Just status_id_data) ->
+ case first_created_at of
+ Nothing -> Nothing
+ (Just created_at_data) ->
+ case first_user of
+ Nothing -> Nothing
+ (Just user_object) ->
+ case (reads status_id_data :: [(Integer, String)]) of
+ [] -> Nothing
+ parseresult:_ -> Just (Status (fst parseresult) created_at_data all_text user_object)
+
+ where
+ status_ids = (unique_id content)
+ first_status_id = get_char_data (status_ids !! 0)
+
+ created_ats = (status_created_at content)
+ first_created_at = get_char_data (created_ats !! 0)
+
+ texts = (status_text content)
+ all_text = concat $ catMaybes (map get_char_data texts)
+
+ users = (status_user content)
+ first_user = user_from_content (users !! 0)
+
+
+
+parse_statuses :: String -> [Status]
+parse_statuses xml_data =
+ catMaybes maybe_statuses
+ where
+ (Document _ _ root _) = xmlParse xml_file_name xml_data
+ root_elem = CElem root
+ status_elements = (all_statuses root_elem)
+ maybe_statuses = map status_from_content status_elements
+
+
+-- This is a required parameter to the xmlParse function used in
+-- error reporting. We're not parsing a function, though, so we
+-- leave it blank.
+xml_file_name :: String
+xml_file_name = ""
+
+pretty_print :: Status -> String
+pretty_print status =
+ concat [ name,
+ " - ",
+ (created_at status),
+ "\n",
+ replicate ((length name) + 3 + (length (created_at status))) '-',
+ "\n",
+ replace_entities (text status),
+ "\n" ]
+ where
+ name = screen_name (user status)
+
+
+
+get_max_status_id :: [Status] -> Integer
+get_max_status_id statuses =
+ maximum status_ids
+ where
+ status_ids = map status_id statuses
\ No newline at end of file
--- /dev/null
+module Twitter.User
+where
+
+import Text.XML.HaXml
+
+import Twitter.Xml
+
+data User = User { screen_name :: String }
+ deriving (Show, Eq)
+
+
+user_from_content :: Content -> (Maybe User)
+user_from_content c =
+ if (length names) == 0
+ then
+ Nothing
+ else
+ case (get_char_data (names !! 0)) of
+ Nothing -> Nothing
+ (Just content) -> Just (User (content))
+
+ where
+ names = user_screen_name c
--- /dev/null
+module Twitter.Xml
+where
+
+import Data.Maybe
+import Text.Regex (mkRegex, subRegex)
+import Text.XML.HaXml
+
+get_char_data :: Content -> (Maybe CharData)
+get_char_data (CString _ cd) = Just cd
+get_char_data (CRef ref) = Just (verbatim ref) -- Entities.
+get_char_data _ = Nothing
+
+
+all_statuses :: CFilter
+all_statuses = (tag "statuses" /> tag "status")
+
+-- Called unique_id here because status_id is used elsewhere.
+unique_id :: CFilter
+unique_id = keep /> (tag "id") /> txt
+
+status_created_at :: CFilter
+status_created_at = keep /> (tag "created_at") /> txt
+
+status_text :: CFilter
+status_text = keep /> (tag "text") /> txt
+
+status_user :: CFilter
+status_user = keep /> (tag "user")
+
+user_screen_name :: CFilter
+user_screen_name = keep /> (tag "screen_name") /> txt
+
+
+xml_entities :: [(String, String)]
+xml_entities = [("[lr]dquo", "\""),
+ ("[mn]dash", "-"),
+ ("nbsp", " "),
+ ("#8217", "'"),
+ ("amp", "&"),
+ ("lt", "<"),
+ ("gt", ">")]
+
+replace_entities :: String -> String
+replace_entities target = unescape_recursive xml_entities target
+
+unescape_recursive :: [(String, String)] -> String -> String
+unescape_recursive [] target = target
+unescape_recursive replacements target =
+ unescape_recursive (tail replacements) (subRegex (mkRegex from) target to)
+ where
+ replacement = (replacements !! 0)
+ from = "&" ++ (fst replacement) ++ ";"
+ to = (snd replacement)
projects / dead / halcyon.git / commitdiff