73 lines
2.5 KiB
Haskell
73 lines
2.5 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
-- | Module for using a kerberos authentication service.
|
|
--
|
|
-- Please note that all configuration should have been done
|
|
-- manually on the machine prior to running the code.
|
|
--
|
|
-- On linux machines the configuration might be in /etc/krb5.conf.
|
|
-- It's worth checking if the Kerberos service provider (e.g. your university)
|
|
-- already provide a complete configuration file.
|
|
--
|
|
-- Be certain that you can manually login from a shell by typing
|
|
--
|
|
-- > kinit username
|
|
--
|
|
-- If you fill in your password and the program returns no error code,
|
|
-- then your kerberos configuration is setup properly.
|
|
-- Only then can this module be of any use.
|
|
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(..))
|
|
|
|
-- | Occurreable results of a Kerberos login
|
|
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
|
|
|
|
|
|
-- Given the errcode and stderr, return error-value
|
|
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
|
|
|
|
-- | Given the username and password, try login to Kerberos service
|
|
loginKerberos :: Text -- ^ Username
|
|
-> Text -- ^ Password
|
|
-> 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)
|
|
|