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