module DBus.Connection.Authentication
( Mechanism
, mechanism
, authenticate
, external
) where
import Prelude hiding (getLine, head)
import Control.Monad (liftM)
import qualified Data.ByteString
import qualified Data.ByteString.Char8
import Data.Char (ord)
import qualified System.Posix.User
import Text.Printf (printf)
import DBus.Connection.Transport
import DBus.Util (readUntil, dropEnd)
authenticate :: Socket
-> [Mechanism]
-> IO Bool
authenticate s mechanisms = do
socketPut s (Data.ByteString.pack [0])
let loop [] = return False
loop ((Mechanism m):next) = do
success <- m s
if success
then return True
else loop next
loop mechanisms
newtype Mechanism = Mechanism (Socket -> IO Bool)
mechanism :: (Socket -> IO Bool) -> Mechanism
mechanism = Mechanism
data Auth a = Auth
{ unAuth :: Socket -> IO a
}
instance Monad Auth where
return a = Auth (\_ -> return a)
m >>= k = Auth $ \s -> do
x <- unAuth m s
unAuth (k x) s
liftIO :: IO a -> Auth a
liftIO io = Auth (\_ -> io)
putLine :: String -> Auth ()
putLine line = Auth $ \s -> do
let pack = Data.ByteString.Char8.pack
socketPut s (pack (line ++ "\r\n"))
getLine :: Auth String
getLine = Auth $ \s -> do
let head = Data.ByteString.Char8.head
let getchr = liftM head (socketGet s 1)
raw <- readUntil "\r\n" getchr
return (dropEnd 2 raw)
external :: Mechanism
external = Mechanism $ unAuth $ do
uid <- liftIO System.Posix.User.getRealUserID
let token = concatMap (printf "%02X" . ord) (show uid)
putLine ("AUTH EXTERNAL " ++ token)
resp <- getLine
case takeWhile (/= ' ') resp of
"OK" -> do
putLine "BEGIN"
return True
_ -> return False