{-
  Copyright (C) 2009 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