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 Data.ByteString.Lazy.Char8 ()
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