{-# LANGUAGE DoAndIfThenElse #-}

module Main
where

import Control.Concurrent ( forkIO, threadDelay )
import Control.Exception ( throw )
import Control.Monad ( forever, when )
import Data.Aeson ( decode )
import Data.Maybe ( fromMaybe, isNothing )
import Data.Monoid ( (<>) )
import Data.Time.LocalTime ( TimeZone, getCurrentTimeZone )
import System.Console.CmdArgs.Default ( Default(..) )
import System.Directory ( doesFileExist )
import System.Exit ( ExitCode(..), exitWith )
import System.IO ( hPutStrLn, stderr )
import System.IO.Error ( catchIOError )

import CommandLine ( get_args, show_help )
import Configuration ( Cfg(..), merge_optional )
import ExitCodes ( exit_no_usernames, exit_pidfile_exists )
import qualified OptionalConfiguration as OC ( from_rc )
import Mail (
  Message(..),
  print_sendmail_result,
  rfc822_now,
  sendmail )
import Twitter.Http ( get_user_new_statuses, get_user_timeline )
import Twitter.Status (
  Status(..),
  Timeline,
  get_max_status_id,
  pretty_print,
  utc_time_to_rfc822 )
import Twitter.User ( User(..) )
import Unix ( full_daemonize )
import Usernames ( Usernames(..) )


-- | A wrapper around threadDelay which takes seconds instead of
--   microseconds as its argument.
--
thread_sleep :: Int -> IO ()
thread_sleep seconds = do
  let microseconds = seconds * (10 ^ (6 :: Int))
  threadDelay microseconds


-- | Given a 'Message', 'Status', and date, update that message's body
--   and subject with the information contained in the status. Adds a
--   /Date: / header, and returns the updated message.
--
message_from_status :: Maybe TimeZone -> Message -> String -> Status -> Message
message_from_status mtz message default_date status =
  message { subject = "Halcyon: " ++ (screen_name (user status)),
            body    = (pretty_print mtz status),
            headers = ((headers message) ++ ["Date: " ++ date])}
  where
    date = maybe
             default_date -- default
             (utc_time_to_rfc822 mtz) -- function to apply if not Nothing
             (created_at status) -- the Maybe thing


-- | If the given 'Message' is not 'Nothing', send a copy of it for
--   every 'Status' in the @statuses@ list.
--
send_messages :: Cfg -> Maybe TimeZone -> Maybe Message -> [Status] -> IO ()
send_messages cfg mtz maybe_message statuses =
  case maybe_message of
    Nothing -> return ()
    Just message -> do
      default_date <- rfc822_now
      let mfs = message_from_status mtz message default_date
      let messages = map mfs statuses
      sendmail_results <- mapM sendmail' messages
      mapM_ print_sendmail_result sendmail_results
  where
    sendmail' = sendmail (sendmail_path cfg)


-- | Display the number of skipped replies if ignore_replies is true
--   and verbose is enabled.
--
mention_replies :: Cfg -> [Status] -> IO ()
mention_replies cfg ss = do
  let replies  = filter reply ss
  when ((ignore_replies cfg) && (verbose cfg)) $ do
    let countstr = show $ length replies
    putStrLn $ "Ignoring " ++ countstr ++ " replies."


-- | Display the number of skipped retweets if ignore_retweets is true
--   and verbose is enabled.
--
mention_retweets :: Cfg -> [Status] -> IO ()
mention_retweets cfg ss = do
  let retweets = filter retweeted ss
  when ((ignore_retweets cfg) && (verbose cfg)) $ do
    let countstr = show $ length retweets
    putStrLn  $ "Ignoring " ++ countstr ++ " retweets."



-- | Filter out replies/retweets based on the configuration.
--
filter_statuses :: Cfg -> [Status] -> [Status]
filter_statuses cfg =
  reply_filter . retweet_filter
  where
    reply_filter = if ignore_replies cfg
                   then filter (not . reply)
                   else id

    retweet_filter = if ignore_retweets cfg
                     then filter (not . retweeted)
                     else id


-- | This is the main recursive loop. It takes a the configuration, a
--   username, a latest_status_id, and optionally a 'Message' as
--   arguments. The @latest_status_id@ is the last status (that we know
--   of) to be posted to username's Twitter account. If we find any
--   newer statuses when we check, they are printed and optionally
--   emailed (if a 'Message' was supplied). Then, the process repeats.
--
recurse :: Cfg -> String -> Integer -> (Maybe Message) -> IO ()
recurse cfg username latest_status_id maybe_message = do
  thread_sleep (heartbeat cfg)
  timeline <- get_user_new_statuses cfg username latest_status_id

  let decoded_timeline = decode timeline :: Maybe Timeline

  when (isNothing decoded_timeline) $
    hPutStrLn stderr $
      "Couldn't retrieve "
      ++ username
      ++ "'s timeline. Skipping..."

  let new_statuses = fromMaybe [] decoded_timeline

  case new_statuses of
    [] -> do_recurse latest_status_id
    _  -> do
      mention_replies cfg new_statuses
      mention_retweets cfg new_statuses

      let good_statuses = filter_statuses cfg new_statuses

      tz <- getCurrentTimeZone
      let mtz = Just tz
      mapM_ (putStr . (pretty_print mtz)) good_statuses

      send_messages cfg mtz maybe_message good_statuses

      let new_latest_status_id = get_max_status_id new_statuses
      do_recurse new_latest_status_id

  where
    -- This lets us write all of these parameters once rather
    -- than... more than once.
    do_recurse :: Integer -> IO ()
    do_recurse lsi = recurse cfg username lsi maybe_message


-- | Try continually to download username's timeline, and determine the
--   latest status id to be posted once we have done so.
--
get_latest_status_id :: Cfg -> String -> IO Integer
get_latest_status_id cfg username = do
  let delay = heartbeat cfg
  timeline <- get_user_timeline cfg username

  let decoded_timeline = decode timeline :: Maybe Timeline

  when (isNothing decoded_timeline) $
    hPutStrLn stderr $
      "Couldn't retrieve "
      ++ username
      ++ "'s timeline. Skipping..."

  let initial_timeline = fromMaybe [] decoded_timeline

  case initial_timeline of
    [] -> do
      -- If the HTTP part barfs, try again after a while.
      thread_sleep delay
      get_latest_status_id cfg username
    _  ->
      return (get_max_status_id initial_timeline)



-- | This function wraps two steps. First, we need to find the latest
--   status id posted by username. Once we have that, we can begin the
--   recursive loop that checks for updates forever. The message
--   argument is optional and is passed to recurse in case the updates
--   should be emailed.
--
run :: Cfg -> Maybe Message -> String -> IO ()
run cfg msg username = do
  latest_status_id <- get_latest_status_id cfg username
  recurse cfg username latest_status_id msg



-- | Take advantage of the Maybe monad to only return a message when
--   we have both a \"to\" and \"from\" address.
--
construct_message :: Cfg -> Maybe Message
construct_message cfg = do
  to_addr <- to_address cfg
  from_addr <- from_address cfg
  return $ def { to = to_addr, from = from_addr }


-- | The main function just parses the command-line arguments and then
--   forks off calls to 'run' for each supplied username. After
--   forking, main loops forever.
--
main :: IO ()
main = do
  -- And a Cfg object.
  rc_cfg  <- OC.from_rc
  cmd_cfg <- get_args

  -- Merge the config file options with the command-line ones,
  -- prefering the command-line ones.
  let opt_config = rc_cfg <> cmd_cfg

  -- Finally, update a default config with any options that have been
  -- set in either the config file or on the command-line.
  let cfg = merge_optional (def :: Cfg) opt_config

  when (null $ get_usernames (usernames cfg)) $ do
    hPutStrLn stderr "ERROR: no usernames supplied."
    _ <- show_help
    exitWith (ExitFailure exit_no_usernames)


  when (daemonize cfg) $ do
    -- Old PID files can be left around after an unclean shutdown. We
    -- only care if we're running as a daemon.
    pidfile_exists <- doesFileExist (pidfile cfg)
    when pidfile_exists $ do
      hPutStrLn stderr $ "ERROR: PID file " ++ (pidfile cfg) ++
                         " already exists. Refusing to start."
      exitWith (ExitFailure exit_pidfile_exists)


  -- If we have both a "To" and "From" address, we'll create a
  -- message object to be passed to all of our threads.
  let message = construct_message cfg
  let run_curried = run cfg message

  let run_program = (mapM_ -- Execute run on each username in a new thread.
                      (forkIO . run_curried)
                      (get_usernames (usernames cfg)))
                    >>
                    -- 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.  If we were
                    -- asked to daemonize, do that; otherwise just run
                    -- the thing.
                    forever (thread_sleep (heartbeat cfg))

  if (daemonize cfg)
  then try_daemonize cfg run_program
  else run_program

  where
    -- | A exception handler around full_daemonize. If full_daemonize
    --   doesn't work, we report the error and crash. This is fine; we
    --   only need the program to be resilient once it actually starts.
    --
    try_daemonize :: Cfg -> IO () -> IO ()
    try_daemonize cfg program =
      catchIOError
        (full_daemonize cfg program)
        (\e -> do
          hPutStrLn stderr ("ERROR: " ++ (show e))
          throw e)