Authentication.hs


-- 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 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