#line 27 "src/authentication.anansi"

#line 30 "src/introduction.anansi"
-- Copyright (C) 2009-2010 John Millikin <jmillikin@gmail.com>
-- 
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- any later version.
-- 
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

#line 28 "src/authentication.anansi"

#line 52 "src/introduction.anansi"
{-# LANGUAGE OverloadedStrings #-}

#line 29 "src/authentication.anansi"
{-# LANGUAGE DeriveDataTypeable #-}
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