content: {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE CPP #-}
  -----------------------------------------------------------------------------
  -- |
  -- Module      : System.Taffybar.Util
  -- Copyright   : (c) Ivan A. Malison
  -- License     : BSD3-style (see LICENSE)
  --
  -- Maintainer  : Ivan A. Malison
  -- Stability   : unstable
  -- Portability : unportable
  -----------------------------------------------------------------------------
  
  module System.Taffybar.Util (
    -- * Configuration
      taffyStateDir
    -- * GTK concurrency
    , module Gtk
    -- * GLib
    , catchGErrorsAsLeft
    -- * Logging
    , logPrintF
    -- * Text
    , truncateString
    , truncateText
    -- * Resources
    , downloadURIToPath
    , getPixbufFromFilePath
    , safePixbufNewFromFile
    -- * Logic Combinators
    , (<||>)
    , (<|||>)
    , forkM
    , ifM
    , anyM
    , maybeTCombine
    , maybeToEither
    -- * Control
    , foreverWithVariableDelay
    , foreverWithDelay
    -- * Process control
    , runCommand
    , onSigINT
    , maybeHandleSigHUP
    , handlePosixSignal
    -- * Resource management
    , rebracket
    , rebracket_
    -- * Deprecated
    , logPrintFDebug
    , liftReader
    , liftActionTaker
    , (??)
    , runCommandFromPath
    ) where
  
  import           Conduit
  import           Control.Applicative
  import           Control.Arrow ((&&&))
  import           Control.Concurrent (ThreadId, forkIO, threadDelay)
  import qualified Control.Concurrent.MVar as MV
  import           Control.Exception.Base
  import           Control.Monad
  import           Control.Monad.Trans.Maybe
  import           Control.Monad.Trans.Reader
  import           Data.Either.Combinators
  import           Data.GI.Base.GError
  import           Control.Exception.Enclosed (catchAny)
  import           Data.GI.Gtk.Threading as Gtk (postGUIASync, postGUISync)
  import           Data.GI.Gtk.Threading (postGUIASyncWithPriority)
  import           Data.Maybe
  import           Data.IORef (newIORef, readIORef, writeIORef)
  import qualified Data.Text as T
  import           Data.Tuple.Sequence
  import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk
  import qualified GI.GLib.Constants as G
  import           Network.HTTP.Simple
  import           System.Directory
  import           System.Environment.XDG.BaseDir
  import           System.Exit (ExitCode (..), exitWith)
  import           System.FilePath.Posix
  import           System.IO (hIsTerminalDevice, stdout, stderr)
  import           System.Log.Logger
  import           System.Posix.Signals (Signal, Handler(..), installHandler, sigHUP, sigINT)
  import qualified System.Process as P
  import           Text.Printf
  
  
  taffyStateDir :: IO FilePath
  taffyStateDir = getUserDataDir "taffybar"
  
  {-# DEPRECATED liftReader "Use Control.Monad.Trans.Reader.mapReaderT instead" #-}
  liftReader :: Monad m => (m1 a -> m b) -> ReaderT r m1 a -> ReaderT r m b
  liftReader = mapReaderT
  
  logPrintF
    :: (MonadIO m, Show t)
    => String -> Priority -> String -> t -> m ()
  logPrintF logPath priority format toPrint =
    liftIO $ logM logPath priority $ printf format $ show toPrint
  
  {-# DEPRECATED logPrintFDebug "Use logPrintF instead" #-}
  logPrintFDebug :: (MonadIO m, Show t) => String -> String -> t -> m ()
  logPrintFDebug path = logPrintF path DEBUG
  
  infixl 4 ??
  (??) :: Functor f => f (a -> b) -> a -> f b
  fab ?? a = fmap ($ a) fab
  {-# INLINE (??) #-}
  {-# DEPRECATED (??) "Use @f <*> pure a@ instead" #-}
  
  ifM :: Monad m => m Bool -> m a -> m a -> m a
  ifM cond whenTrue whenFalse =
    cond >>= (\bool -> if bool then whenTrue else whenFalse)
  
  forkM :: Monad m => (c -> m a) -> (c -> m b) -> c -> m (a, b)
  forkM a b = sequenceT . (a &&& b)
  
  maybeToEither :: b -> Maybe a -> Either b a
  maybeToEither = flip maybe Right . Left
  
  truncateString :: Int -> String -> String
  truncateString n incoming
    | length incoming <= n = incoming
    | otherwise = take n incoming ++ "…"
  
  truncateText :: Int -> T.Text -> T.Text
  truncateText n incoming
    | T.length incoming <= n = incoming
    | otherwise = T.append (T.take n incoming) "…"
  
  -- | Run the provided command with the provided arguments.
  --
  -- If the command filename does not contain a slash, then the @PATH@
  -- environment variable is searched for the executable.
  runCommand :: MonadIO m => FilePath -> [String] -> m (Either String String)
  runCommand cmd args = liftIO $ do
    (ecode, out, err) <- 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 out
      ExitFailure exitCode -> Left $ printf "Exit code %s: %s " (show exitCode) err
  
  {-# DEPRECATED runCommandFromPath "Use runCommand instead" #-}
  runCommandFromPath :: MonadIO m => FilePath -> [String] -> m (Either String String)
  runCommandFromPath = runCommand
  
  -- | A variant of 'bracket' which allows for reloading.
  --
  -- The first parameter is an allocation function which returns a newly
  -- created value of type @r@, paired with an @IO@ action which will
  -- destroy that value.
  --
  -- The second parameter is the action to run. It is passed a "reload"
  -- function which will run the allocation function and return the
  -- newly created value.
  --
  -- Initially, there is no value. Reloading will cause the previous
  -- value (if any) to be destroyed. When the action completes, the
  -- current value (if any) will be destroyed.
  rebracket :: IO (IO (), r) -> (IO r -> IO a) -> IO a
  rebracket alloc action = bracket setup teardown (action . reload)
    where
      cleanup = fst
      resource = snd
      setup = MV.newMVar Nothing
      teardown = maybeTeardown <=< MV.takeMVar
      maybeTeardown = maybe (pure ()) cleanup
      reload var = MV.modifyMVar var $ \stale -> do
        maybeTeardown stale
        fresh <- alloc
        pure (Just fresh, resource fresh)
  
  -- | A variant of 'rebracket' where the resource value isn't needed.
  --
  -- And because the resource value isn't needed, this variant will
  -- automatically allocate the resource before running the enclosed
  -- action.
  rebracket_ :: IO (IO ()) -> (IO () -> IO a) -> IO a
  rebracket_ alloc action = rebracket ((, ()) <$> alloc) $
    \reload -> reload >> action reload
  
  -- | Execute the provided IO action at the provided interval.
  foreverWithDelay :: (MonadIO m, RealFrac d) => d -> IO () -> m ThreadId
  foreverWithDelay delay action =
    foreverWithVariableDelay $ safeAction >> return delay
    where safeAction =
            catchAny action $ \e ->
              logPrintF "System.Taffybar.Util" WARNING "Error in foreverWithDelay %s" e
  
  -- | Execute the provided IO action, and use the value it returns to decide how
  -- long to wait until executing it again. The value returned by the action is
  -- interpreted as a number of seconds.
  foreverWithVariableDelay :: (MonadIO m, RealFrac d) => IO d -> m ThreadId
  foreverWithVariableDelay action = liftIO $ forkIO $ action >>= delayThenAction
    where delayThenAction delay =
            threadDelay (floor $ delay * 1000000) >> action >>= delayThenAction
  
  liftActionTaker
    :: (Monad m)
    => ((a -> m a) -> m b) -> (a -> ReaderT c m a) -> ReaderT c m b
  liftActionTaker actionTaker action = do
    ctx <- ask
    lift $ actionTaker $ flip runReaderT ctx . action
  
  maybeTCombine
    :: Monad m
    => m (Maybe a) -> m (Maybe a) -> m (Maybe a)
  maybeTCombine a b = runMaybeT $ MaybeT a <|> MaybeT b
  
  infixl 3 <||>
  (<||>) ::
    Monad m =>
    (t -> m (Maybe a)) -> (t -> m (Maybe a)) -> t -> m (Maybe a)
  a <||> b = combineOptions
    where combineOptions v = maybeTCombine (a v) (b v)
  
  infixl 3 <|||>
  (<|||>)
    :: Monad m
    => (t -> t1 -> m (Maybe a))
    -> (t -> t1 -> m (Maybe a))
    -> t
    -> t1
    -> m (Maybe a)
  a <|||> b = combineOptions
    where combineOptions v v1 = maybeTCombine (a v v1) (b v v1)
  
  catchGErrorsAsLeft :: IO a -> IO (Either GError a)
  catchGErrorsAsLeft action = catch (Right <$> action) (return . Left)
  
  catchGErrorsAsNothing :: IO a -> IO (Maybe a)
  catchGErrorsAsNothing = fmap rightToMaybe . catchGErrorsAsLeft
  
  safePixbufNewFromFile :: FilePath -> IO (Maybe Gdk.Pixbuf)
  safePixbufNewFromFile =
    handleResult . catchGErrorsAsNothing . Gdk.pixbufNewFromFile
    where
  #if MIN_VERSION_gi_gdkpixbuf(2,0,26)
      handleResult = fmap join
  #else
      handleResult = id
  #endif
  
  getPixbufFromFilePath :: FilePath -> IO (Maybe Gdk.Pixbuf)
  getPixbufFromFilePath filepath = do
    result <- safePixbufNewFromFile filepath
    when (isNothing result) $
         logM "System.Taffybar.WindowIcon" WARNING $
              printf "Failed to load icon from filepath %s" filepath
    return result
  
  downloadURIToPath :: Request -> FilePath -> IO ()
  downloadURIToPath uri filepath =
    createDirectoryIfMissing True directory >>
    runConduitRes (httpSource uri getResponseBody .| sinkFile filepath)
    where (directory, _) = splitFileName filepath
  
  anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
  anyM _ [] = return False
  anyM p (x:xs) = do
    q <- p x
    if q
    then return True
    else anyM p xs
  
  -- | Installs a useful posix signal handler for 'sigINT' (i.e. Ctrl-C)
  -- for cases when the 'Control.Exception.UserInterrupt' exception gets
  -- swallowed within a main loop, preventing the program from exiting.
  --
  -- The given callback should be a command which causes the main loop
  -- action to exit. For example:
  --
  -- > Gtk.main `onSigINT` Gtk.mainQuit
  --
  -- If the signal handler was invoked, the program will exit with
  -- status 130 after the main loop action returns.
  onSigINT
    :: IO a -- ^ The main loop 'IO' action
    -> IO () -- ^ Callback for @SIGINT@
    -> IO a
  onSigINT action callback = do
    exitStatus <- newIORef Nothing
  
    let intHandler = do
          writeIORef exitStatus (Just (ExitFailure 130))
          callback
  
    withSigHandlerBase sigINT (CatchOnce intHandler) $ do
      res <- action
      readIORef exitStatus >>= mapM_ exitWith
      pure res
  
  -- | Installs the given function as a handler for @SIGHUP@, but only
  -- if this process is not running in a terminal (i.e. runnning as a
  -- daemon).
  --
  -- If not running as a daemon, then no handler is installed by
  -- 'maybeHandleSigHUP'. The default handler for 'sigHUP' exits the
  -- program, which is the correct thing to do.
  maybeHandleSigHUP :: IO () -> IO a -> IO a
  maybeHandleSigHUP callback action =
    ifM (anyM hIsTerminalDevice [stdout, stderr])
      action
      (handlePosixSignal sigHUP callback action)
  
  -- | Install a handler for the given POSIX 'Signal' while the given
  -- @IO@ action is running, then restore the original handler.
  --
  -- This function is for handling non-critical signals.
  --
  -- The given callback function won't be run immediately within the
  -- @sigaction@ handler, but will instead be posted to the GLib main
  -- loop.
  handlePosixSignal :: Signal -> IO () -> IO a -> IO a
  handlePosixSignal sig cb = withSigHandlerBase sig (Catch handler)
    where
      handler = postGUIASyncWithPriority G.PRIORITY_HIGH_IDLE cb
  
  -- | Install a handler for the given signal, run an 'IO' action, then
  -- restore the original handler.
  withSigHandlerBase :: Signal -> Handler -> IO a -> IO a
  withSigHandlerBase sig h = bracket (install h) install . const
    where
      install handler = installHandler sig handler Nothing
  