{-# LANGUAGE OverloadedStrings #-}
module StatusNotifier.Util where

import           Control.Arrow
import           Control.Lens
import           DBus.Client
import qualified DBus.Generation as G
import qualified DBus.Internal.Message as M
import qualified DBus.Internal.Types as T
import qualified DBus.Introspection as I
import           Data.Bits
import qualified Data.ByteString as BS
import           Data.Maybe
import qualified Data.Vector.Storable as VS
import           Data.Vector.Storable.ByteString
import           Data.Word
import           Language.Haskell.TH
import           StatusNotifier.TH
import qualified Data.Text.IO as TIO
import           Data.Text (pack)
import           System.ByteOrder (fromBigEndian)
import           System.Log.Logger

getIntrospectionObjectFromFile :: FilePath -> T.ObjectPath -> Q I.Object
getIntrospectionObjectFromFile :: FilePath -> ObjectPath -> Q Object
getIntrospectionObjectFromFile FilePath
filepath ObjectPath
nodePath = IO Object -> Q Object
forall a. IO a -> Q a
runIO (IO Object -> Q Object) -> IO Object -> Q Object
forall a b. (a -> b) -> a -> b
$
  [Object] -> Object
forall a. [a] -> a
head ([Object] -> Object) -> (Text -> [Object]) -> Text -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Object -> [Object]
forall a. Maybe a -> [a]
maybeToList (Maybe Object -> [Object])
-> (Text -> Maybe Object) -> Text -> [Object]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectPath -> Text -> Maybe Object
I.parseXML ObjectPath
nodePath (Text -> Object) -> IO Text -> IO Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Text
TIO.readFile FilePath
filepath

generateClientFromFile :: G.GenerationParams -> Bool -> FilePath -> Q [Dec]
generateClientFromFile :: GenerationParams -> Bool -> FilePath -> Q [Dec]
generateClientFromFile GenerationParams
params Bool
useObjectPath FilePath
filepath = do
  Object
object <- FilePath -> ObjectPath -> Q Object
getIntrospectionObjectFromFile FilePath
filepath ObjectPath
"/"
  let interface :: Interface
interface = [Interface] -> Interface
forall a. [a] -> a
head ([Interface] -> Interface) -> [Interface] -> Interface
forall a b. (a -> b) -> a -> b
$ Object -> [Interface]
I.objectInterfaces Object
object
      actualObjectPath :: ObjectPath
actualObjectPath = Object -> ObjectPath
I.objectPath Object
object
      realParams :: GenerationParams
realParams =
        if Bool
useObjectPath
        then GenerationParams
params { genObjectPath :: Maybe ObjectPath
G.genObjectPath = ObjectPath -> Maybe ObjectPath
forall a. a -> Maybe a
Just ObjectPath
actualObjectPath }
        else GenerationParams
params
  [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
(++) ([Dec] -> [Dec] -> [Dec]) -> Q [Dec] -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenerationParams -> Interface -> Q [Dec]
G.generateClient GenerationParams
realParams Interface
interface Q ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
           GenerationParams -> Interface -> Q [Dec]
G.generateSignalsFromInterface GenerationParams
realParams Interface
interface

ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM :: m Bool -> m a -> m a -> m a
ifM m Bool
cond m a
whenTrue m a
whenFalse =
  m Bool
cond m Bool -> (Bool -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\Bool
bool -> if Bool
bool then m a
whenTrue else m a
whenFalse)

makeLensesWithLSuffix :: Name -> DecsQ
makeLensesWithLSuffix :: Name -> Q [Dec]
makeLensesWithLSuffix =
  LensRules -> Name -> Q [Dec]
makeLensesWith (LensRules -> Name -> Q [Dec]) -> LensRules -> Name -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
  LensRules
lensRules LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& (FieldNamer -> Identity FieldNamer)
-> LensRules -> Identity LensRules
Lens' LensRules FieldNamer
lensField ((FieldNamer -> Identity FieldNamer)
 -> LensRules -> Identity LensRules)
-> FieldNamer -> LensRules -> LensRules
forall s t a b. ASetter s t a b -> b -> s -> t
.~ \Name
_ [Name]
_ Name
name ->
    [Name -> DefName
TopName (FilePath -> Name
mkName (FilePath -> Name) -> FilePath -> Name
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
nameBase Name
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"L")]

whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust :: Maybe a -> (a -> m ()) -> m ()
whenJust = ((a -> m ()) -> Maybe a -> m ()) -> Maybe a -> (a -> m ()) -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((a -> m ()) -> Maybe a -> m ())
 -> Maybe a -> (a -> m ()) -> m ())
-> ((a -> m ()) -> Maybe a -> m ())
-> Maybe a
-> (a -> m ())
-> m ()
forall a b. (a -> b) -> a -> b
$ m () -> (a -> m ()) -> Maybe a -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (m () -> (a -> m ()) -> Maybe a -> m ())
-> m () -> (a -> m ()) -> Maybe a -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

convertARGBToABGR :: Word32 -> Word32
convertARGBToABGR :: Word32 -> Word32
convertARGBToABGR Word32
bits = (Word32
blue Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shift` Int
16) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word32
red Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shift` (-Int
16)) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
green Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
alpha
  where
    blue :: Word32
blue = Word32
bits Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF
    green :: Word32
green = Word32
bits Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF00
    red :: Word32
red = Word32
bits Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF0000
    alpha :: Word32
alpha = Word32
bits Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xFF000000

networkToSystemByteOrder :: BS.ByteString -> BS.ByteString
networkToSystemByteOrder :: ByteString -> ByteString
networkToSystemByteOrder ByteString
original =
  Vector Word32 -> ByteString
forall a. Storable a => Vector a -> ByteString
vectorToByteString (Vector Word32 -> ByteString) -> Vector Word32 -> ByteString
forall a b. (a -> b) -> a -> b
$ (Word32 -> Word32) -> Vector Word32 -> Vector Word32
forall a b.
(Storable a, Storable b) =>
(a -> b) -> Vector a -> Vector b
VS.map (Word32 -> Word32
convertARGBToABGR (Word32 -> Word32) -> (Word32 -> Word32) -> Word32 -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Word32
forall a. Bytes a => a -> a
fromBigEndian) (Vector Word32 -> Vector Word32) -> Vector Word32 -> Vector Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Vector Word32
forall a. Storable a => ByteString -> Vector a
byteStringToVector ByteString
original

maybeToEither :: b -> Maybe a -> Either b a
maybeToEither :: 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

makeErrorReply :: ErrorName -> String -> Reply
makeErrorReply :: ErrorName -> FilePath -> Reply
makeErrorReply ErrorName
e FilePath
message = ErrorName -> [Variant] -> Reply
ReplyError ErrorName
e [FilePath -> Variant
forall a. IsVariant a => a -> Variant
T.toVariant FilePath
message]

logErrorWithDefault ::
  Show a => (Priority -> String -> IO ()) -> b -> String -> Either a b -> IO b
logErrorWithDefault :: (Priority -> FilePath -> IO ())
-> b -> FilePath -> Either a b -> IO b
logErrorWithDefault Priority -> FilePath -> IO ()
logger b
def FilePath
message =
  (Maybe b -> b) -> IO (Maybe b) -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> Maybe b -> b
forall a. a -> Maybe a -> a
fromMaybe b
def) (IO (Maybe b) -> IO b)
-> (Either a b -> IO (Maybe b)) -> Either a b -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Priority -> FilePath -> IO ())
-> FilePath -> Either a b -> IO (Maybe b)
forall a b.
Show a =>
(Priority -> FilePath -> IO ())
-> FilePath -> Either a b -> IO (Maybe b)
logEitherError Priority -> FilePath -> IO ()
logger FilePath
message

