#line 27 "src/authentication.anansi"
#line 30 "src/introduction.anansi"
#line 28 "src/authentication.anansi"
#line 52 "src/introduction.anansi"
#line 29 "src/authentication.anansi"
module DBus.Authentication
( Command
, Mechanism (..)
, AuthenticationError (..)
, authenticate
, realUserID
) where
#line 56 "src/introduction.anansi"
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as TL
#line 38 "src/authentication.anansi"
#line 45 "src/authentication.anansi"
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as ByteString
import Data.ByteString.Lazy.Char8 ()
import qualified DBus.UUID as UUID
#line 61 "src/authentication.anansi"
import Data.Typeable (Typeable)
import qualified Control.Exception as E
#line 78 "src/authentication.anansi"
import Data.Word (Word8)
#line 94 "src/authentication.anansi"
import Control.Monad (liftM)
import Data.Char (chr)
import Data.Text.Lazy.Encoding (encodeUtf8)
import DBus.Util (readUntil, dropEnd)
#line 115 "src/authentication.anansi"
import System.Posix.User (getRealUserID)
import Data.Char (ord)
import Text.Printf (printf)
#line 136 "src/authentication.anansi"
import Data.Maybe (isJust)
#line 52 "src/authentication.anansi"
type Command = Text
newtype Mechanism = Mechanism
{ mechanismRun :: (Command -> IO Command) -> IO UUID.UUID
}
#line 66 "src/authentication.anansi"
data AuthenticationError
= AuthenticationError Text
deriving (Show, Typeable)
instance E.Exception AuthenticationError
#line 82 "src/authentication.anansi"
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
#line 101 "src/authentication.anansi"
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
#line 121 "src/authentication.anansi"
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
#line 140 "src/authentication.anansi"
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