{-# Language LambdaCase #-}
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
data Address = Address String (Map String String)
deriving (Eq)
addressMethod :: Address -> String
addressMethod (Address x _ ) = x
addressParameters :: Address -> Map String String
addressParameters (Address _ x) = x
address :: String -> Map String String -> Maybe Address
address method params = if validMethod method && validParams params
then if null method && Data.Map.null params
then Nothing
else Just (Address method params)
else Nothing
validMethod :: String -> Bool
validMethod = all validChar where
validChar c = c /= ';' && c /= ':'
validParams :: Map String String -> Bool
validParams = all validItem . Data.Map.toList where
validItem (k, v) = notNull k && notNull v && validKey k
validKey = all validChar
validChar c = c /= ';' && c /= ',' && c /= '='
notNull = not . null
optionallyEncoded :: [Char]
optionallyEncoded = concat
[ ['0'..'9']
, ['a'..'z']
, ['A'..'Z']
, ['-', '_', '/', '\\', '*', '.']
]
formatAddress :: Address -> String
formatAddress (Address method params) = concat [method, ":", csvParams] where
csvParams = intercalate "," $ do
(k, v) <- Data.Map.toList params
let v' = concatMap escape v
return (concat [k, "=", v'])
escape c = if elem c optionallyEncoded
then [c]
else printf "%%%02X" (ord c)
formatAddresses :: [Address] -> String
formatAddresses = intercalate ";" . map formatAddress
instance Show Address where
showsPrec d x = showParen (d > 10) $
showString "Address " .
shows (formatAddress x)
parseAddress :: String -> Maybe Address
parseAddress = maybeParseString $ do
addr <- parsecAddress
eof
return addr
parseAddresses :: String -> Maybe [Address]
parseAddresses = maybeParseString $ do
addrs <- sepEndBy parsecAddress (char ';')
eof
return addrs
parsecAddress :: Parser Address
parsecAddress = p where
p = do
method <- many (noneOf ":;")
_ <- char ':'
params <- sepEndBy param (char ',')
return (Address method (Data.Map.fromList params))
param = do
key <- many1 (noneOf "=;,")
_ <- char '='
value <- many1 valueChar
return (key, value)
valueChar = encoded <|> unencoded
encoded = do
_ <- char '%'
hex <- count 2 hexDigit
return (chr (hexToInt hex))
unencoded = oneOf optionallyEncoded
getSystemAddress :: IO (Maybe Address)
getSystemAddress = do
let system = "unix:path=/var/run/dbus/system_bus_socket"
env <- lookupEnv "DBUS_SYSTEM_BUS_ADDRESS"
return (parseAddress (fromMaybe system env))
getSessionAddress :: IO (Maybe Address)
getSessionAddress = lookupEnv "DBUS_SESSION_BUS_ADDRESS" >>= \case
Just addrs -> pure (parseAddresses addrs >>= listToMaybe)
Nothing -> (>>= parseFallback) <$> lookupEnv "XDG_RUNTIME_DIR"
where
parseFallback dir = parseAddress ("unix:path=" ++ dir ++ "/bus")
getStarterAddress :: IO (Maybe Address)
getStarterAddress = do
env <- lookupEnv "DBUS_STARTER_ADDRESS"
return (env >>= parseAddress)
hexToInt :: String -> Int
hexToInt = foldl ((+) . (16 *)) 0 . map digitToInt
maybeParseString :: Parser a -> String -> Maybe a
maybeParseString p str = case runParser p () "" str of
Left _ -> Nothing
Right a -> Just a