{-# 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 nodePath = runIO $
head . maybeToList . I.parseXML nodePath <$> TIO.readFile filepath
generateClientFromFile :: G.GenerationParams -> Bool -> FilePath -> Q [Dec]
generateClientFromFile params useObjectPath filepath = do
object <- getIntrospectionObjectFromFile filepath "/"
let interface = head $ I.objectInterfaces object
actualObjectPath = I.objectPath object
realParams =
if useObjectPath
then params { G.genObjectPath = Just actualObjectPath }
else params
(++) <$> G.generateClient realParams interface <*>
G.generateSignalsFromInterface realParams interface
ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM cond whenTrue whenFalse =
cond >>= (\bool -> if bool then whenTrue else whenFalse)
makeLensesWithLSuffix :: Name -> DecsQ
makeLensesWithLSuffix =
makeLensesWith $
lensRules & lensField .~ \_ _ name ->
[TopName (mkName $ nameBase name ++ "L")]
whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust = flip $ maybe $ return ()
convertARGBToABGR :: Word32 -> Word32
convertARGBToABGR bits = (blue `shift` 16) .|. (red `shift` (-16)) .|. green .|. alpha
where
blue = bits .&. 0xFF
green = bits .&. 0xFF00
red = bits .&. 0xFF0000
alpha = bits .&. 0xFF000000
networkToSystemByteOrder :: BS.ByteString -> BS.ByteString
networkToSystemByteOrder original =
vectorToByteString $ VS.map (convertARGBToABGR . fromBigEndian) $ byteStringToVector original
maybeToEither :: b -> Maybe a -> Either b a
maybeToEither = flip maybe Right . Left
makeErrorReply :: ErrorName -> String -> Reply
makeErrorReply e message = ReplyError e [T.toVariant message]
logErrorWithDefault ::
Show a => (Priority -> String -> IO ()) -> b -> String -> Either a b -> IO b
logErrorWithDefault logger def message =
fmap (fromMaybe def) . logEitherError logger message
logEitherError :: Show a => (Priority -> String -> IO ()) -> String -> Either a b -> IO (Maybe b)
logEitherError logger message =
either (\err -> logger ERROR (message ++ show err) >> return Nothing) (return . Just)
exemptUnknownMethod ::
b -> Either M.MethodError b -> Either M.MethodError b
exemptUnknownMethod def eitherV =
case eitherV of
Right _ -> eitherV
Left M.MethodError { M.methodErrorName = errorName } ->
if errorName == errorUnknownMethod
then Right def
else eitherV
exemptAll ::
b -> Either M.MethodError b -> Either M.MethodError b
exemptAll def eitherV =
case eitherV of
Right _ -> eitherV
Left _ -> Right def
infixl 4 <..>
(<..>) :: Functor f => (a -> b) -> f (f a) -> f (f b)
(<..>) = fmap . fmap
infixl 4 <<$>>
(<<$>>) :: (a -> IO b) -> Maybe a -> IO (Maybe b)
fn <<$>> m = sequenceA $ fn <$> m
forkM :: Monad m => (i -> m a) -> (i -> m b) -> i -> m (a, b)
forkM a b i =
do
r1 <- a i
r2 <- b i
return (r1, r2)
tee :: Monad m => (i -> m a) -> (i -> m b) -> i -> m a
tee = (fmap . fmap . fmap) (fmap fst) forkM
(>>=/) :: Monad m => m a -> (a -> m b) -> m a
(>>=/) a = (a >>=) . tee return
getInterfaceAt
:: Client
-> T.BusName
-> T.ObjectPath
-> IO (Either M.MethodError (Maybe I.Object))
getInterfaceAt client bus path =
right (I.parseXML "/" . pack) <$> introspect client bus path
findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
findM p [] = return Nothing
findM p (x:xs) = ifM (p x) (return $ Just x) (findM p xs)