{-# Language LambdaCase #-}
-- Copyright (C) 2009-2012 John Millikin <john@john-millikin.com>
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--     http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.

module DBus.Internal.Address where

import           Data.Char (digitToInt, ord, chr)
import           Data.Maybe (listToMaybe, fromMaybe)
import           Data.List (intercalate)
import qualified Data.Map
import           Data.Map (Map)
import           System.Environment (lookupEnv)
import           Text.Printf (printf)

import           Text.ParserCombinators.Parsec

-- | When a D-Bus server must listen for connections, or a client must connect
-- to a server, the listening socket's configuration is specified with an
-- /address/. An address contains the /method/, which determines the
-- protocol and transport mechanism, and /parameters/, which provide
-- additional method-specific information about the address.
data Address = Address String (Map String String)
    deriving (Address -> Address -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Address -> Address -> Bool
$c/= :: Address -> Address -> Bool
== :: Address -> Address -> Bool
$c== :: Address -> Address -> Bool
Eq)

addressMethod :: Address -> String
addressMethod :: Address -> String
addressMethod (Address String
x Map String String
_ ) = String
x

addressParameters :: Address -> Map String String
addressParameters :: Address -> Map String String
addressParameters (Address String
_ Map String String
x) = Map String String
x

-- | Try to convert a method string and parameter map to an 'Address'.
--
-- Returns 'Nothing' if the method or parameters are invalid.
address :: String -> Map String String -> Maybe Address
address :: String -> Map String String -> Maybe Address
address String
method Map String String
params = if String -> Bool
validMethod String
method Bool -> Bool -> Bool
&& Map String String -> Bool
validParams Map String String
params
    then if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
method Bool -> Bool -> Bool
&& forall k a. Map k a -> Bool
Data.Map.null Map String String
params
        then forall a. Maybe a
Nothing
        else forall a. a -> Maybe a
Just (String -> Map String String -> Address
Address String
method Map String String
params)
    else forall a. Maybe a
Nothing

validMethod :: String -> Bool
validMethod :: String -> Bool
validMethod = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
validChar where
    validChar :: Char -> Bool
validChar Char
c = Char
c forall a. Eq a => a -> a -> Bool
/= Char
';' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
':'

validParams :: Map String String -> Bool
validParams :: Map String String -> Bool
validParams = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall {a}. (String, [a]) -> Bool
validItem forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Data.Map.toList where
    validItem :: (String, [a]) -> Bool
validItem (String
k, [a]
v) = forall {a}. [a] -> Bool
notNull String
k Bool -> Bool -> Bool
&& forall {a}. [a] -> Bool
notNull [a]
v Bool -> Bool -> Bool
&& String -> Bool
validKey String
k
    validKey :: String -> Bool
validKey = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
validChar
    validChar :: Char -> Bool
validChar Char
c = Char
c forall a. Eq a => a -> a -> Bool
/= Char
';' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
',' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
'='
    notNull :: [a] -> Bool
notNull = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null

optionallyEncoded :: [Char]
optionallyEncoded :: String
optionallyEncoded = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [Char
'0'..Char
'9']
    , [Char
'a'..Char
'z']
    , [Char
'A'..Char
'Z']
    , [Char
'-', Char
'_', Char
'/', Char
'\\', Char
'*', Char
'.']
    ]

-- | Convert an address to a string in the format expected by 'parseAddress'.
formatAddress :: Address -> String
formatAddress :: Address -> String
formatAddress (Address String
method Map String String
params) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
method, String
":", String
csvParams] where
    csvParams :: String
csvParams = forall a. [a] -> [[a]] -> [a]
intercalate String
"," forall a b. (a -> b) -> a -> b
$ do
        (String
k, String
v) <- forall k a. Map k a -> [(k, a)]
Data.Map.toList Map String String
params
        let v' :: String
v' = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
escape String
v
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
k, String
"=", String
v'])

    escape :: Char -> String
escape Char
c = if forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
c String
optionallyEncoded
        then [Char
c]
        else forall r. PrintfType r => String -> r
printf String
"%%%02X" (Char -> Int
ord Char
c)

-- | Convert a list of addresses to a string in the format expected by
-- 'parseAddresses'.
formatAddresses :: [Address] -> String
formatAddresses :: [Address] -> String
formatAddresses = forall a. [a] -> [[a]] -> [a]
intercalate String
";" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Address -> String
formatAddress

instance Show Address where
    showsPrec :: Int -> Address -> ShowS
showsPrec Int
d Address
x = Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$
        String -> ShowS
showString String
"Address " forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        forall a. Show a => a -> ShowS
shows (Address -> String
formatAddress Address
x)

-- | Try to parse a string containing one valid address.
--
-- An address string is in the format @method:key1=val1,key2=val2@. There
-- are some limitations on the characters allowed within methods and
-- parameters; see the D-Bus specification for full details.
parseAddress :: String -> Maybe Address
parseAddress :: String -> Maybe Address
parseAddress = forall a. Parser a -> String -> Maybe a
maybeParseString forall a b. (a -> b) -> a -> b
$ do
    Address
addr <- Parser Address
parsecAddress
    forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
    forall (m :: * -> *) a. Monad m => a -> m a
