1{-# Language LambdaCase #-} 2-- Copyright (C) 2009-2012 John Millikin <john@john-millikin.com> 3-- 4-- Licensed under the Apache License, Version 2.0 (the "License"); 5-- you may not use this file except in compliance with the License. 6-- You may obtain a copy of the License at 7-- 8-- http://www.apache.org/licenses/LICENSE-2.0 9-- 10-- Unless required by applicable law or agreed to in writing, software 11-- distributed under the License is distributed on an "AS IS" BASIS, 12-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13-- See the License for the specific language governing permissions and 14-- limitations under the License. 15 16module DBus.Internal.Address where 17 18import Data.Char (digitToInt, ord, chr) 19import Data.Maybe (listToMaybe, fromMaybe) 20import Data.List (intercalate) 21import qualified Data.Map 22import Data.Map (Map) 23import System.Environment (lookupEnv) 24import Text.Printf (printf) 25 26import Text.ParserCombinators.Parsec 27 28-- | When a D-Bus server must listen for connections, or a client must connect 29-- to a server, the listening socket's configuration is specified with an 30-- /address/. An address contains the /method/, which determines the 31-- protocol and transport mechanism, and /parameters/, which provide 32-- additional method-specific information about the address. 33data Address = Address String (Map String String) 34 deriving (Eq) 35 36addressMethod :: Address -> String 37addressMethod (Address x _ ) = x 38 39addressParameters :: Address -> Map String String 40addressParameters (Address _ x) = x 41 42-- | Try to convert a method string and parameter map to an 'Address'. 43-- 44-- Returns 'Nothing' if the method or parameters are invalid. 45address :: String -> Map String String -> Maybe Address 46address method params = if validMethod method && validParams params 47 then if null method && Data.Map.null params 48 then Nothing 49 else Just (Address method params) 50 else Nothing 51 52validMethod :: String -> Bool 53validMethod = all validChar where 54 validChar c = c /= ';' && c /= ':' 55 56validParams :: Map String String -> Bool 57validParams = all validItem . Data.Map.toList where 58 validItem (k, v) = notNull k && notNull v && validKey k 59 validKey = all validChar 60 validChar c = c /= ';' && c /= ',' && c /= '=' 61 notNull = not . null 62 63optionallyEncoded :: [Char] 64optionallyEncoded = concat 65 [ ['0'..'9'] 66 , ['a'..'z'] 67 , ['A'..'Z'] 68 , ['-', '_', '/', '\\', '*', '.'] 69 ] 70 71-- | Convert an address to a string in the format expected by 'parseAddress'. 72formatAddress :: Address -> String 73formatAddress (Address method params) = concat [method, ":", csvParams] where 74 csvParams = intercalate "," $ do 75 (k, v) <- Data.Map.toList params 76 let v' = concatMap escape v 77 return (concat [k, "=", v']) 78 79 escape c = if elem c optionallyEncoded 80 then [c] 81 else printf "%%%02X" (ord c) 82 83-- | Convert a list of addresses to a string in the format expected by 84-- 'parseAddresses'. 85formatAddresses :: [Address] -> String 86formatAddresses = intercalate ";" . map formatAddress 87 88instance Show Address where 89 showsPrec d x = showParen (d > 10) $ 90 showString "Address " . 91 shows (formatAddress x) 92 93-- | Try to parse a string containing one valid address. 94-- 95-- An address string is in the format @method:key1=val1,key2=val2@. There 96-- are some limitations on the characters allowed within methods and 97-- parameters; see the D-Bus specification for full details. 98parseAddress :: String -> Maybe Address 99parseAddress = maybeParseString $ do 100 addr <- parsecAddress 101 eof 102 return addr 103 104-- | Try to parse a string containing one or more valid addresses. 105-- 106-- Addresses are separated by semicolons. See 'parseAddress' for the format 107-- of addresses. 108parseAddresses :: String -> Maybe [Address] 109parseAddresses = maybeParseString $ do 110 addrs <- sepEndBy parsecAddress (char ';') 111 eof 112 return addrs 113 114parsecAddress :: Parser Address 115parsecAddress = p where 116 p = do 117 method <- many (noneOf ":;") 118 _ <- char ':' 119 params <- sepEndBy param (char ',') 120 return (Address method (Data.Map.fromList params)) 121 122 param = do 123 key <- many1 (noneOf "=;,") 124 _ <- char '=' 125 value <- many1 valueChar 126 return (key, value) 127 128 valueChar = encoded <|> unencoded 129 encoded = do 130 _ <- char '%' 131 hex <- count 2 hexDigit 132 return (chr (hexToInt hex)) 133 unencoded = oneOf optionallyEncoded 134 135-- | Returns the address in the environment variable 136-- @DBUS_SYSTEM_BUS_ADDRESS@, or 137-- @unix:path=\/var\/run\/dbus\/system_bus_socket@ if @DBUS_SYSTEM_BUS_ADDRESS@ 138-- is not set. 139-- 140-- Returns 'Nothing' if @DBUS_SYSTEM_BUS_ADDRESS@ contains an invalid address. 141getSystemAddress :: IO (Maybe Address) 142getSystemAddress = do 143 let system = "unix:path=/var/run/dbus/system_bus_socket" 144 env <- lookupEnv "DBUS_SYSTEM_BUS_ADDRESS" 145 return (parseAddress (fromMaybe system env)) 146 147-- | Returns the first address in the environment variable 148-- @DBUS_SESSION_BUS_ADDRESS@, which must be set. 149-- 150-- Returns 'Nothing' if @DBUS_SYSTEM_BUS_ADDRESS@ contains an invalid address 151-- or @DBUS_SYSTEM_BUS_ADDRESS@ is unset @XDG_RUNTIME_DIR@ doesn't have @/bus@. 152getSessionAddress :: IO (Maybe Address) 153getSessionAddress = lookupEnv "DBUS_SESSION_BUS_ADDRESS" >>= \case 154 Just addrs -> pure (parseAddresses addrs >>= listToMaybe) 155 Nothing -> (>>= parseFallback) <$> lookupEnv "XDG_RUNTIME_DIR" 156 where 157 parseFallback dir = parseAddress ("unix:path=" ++ dir ++ "/bus") 158 159-- | Returns the address in the environment variable 160-- @DBUS_STARTER_ADDRESS@, which must be set. 161-- 162-- Returns 'Nothing' if @DBUS_STARTER_ADDRESS@ is unset or contains an 163-- invalid address. 164getStarterAddress :: IO (Maybe Address) 165getStarterAddress = do 166 env <- lookupEnv "DBUS_STARTER_ADDRESS" 167 return (env >>= parseAddress) 168 169hexToInt :: String -> Int 170hexToInt = foldl ((+) . (16 *)) 0 . map digitToInt 171 172maybeParseString :: Parser a -> String -> Maybe a 173maybeParseString p str = case runParser p () "" str of 174 Left _ -> Nothing 175 Right a -> Just a 176