module Web.Authenticate.Kerberos
( loginKerberos
, KerberosAuthResult(..)
) where
import Data.Text (Text)
import qualified Data.Text as T
import Data.Maybe (fromJust)
import Control.Monad (msum, guard)
import System.Process (readProcessWithExitCode)
import System.Timeout (timeout)
import System.Exit (ExitCode(..))
data KerberosAuthResult = Ok
| NoSuchUser
| WrongPassword
| TimeOut
| UnknownError Text
instance Show KerberosAuthResult where
show Ok = "Login sucessful"
show NoSuchUser = "Wrong username"
show WrongPassword = "Wrong password"
show TimeOut = "kinit respone timeout"
show (UnknownError msg) = "Unkown error: " ++ T.unpack msg
interpretError :: Int -> Text -> KerberosAuthResult
interpretError _ errmsg = fromJust . msum $
["Client not found in Kerberos database while getting" --> NoSuchUser,
"Preauthentication failed while getting" --> WrongPassword,
Just $ UnknownError errmsg]
where
substr --> kError = guard (substr `T.isInfixOf` errmsg) >> Just kError
loginKerberos :: Text
-> Text
-> IO KerberosAuthResult
loginKerberos username password = do
timedFetch <- timeout (10*1000000) fetch
case timedFetch of
Just res -> return res
Nothing -> return TimeOut
where
fetch :: IO KerberosAuthResult
fetch = do
(exitCode, _out, err) <- readProcessWithExitCode
"kinit" [T.unpack username] (T.unpack password)
case exitCode of
ExitSuccess -> return Ok
ExitFailure x -> return $ interpretError x (T.pack err)