module DBus.Authentication
( Command
, Mechanism (..)
, AuthenticationError (..)
, authenticate
, realUserID
) where
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as TL
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as ByteString
import qualified DBus.UUID as UUID
import Data.Typeable (Typeable)
import qualified Control.Exception as E
import Data.Word (Word8)
import Control.Monad (liftM)
import Data.Char (chr)
import Data.Text.Lazy.Encoding (encodeUtf8)
import DBus.Util (readUntil, dropEnd)
import System.Posix.User (getRealUserID)
import Data.Char (ord)
import Text.Printf (printf)
import Data.Maybe (isJust)
type Command = Text
newtype Mechanism = Mechanism
{ mechanismRun :: (Command -> IO Command) -> IO UUID.UUID
}
data AuthenticationError
= AuthenticationError Text
deriving (Show, Typeable)
instance E.Exception AuthenticationError
authenticate :: Mechanism -> (ByteString -> IO ()) -> IO Word8
-> IO UUID.UUID
authenticate mech put getByte = do
put $ ByteString.singleton 0
uuid <- mechanismRun mech (putCommand put getByte)
put "BEGIN\r\n"
return uuid
putCommand :: Monad m => (ByteString -> m ()) -> m Word8 -> Command -> m Command
putCommand put get cmd = do
let getC = liftM (chr . fromIntegral) get
put $ encodeUtf8 cmd
put "\r\n"
liftM (TL.pack . dropEnd 2) $ readUntil "\r\n" getC
realUserID :: Mechanism
realUserID = Mechanism $ \sendCmd -> do
uid <- getRealUserID
let token = concatMap (printf "%02X" . ord) (show uid)
let cmd = "AUTH EXTERNAL " ++ token
eitherUUID <- checkOK `fmap` sendCmd (TL.pack cmd)
case eitherUUID of
Right uuid -> return uuid
Left err -> E.throwIO $ AuthenticationError err
checkOK :: Command -> Either Text UUID.UUID
checkOK cmd = if validUUID then Right uuid else Left errorMsg where
validUUID = TL.isPrefixOf "OK " cmd && isJust maybeUUID
maybeUUID = UUID.fromHex $ TL.drop 3 cmd
Just uuid = maybeUUID
errorMsg = if TL.isPrefixOf "ERROR " cmd
then TL.drop 6 cmd
else TL.pack $ "Unexpected response: " ++ show cmd