{-# LANGUAGE OverloadedStrings #-}
module System.Log.DBus.Server where

import           Data.IORef
import           Data.Map (Map)
import qualified Data.Map as Map
import           DBus
import           DBus.Client
import qualified DBus.Introspection as I
import           System.Log.Logger
import           Text.Read

maybeToEither :: b -> Maybe a -> Either b a
maybeToEither :: forall b a. b -> Maybe a -> Either b a
maybeToEither = (Either b a -> (a -> Either b a) -> Maybe a -> Either b a)
-> (a -> Either b a) -> Either b a -> Maybe a -> Either b a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Either b a -> (a -> Either b a) -> Maybe a -> Either b a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe a -> Either b a
forall a b. b -> Either a b
Right (Either b a -> Maybe a -> Either b a)
-> (b -> Either b a) -> b -> Maybe a -> Either b a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either b a
forall a b. a -> Either a b
Left

-- | An opaque handle for the log server, which tracks loggers whose levels
-- have been explicitly set.
newtype LogServer = LogServer (IORef (Map String Priority))

-- | Create a new 'LogServer'.
newLogServer :: IO LogServer
newLogServer :: IO LogServer
newLogServer = IORef (Map String Priority) -> LogServer
LogServer (IORef (Map String Priority) -> LogServer)
-> IO (IORef (Map String Priority)) -> IO LogServer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map String Priority -> IO (IORef (Map String Priority))
forall a. a -> IO (IORef a)
newIORef Map String Priority
forall k a. Map k a
Map.empty

setLogLevelTracked :: LogServer -> String -> Priority -> IO ()
setLogLevelTracked :: LogServer -> String -> Priority -> IO ()
setLogLevelTracked (LogServer IORef (Map String Priority)
ref) String
logPrefix Priority
level = do
  String -> IO Logger
getLogger String
logPrefix IO Logger -> (Logger -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Logger -> IO ()
saveGlobalLogger (Logger -> IO ()) -> (Logger -> Logger) -> Logger -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Priority -> Logger -> Logger
setLevel Priority
level
  IORef (Map String Priority)
-> (Map String Priority -> Map String Priority) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Map String Priority)
ref (String -> Priority -> Map String Priority -> Map String Priority
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
logPrefix Priority
level)

setLogLevelFromPriorityStringTracked
  :: LogServer -> String -> String -> IO (Either Reply ())
setLogLevelFromPriorityStringTracked :: LogServer -> String -> String -> IO (Either Reply ())
setLogLevelFromPriorityStringTracked LogServer
server String
logPrefix String
levelString =
  case String -> Maybe Priority
forall a. Read a => String -> Maybe a
readMaybe String
levelString of
    Just Priority
level -> () -> Either Reply ()
forall a b. b -> Either a b
Right (() -> Either Reply ()) -> IO () -> IO (Either Reply ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LogServer -> String -> Priority -> IO ()
setLogLevelTracked LogServer
server String
logPrefix Priority
level
    Maybe Priority
Nothing -> Either Reply () -> IO (Either Reply ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Reply () -> IO (Either Reply ()))
-> Either Reply () -> IO (Either Reply ())
forall a b. (a -> b) -> a -> b
$ Reply -> Either Reply ()
forall a b. a -> Either a b
Left (ErrorName -> [Variant] -> Reply
ReplyError ErrorName
errorInvalidParameters [])

-- | Get the log level of a specific logger. Returns the level as a string,
-- or an empty string if no level has been explicitly set on that logger.
getLogLevel :: String -> IO String
getLogLevel :: String -> IO String
getLogLevel String
logPrefix = do
  logger <- String -> IO Logger
getLogger String
logPrefix
  return $ maybe "" show (getLevel logger)

-- | Get all loggers whose levels have been explicitly set via 'SetLogLevel',
-- as a map from logger name to level string.
getConfiguredLogLevels :: LogServer -> IO (Map String String)
getConfiguredLogLevels :: LogServer -> IO (Map String String)
getConfiguredLogLevels (LogServer IORef (Map String Priority)
ref) =
  (Priority -> String) -> Map String Priority -> Map String String
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Priority -> String
forall a. Show a => a -> String
show (Map String Priority -> Map String String)
-> IO (Map String Priority) -> IO (Map String String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map String Priority) -> IO (Map String Priority)
forall a. IORef a -> IO a
readIORef IORef (Map String Priority)
ref

-- | Build the D-Bus interface with tracking and introspection methods.
logInterfaceWithServer :: LogServer -> Interface
logInterfaceWithServer :: LogServer -> Interface
logInterfaceWithServer LogServer
server = Interface
defaultInterface
  { interfaceName = "org.taffybar.LogServer"
  , interfaceMethods =
      [ autoMethod "SetLogLevel"
          (setLogLevelFromPriorityStringTracked server)
      , autoMethod "GetLogLevel" getLogLevel
      , autoMethod "GetConfiguredLogLevels"
          (getConfiguredLogLevels server)
      ]
  }

-- | The original interface with only 'SetLogLevel'. Kept for backward
-- compatibility.
logInterface :: Interface
logInterface :: Interface
logInterface = Interface
defaultInterface
  { interfaceName = "org.taffybar.LogServer"
  , interfaceMethods = [ autoMethod "SetLogLevel" setLogLevelFromPriorityString ]
  }

logPath :: ObjectPath
logPath :: ObjectPath
logPath = ObjectPath
"/org/taffybar/LogServer"

-- | Start the log server with tracking and introspection. Returns a
-- 'LogServer' handle that can be used to register additional loggers.
startLogServerWithTracking :: Client -> IO LogServer
startLogServerWithTracking :: Client -> IO LogServer
startLogServerWithTracking Client
client = do
  server <- IO LogServer
newLogServer
  export client logPath (logInterfaceWithServer server)
  return server

-- | Start the log server (original API, no tracking).
startLogServer :: Client -> IO ()
startLogServer :: Client -> IO ()
startLogServer Client
client =
  Client -> ObjectPath -> Interface -> IO ()
export Client
client ObjectPath
logPath Interface
logInterface

-- | Introspection interface including all methods (SetLogLevel, GetLogLevel,
-- GetConfiguredLogLevels). Suitable for TH client generation.
logIntrospectionInterface :: I.Interface
logIntrospectionInterface :: Interface
logIntrospectionInterface = Interface -> Interface
buildIntrospectionInterface (Interface -> Interface) -> Interface -> Interface
forall a b. (a -> b) -> a -> b
$
  Interface
defaultInterface
    { interfaceName = "org.taffybar.LogServer"
    , interfaceMethods =
        [ autoMethod "SetLogLevel" setLogLevelFromPriorityString
        , autoMethod "GetLogLevel" getLogLevel
        , autoMethod "GetConfiguredLogLevels"
            (return Map.empty :: IO (Map String String))
        ]
    }

setLogLevelFromPriorityString :: String -> String -> IO (Either Reply ())
setLogLevelFromPriorityString :: String -> String -> IO (Either Reply ())
setLogLevelFromPriorityString String
logPrefix String
levelString =
  let maybePriority :: Maybe Priority
maybePriority = String -> Maybe Priority
forall a. Read a => String -> Maybe a
readMaybe String
levelString
      getMaybeResult :: IO (Maybe ())
getMaybeResult = Maybe (IO ()) -> IO (Maybe ())
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => Maybe (f a) -> f (Maybe a)
sequenceA (Maybe (IO ()) -> IO (Maybe ())) -> Maybe (IO ()) -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ String -> Priority -> IO ()
setLogLevel String
logPrefix (Priority -> IO ()) -> Maybe Priority -> Maybe (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Priority
maybePriority
  in Reply -> Maybe () -> Either Reply ()
forall b a. b -> Maybe a -> Either b a
maybeToEither (ErrorName -> [Variant] -> Reply
ReplyError ErrorName
errorInvalidParameters []) (Maybe () -> Either Reply ())
-> IO (Maybe ()) -> IO (Either Reply ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe ())
getMaybeResult

setLogLevel :: String -> Priority -> IO ()
setLogLevel :: String -> Priority -> IO ()
setLogLevel String
logPrefix Priority
level =
  String -> IO Logger
getLogger String
logPrefix IO Logger -> (Logger -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Logger -> IO ()
saveGlobalLogger (Logger -> IO ()) -> (Logger -> Logger) -> Logger -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Priority -> Logger -> Logger
setLevel Priority
level