logEitherError :: Show a => (Priority -> String -> IO ()) -> String -> Either a b -> IO (Maybe b)
logEitherError :: (Priority -> FilePath -> IO ())
-> FilePath -> Either a b -> IO (Maybe b)
logEitherError Priority -> FilePath -> IO ()
logger FilePath
message =
  (a -> IO (Maybe b))
-> (b -> IO (Maybe b)) -> Either a b -> IO (Maybe b)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\a
err -> Priority -> FilePath -> IO ()
logger Priority
ERROR (FilePath
message FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ a -> FilePath
forall a. Show a => a -> FilePath
show a
err) IO () -> IO (Maybe b) -> IO (Maybe b)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe b -> IO (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing) (Maybe b -> IO (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe b -> IO (Maybe b)) -> (b -> Maybe b) -> b -> IO (Maybe b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Maybe b
forall a. a -> Maybe a
Just)

exemptUnknownMethod ::
  b -> Either M.MethodError b -> Either M.MethodError b
exemptUnknownMethod :: b -> Either MethodError b -> Either MethodError b
exemptUnknownMethod b
def Either MethodError b
eitherV =
  case Either MethodError b
eitherV of
    Right b
_ -> Either MethodError b
eitherV
    Left M.MethodError { methodErrorName :: MethodError -> ErrorName
M.methodErrorName = ErrorName
errorName } ->
      if ErrorName
errorName ErrorName -> ErrorName -> Bool
forall a. Eq a => a -> a -> Bool
== ErrorName
errorUnknownMethod
      then b -> Either MethodError b
forall a b. b -> Either a b
Right b
def
      else Either MethodError b
eitherV

exemptAll ::
  b -> Either M.MethodError b -> Either M.MethodError b
exemptAll :: b -> Either MethodError b -> Either MethodError b
exemptAll b
def Either MethodError b
eitherV =
  case Either MethodError b
eitherV of
    Right b
_ -> Either MethodError b
eitherV
    Left MethodError
_ -> b -> Either MethodError b
forall a b. b -> Either a b
Right b
def

infixl 4 <..>
(<..>) :: Functor f => (a -> b) -> f (f a) -> f (f b)
<..> :: (a -> b) -> f (f a) -> f (f b)
(<..>) = (f a -> f b) -> f (f a) -> f (f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((f a -> f b) -> f (f a) -> f (f b))
-> ((a -> b) -> f a -> f b) -> (a -> b) -> f (f a) -> f (f b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap

infixl 4 <<$>>
(<<$>>) :: (a -> IO b) -> Maybe a -> IO (Maybe b)
a -> IO b
fn <<$>> :: (a -> IO b) -> Maybe a -> IO (Maybe b)
<<$>> Maybe a
m = Maybe (IO b) -> IO (Maybe b)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (Maybe (IO b) -> IO (Maybe b)) -> Maybe (IO b) -> IO (Maybe b)
forall a b. (a -> b) -> a -> b
$ a -> IO b
fn (a -> IO b) -> Maybe a -> Maybe (IO b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
m

forkM :: Monad m => (i -> m a) -> (i -> m b) -> i -> m (a, b)
forkM :: (i -> m a) -> (i -> m b) -> i -> m (a, b)
forkM i -> m a
a i -> m b
b i
i =
  do
    a
r1 <- i -> m a
a i
i
    b
r2 <- i -> m b
b i
i
    (a, b) -> m (a, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
r1, b
r2)

tee :: Monad m => (i -> m a) -> (i -> m b) -> i -> m a
tee :: (i -> m a) -> (i -> m b) -> i -> m a
tee = ((((i -> m b) -> i -> m (a, b)) -> (i -> m b) -> i -> m a)
-> ((i -> m a) -> (i -> m b) -> i -> m (a, b))
-> (i -> m a)
-> (i -> m b)
-> i
-> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((((i -> m b) -> i -> m (a, b)) -> (i -> m b) -> i -> m a)
 -> ((i -> m a) -> (i -> m b) -> i -> m (a, b))
 -> (i -> m a)
 -> (i -> m b)
 -> i
 -> m a)
-> ((m (a, b) -> m a)
    -> ((i -> m b) -> i -> m (a, b)) -> (i -> m b) -> i -> m a)
-> (m (a, b) -> m a)
-> ((i -> m a) -> (i -> m b) -> i -> m (a, b))
-> (i -> m a)
-> (i -> m b)
-> i
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((i -> m (a, b)) -> i -> m a)
-> ((i -> m b) -> i -> m (a, b)) -> (i -> m b) -> i -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((i -> m (a, b)) -> i -> m a)
 -> ((i -> m b) -> i -> m (a, b)) -> (i -> m b) -> i -> m a)
-> ((m (a, b) -> m a) -> (i -> m (a, b)) -> i -> m a)
-> (m (a, b) -> m a)
-> ((i -> m b) -> i -> m (a, b))
-> (i -> m b)
-> i
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m (a, b) -> m a) -> (i -> m (a, b)) -> i -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (((a, b) -> a) -> m (a, b) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, b) -> a
forall a b. (a, b) -> a
fst) (i -> m a) -> (i -> m b) -> i -> m (a, b)
forall (m :: * -> *) i a b.
Monad m =>
(i -> m a) -> (i -> m b) -> i -> m (a, b)
forkM

(>>=/) :: Monad m => m a -> (a -> m b) -> m a
>>=/ :: m a -> (a -> m b) -> m a
(>>=/) m a
a = (m a
a m a -> (a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=) ((a -> m a) -> m a)
-> ((a -> m b) -> a -> m a) -> (a -> m b) -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m a) -> (a -> m b) -> a -> m a
forall (m :: * -> *) i a b.
Monad m =>
(i -> m a) -> (i -> m b) -> i -> m a
tee a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

getInterfaceAt
  :: Client
  -> T.BusName
  -> T.ObjectPath
  -> IO (Either M.MethodError (Maybe I.Object))
getInterfaceAt :: Client
-> BusName -> ObjectPath -> IO (Either MethodError (Maybe Object))
getInterfaceAt Client
client BusName
bus ObjectPath
path =
  (FilePath -> Maybe Object)
-> Either MethodError FilePath -> Either MethodError (Maybe Object)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right (ObjectPath -> Text -> Maybe Object
I.parseXML ObjectPath
"/" (Text -> Maybe Object)
-> (FilePath -> Text) -> FilePath -> Maybe Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
pack) (Either MethodError FilePath -> Either MethodError (Maybe Object))
-> IO (Either MethodError FilePath)
-> IO (Either MethodError (Maybe Object))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Client -> BusName -> ObjectPath -> IO (Either MethodError FilePath)
introspect Client
client BusName
bus ObjectPath
path

findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
findM :: (a -> m Bool) -> [a] -> m (Maybe a)
findM a -> m Bool
p [] = Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
findM a -> m Bool
p (a
x:[a]
xs) = m Bool -> m (Maybe a) -> m (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (a -> m Bool
p a
x) (Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x) ((a -> m Bool) -> [a] -> m (Maybe a)
forall (m :: * -> *) a.
Monad m =>
(a -> m Bool) -> [a] -> m (Maybe a)
findM a -> m Bool
p [a]
xs)