-- 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/>.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
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