{-# 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
(Address -> Address -> Bool)
-> (Address -> Address -> Bool) -> Eq Address
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 String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
method Bool -> Bool -> Bool
&& Map String String -> Bool
forall k a. Map k a -> Bool
Data.Map.null Map String String
params
        then Maybe Address
forall a. Maybe a
Nothing
        else Address -> Maybe Address
forall a. a -> Maybe a
Just (String -> Map String String -> Address
Address String
method Map String String
params)
    else Maybe Address
forall a. Maybe a
Nothing

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

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

optionallyEncoded :: [Char]
optionallyEncoded :: String
optionallyEncoded = [String] -> String
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) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
method, String
":", String
csvParams] where
    csvParams :: String
csvParams = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ do
        (String
k, String
v) <- Map String String -> [(String, String)]
forall k a. Map k a -> [(k, a)]
Data.Map.toList Map String String
params
        let v' :: String
v' = (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
escape String
v
        String -> [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
k, String
"=", String
v'])

    escape :: Char -> String
escape Char
c = if Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
c String
optionallyEncoded
        then [Char
c]
        else String -> Int -> String
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 = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
";" ([String] -> String)
-> ([Address] -> [String]) -> [Address] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Address -> String) -> [Address] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Address -> String
formatAddress

instance Show Address where
    showsPrec :: Int -> Address -> String -> String
showsPrec Int
d Address
x = Bool -> (String -> String) -> String -> String
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
        String -> String -> String
showString String
"Address " (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        String -> String -> String
forall a. Show a => a -> String -> String
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 = Parser Address -> String -> Maybe Address
forall a. Parser a -> String -> Maybe a
maybeParseString (Parser Address -> String -> Maybe Address)
-> Parser Address -> String -> Maybe Address
forall a b. (a -> b) -> a -> b
$ do
    Address
addr <- Parser Address
parsecAddress
    ParsecT String () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
    Address -> Parser Address
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 = Parser [Address] -> String -> Maybe [Address]
forall a. Parser a -> String -> Maybe a
maybeParseString (Parser [Address] -> String -> Maybe [Address])
-> Parser [Address] -> String -> Maybe [Address]
forall a b. (a -> b) -> a -> b
$ do
    [Address]
addrs <- Parser Address
-> ParsecT String () Identity Char -> Parser [Address]
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 (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
';')
    ParsecT String () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
    [Address] -> Parser [Address]
forall (m :: * -> *) a. Monad m => a -> m a
return [Address]
addrs

parsecAddress :: Parser Address
parsecAddress :: Parser Address
parsecAddress = Parser Address
forall u. ParsecT String u Identity Address
p where
    p :: ParsecT String u Identity Address
p = do
        String
method <- ParsecT String u Identity Char -> ParsecT String u Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (String -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
":;")
        Char
_ <- Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':'
        [(String, String)]
params <- ParsecT String u Identity (String, String)
-> ParsecT String u Identity Char
-> ParsecT String u Identity [(String, String)]
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 ParsecT String u Identity (String, String)
forall u. ParsecT String u Identity (String, String)
param (Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
',')
        Address -> ParsecT String u Identity Address
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Map String String -> Address
Address String
method ([(String, String)] -> Map String String
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 <- ParsecT String u Identity Char -> ParsecT String u Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (String -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"=;,")
        Char
_ <- Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'='
        String
value <- ParsecT String u Identity Char -> ParsecT String u Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String u Identity Char
forall u. ParsecT String u Identity Char
valueChar
        (String, String) -> ParsecT String u Identity (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
key, String
value)

    valueChar :: ParsecT String u Identity Char
valueChar = ParsecT String u Identity Char
forall u. ParsecT String u Identity Char
encoded ParsecT String u Identity Char
-> ParsecT String u Identity Char -> ParsecT String u Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String u Identity Char
forall u. ParsecT String u Identity Char
unencoded
    encoded :: ParsecT String u Identity Char
encoded = do
        Char
_ <- Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'%'
        String
hex <- Int
-> ParsecT String u Identity Char
-> ParsecT String u Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
Int -> ParsecT s u m a -> ParsecT s u m [a]
count Int
2 ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
hexDigit
        Char -> ParsecT String u Identity Char
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Char
chr (String -> Int
hexToInt String
hex))
    unencoded :: ParsecT String u Identity Char
unencoded = String -> ParsecT String u Identity Char
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"
    Maybe Address -> IO (Maybe Address)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe Address
parseAddress (String -> Maybe String -> String
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" IO (Maybe String)
-> (Maybe String -> IO (Maybe Address)) -> IO (Maybe Address)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just String
addrs -> Maybe Address -> IO (Maybe Address)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe [Address]
parseAddresses String
addrs Maybe [Address] -> ([Address] -> Maybe Address) -> Maybe Address
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Address] -> Maybe Address
forall a. [a] -> Maybe a
listToMaybe)
    Maybe String
Nothing -> (Maybe String -> (String -> Maybe Address) -> Maybe Address
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Address
parseFallback) (Maybe String -> Maybe Address)
-> IO (Maybe String) -> IO (Maybe Address)
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=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dir String -> String -> String
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"
    Maybe Address -> IO (Maybe Address)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String
env Maybe String -> (String -> Maybe Address) -> Maybe Address
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Address
parseAddress)

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

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