notifications-tray-icon-0.1.1.0: app/Main.hs

module Main where

import           Control.Concurrent
import           Control.Monad
import           Control.Monad.Trans.Class
import qualified Data.ByteString.Char8 as BS
import           Data.Semigroup ((<>))
import qualified Data.Text as T
import           Data.Tuple.Sequence
import           Data.Version (showVersion)
import qualified GitHub.Auth as GH
import           Options.Applicative
import           StatusNotifier.Item.Notifications.GitHub
import           StatusNotifier.Item.Notifications.OverlayIcon
import           StatusNotifier.Item.Notifications.Util
import           System.Console.Haskeline
import           System.Log.Logger
import           Text.Printf

import           Paths_notifications_tray_icon (version)

iconNameParser :: Parser String
iconNameParser = strOption
  (  long "icon-name"
  <> short 'n'
  <> metavar "NAME"
  <> value "github"
  <> help "The icon the item will display"
  )

overlayIconNameParser :: Parser String
overlayIconNameParser = strOption
  (  long "overlay-icon-name"
  <> short 'o'
  <> metavar "NAME"
  <> value "github"
  <> help "The overlay icon that will be displayed when notifications are present"
  )

busNameParser :: Parser String
busNameParser = strOption
  (  long "bus-name"
  <> short 'b'
  <> metavar "BUS-NAME"
  <> value "org.Github.Notifications"
  )

githubTokenAuthParser :: Parser (IO GH.Auth)
githubTokenAuthParser = fmap (GH.OAuth . BS.pack . T.unpack . T.strip . T.pack) <$>
  (passGetMain <$> strOption
  (  long "github-token-pass"
  <> metavar "TOKEN-NAME"
  <> help "Use pass to get a token password to authenticate with github"
  ) <|>
  (gitConfigGet <$> strOption
  (  long "github-token-config"
  <> metavar "TOKEN-KEY"
  <> help "Get a github token using the provided git config key"
  )) <|>
  (return <$> strOption
  (  long "github-token-string"
  <> metavar "TOKEN"
  <> help "Provide the github token as a value"
  )))

gitConfigGet :: String -> IO String
gitConfigGet key = do
  Right value <- runCommandFromPath ["git", "config", "--get", key]
  return value

githubConfigAuthParser :: Parser (IO GH.Auth)
githubConfigAuthParser =
  fmap githubAuthFromUsernamePassword <$> usernamePasswordParser
  where usernamePasswordParser =
          runGitConfigCommands <$> userOption <*> passwordOption
        userOption = strOption
                 (  long "github-config-user"
                 <> metavar "USER-KEY"
                 <> help "The git config key to use to get the github user"
                 )
        passwordOption = strOption
                 (  long "github-config-password"
                 <> metavar "PASSWORD-KEY"
                 <> help "The git config key to use to get the github password"
                 )
        runGitConfigCommands userKey passwordKey = do
          username <- gitConfigGet userKey
          password <- gitConfigGet passwordKey
          return (username, password)

getUsernameAndPassword :: IO (String, String)
getUsernameAndPassword =
  runInputT defaultSettings $ sequenceT (getU, getP)
    where getP :: InputT IO String
          getP = getPassword (Just '*') "password: " >>= maybe getP pure
          getU :: InputT IO String
          getU = getInputLine "username: " >>= maybe getU pure

githubAuthFromUsernamePassword (username, password) =
  GH.BasicAuth (BS.pack username) (BS.pack password)

githubConsoleAuthParser :: Parser (IO GH.Auth)
githubConsoleAuthParser =
  flag' (githubAuthFromUsernamePassword <$> getUsernameAndPassword) $
  long "github-basic-auth"

githubAuthParser =
  githubTokenAuthParser <|> githubConfigAuthParser <|> githubConsoleAuthParser

githubParser :: Parser (IO GitHubConfig)
githubParser = fmap <$> helper <*> githubAuthParser
  where helper =
          flip GitHubConfig <$> option auto
            (  long "poll-interval"
            <> help "The amount of time to wait between refreshes of notification data"
            <> value 30
            <> metavar "SECONDS"
            )

updaterParser
  =   (fmap githubUpdaterNew <$> githubParser)
  <|> (flag' (return $ sampleUpdater ) $ long "sample")

logParser =
  option auto
  (  long "log-level"
  <> short 'l'
  <> help "Set the log level"
  <> metavar "LEVEL"
  <> value WARNING
  )

params iconName overlayIconName busName notifications = OverlayIconParams
  { iconName = iconName
  , iconPath = "/StatusNotifierItem"
  , iconDBusName = busName
  , getOverlayName = \count -> return $ if count > 0 then T.pack overlayIconName else ""
  , runUpdater = notifications
  }

startOverlayIcon getUpdater iconName overlayIconName logLevel busName = do
  logger <- getLogger "StatusNotifier.Item.Notifications"
  saveGlobalLogger $ setLevel logLevel logger
  dbusLogger <- getLogger "DBus"
  saveGlobalLogger $ setLevel logLevel dbusLogger
  (params iconName overlayIconName busName <$> getUpdater) >>= buildOverlayIcon

parser =
  startOverlayIcon
  <$> updaterParser <*> iconNameParser <*> overlayIconNameParser
  <*> logParser <*> busNameParser

versionOption :: Parser (a -> a)
versionOption = infoOption
                (printf "notifications-tray-icon %s" versionString)
                (  long "version"
                <> (help $
                    printf "Show the version number of notifications-tray-icon (%s)"
                    versionString)
                )
  where versionString = showVersion version

main :: IO ()
main = do
  join $ execParser $ info (helper <*> versionOption <*> parser)
         (  fullDesc
         <> progDesc "Run a notification monitoring tray icon"
         )
  -- TODO: Come up with a better way to hang indefinitely
  void $ forever $ threadDelay 999999999999999999