Util.hs

module StatusNotifier.Item.Notifications.Util where

import           Control.Arrow
import           Control.Monad.Fail
import           Control.Monad.IO.Class
import           DBus
import           DBus.Client (Client, call)
import           Data.Int (Int32)
import qualified Data.Map as M
import           Data.Maybe
import qualified Data.Text as T
import           Data.Word (Word32)
import           GI.Dbusmenu hiding (Client)
import           System.Exit (ExitCode (..))
import           System.Log.Logger
import qualified System.Process as P
import           Text.Printf
import           Text.Regex

fieldRegex :: Regex
fieldRegex = mkRegexWithOpts "^(.*?): *(.*?)$" True True

runCommandFromPath :: MonadIO m => [String] -> m (Either String String)
runCommandFromPath = runCommand "/usr/bin/env"

-- | Run the provided command with the provided arguments.
runCommand :: MonadIO m => FilePath -> [String] -> m (Either String String)
runCommand cmd args = liftIO $ do
  (ecode, stdout, stderr) <- P.readProcessWithExitCode cmd args ""
  logM "System.Taffybar.Util" INFO $
       printf "Running command %s with args %s" (show cmd) (show args)
  return $ case ecode of
    ExitSuccess -> Right stdout
    ExitFailure exitCode -> Left $ printf "Exit code %s: %s " (show exitCode) stderr

passGet :: (MonadFail m, MonadIO m) => String -> m (Either String (String, [(String, String)]))
passGet credentialName =
  right (getPassComponents . lines) <$>
        runCommandFromPath ["pass", "show", credentialName]
  where getPassComponents [] = ("", [])
        getPassComponents (firstLine:restLines) =
          let entries =
                map buildEntry $ catMaybes $
                    matchRegex fieldRegex <$> restLines
              buildEntry [fieldName, fieldValue] = (fieldName, fieldValue)
              buildEntry _ = ("", "")
          in (firstLine, entries)

passGetMain :: (MonadFail m, MonadIO m) => String -> m String
passGetMain name = do
  Right (value, _) <- passGet name
  return value

runDetached :: [String] -> IO (Either String String)
runDetached args = do
  logM "System.Taffybar.Util" INFO $
       printf "Starting detached command with args %s" (show args)
  (_, _, _, _) <-
    P.createProcess
      (P.proc "/usr/bin/env" args)
        { P.std_in = P.NoStream
        , P.std_out = P.NoStream
        , P.std_err = P.NoStream
        , P.close_fds = True
        }
  return $ Right ""

xdgOpen :: MonadIO m => [String] -> m (Either String String)
xdgOpen args = liftIO $ do
  -- Route URL handlers through systemd so browsers are not parented to the
  -- long-running tray icon service. Otherwise xdg-open can pull Chrome/Electron
  -- into this service's cgroup and make restarts kill unrelated GUI apps.
  result <- runCommandFromPath
    ( [ "systemd-run"
      , "--user"
      , "--collect"
      , "--quiet"
      , "/usr/bin/env"
      , "xdg-open"
      ]
      ++ args
    )
  either (const $ runDetached ("xdg-open":args)) (const $ return result) result

openURL :: MonadIO m => String -> m (Either String String)
openURL = xdgOpen . return

makeMenuItemWithLabel :: T.Text -> IO Menuitem
makeMenuItemWithLabel text = do
  menuItem <- menuitemNew
  textVariant <- liftIO $ toGVariant text
  menuitemPropertySetVariant menuItem "label" textVariant
  return menuItem

makeSeparatorMenuItem :: IO Menuitem
makeSeparatorMenuItem = undefined

-- | Send a notification through org.freedesktop.Notifications.
sendDesktopNotification
  :: Client
  -> T.Text -- ^ Application name
  -> T.Text -- ^ Icon name
  -> T.Text -- ^ Summary
  -> T.Text -- ^ Body
  -> IO (Either String Word32)
sendDesktopNotification client appName icon summary body = do
  result <- call client
    (methodCall "/org/freedesktop/Notifications"
                "org.freedesktop.Notifications" "Notify")
    { methodCallDestination = Just "org.freedesktop.Notifications"
    , methodCallBody =
        [ toVariant appName
        , toVariant (0 :: Word32)
        , toVariant icon
        , toVariant summary
        , toVariant body
        , toVariant ([] :: [T.Text])
        , toVariant (M.empty :: M.Map T.Text Variant)
        , toVariant (-1 :: Int32)
        ]
    }
  return $ case result of
    Left err -> Left $ methodErrorMessage err
    Right reply -> case methodReturnBody reply of
      [v] | Just notificationId <- fromVariant v -> Right notificationId
      other -> Left $ printf "Unexpected Notify reply: %s" (show other)