return Address
addr

-- | Try to parse a string containing one or more valid addresses.
--
-- Addresses are separated by semicolons. See 'parseAddress' for the format
-- of addresses.
parseAddresses :: String -> Maybe [Address]
parseAddresses :: String -> Maybe [Address]
parseAddresses = forall a. Parser a -> String -> Maybe a
maybeParseString forall a b. (a -> b) -> a -> b
$ do
    [Address]
addrs <- forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepEndBy Parser Address
parsecAddress (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
';')
    forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
    forall (m :: * -> *) a. Monad m => a -> m a
return [Address]
addrs

parsecAddress :: Parser Address
parsecAddress :: Parser Address
parsecAddress = forall {u}. ParsecT String u Identity Address
p where
    p :: ParsecT String u Identity Address
p = do
        String
method <- forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
":;")
        Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':'
        [(String, String)]
params <- forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepEndBy forall {u}. ParsecT String u Identity (String, String)
param (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
',')
        forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Map String String -> Address
Address String
method (forall k a. Ord k => [(k, a)] -> Map k a
Data.Map.fromList [(String, String)]
params))

    param :: ParsecT String u Identity (String, String)
param = do
        String
key <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"=;,")
        Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'='
        String
value <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall {u}. ParsecT String u Identity Char
valueChar
        forall (m :: * -> *) a. Monad m => a -> m a
return (String
key, String
value)

    valueChar :: ParsecT String u Identity Char
valueChar = forall {u}. ParsecT String u Identity Char
encoded forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall {u}. ParsecT String u Identity Char
unencoded
    encoded :: ParsecT String u Identity Char
encoded = do
        Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'%'
        String
hex <- forall s (m :: * -> *) t u a.
Stream s m t =>
Int -> ParsecT s u m a -> ParsecT s u m [a]
count Int
2 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
hexDigit
        forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Char
chr (String -> Int
hexToInt String
hex))
    unencoded :: ParsecT String u Identity Char
unencoded = forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
optionallyEncoded

-- | Returns the address in the environment variable
-- @DBUS_SYSTEM_BUS_ADDRESS@, or
-- @unix:path=\/var\/run\/dbus\/system_bus_socket@ if @DBUS_SYSTEM_BUS_ADDRESS@
-- is not set.
--
-- Returns 'Nothing' if @DBUS_SYSTEM_BUS_ADDRESS@ contains an invalid address.
getSystemAddress :: IO (Maybe Address)
getSystemAddress :: IO (Maybe Address)
getSystemAddress = do
    let system :: String
system = String
"unix:path=/var/run/dbus/system_bus_socket"
    Maybe String
env <- String -> IO (Maybe String)
lookupEnv String
"DBUS_SYSTEM_BUS_ADDRESS"
    forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe Address
parseAddress (forall a. a -> Maybe a -> a
fromMaybe String
system Maybe String
env))

-- | Returns the first address in the environment variable
-- @DBUS_SESSION_BUS_ADDRESS@, which must be set.
--
-- Returns 'Nothing' if @DBUS_SYSTEM_BUS_ADDRESS@ contains an invalid address
-- or @DBUS_SESSION_BUS_ADDRESS@ is unset @XDG_RUNTIME_DIR@ doesn't have @/bus@.
getSessionAddress :: IO (Maybe Address)
getSessionAddress :: IO (Maybe Address)
getSessionAddress = String -> IO (Maybe String)
lookupEnv String
"DBUS_SESSION_BUS_ADDRESS" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just String
addrs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe [Address]
parseAddresses String
addrs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. [a] -> Maybe a
listToMaybe)
    Maybe String
Nothing -> (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Address
parseFallback) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"XDG_RUNTIME_DIR"
  where
    parseFallback :: String -> Maybe Address
parseFallback String
dir = String -> Maybe Address
parseAddress (String
"unix:path=" forall a. [a] -> [a] -> [a]
++ String
dir forall a. [a] -> [a] -> [a]
++ String
"/bus")

-- | Returns the address in the environment variable
-- @DBUS_STARTER_ADDRESS@, which must be set.
--
-- Returns 'Nothing' if @DBUS_STARTER_ADDRESS@ is unset or contains an
-- invalid address.
getStarterAddress :: IO (Maybe Address)
getStarterAddress :: IO (Maybe Address)
getStarterAddress = do
    Maybe String
env <- String -> IO (Maybe String)
lookupEnv String
"DBUS_STARTER_ADDRESS"
    forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String
env forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Address
parseAddress)

hexToInt :: String -> Int
hexToInt :: String -> Int
hexToInt = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (forall a. Num a => a -> a -> a
(+) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
16 forall a. Num a => a -> a -> a
*)) Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Char -> Int
digitToInt

maybeParseString :: Parser a -> String -> Maybe a
maybeParseString :: forall a. Parser a -> String -> Maybe a
maybeParseString Parser a
p String
str = case forall tok st a.
GenParser tok st a -> st -> String -> [tok] -> Either ParseError a
runParser Parser a
p () String
"" String
str of
    Left ParseError
_ -> forall a. Maybe a
Nothing
    Right a
a -> forall a. a -> Maybe a
Just a
a