Merge pull request #12 from Tarrasch/master

Addition of Kerberos module

Web/Authenticate/Kerberos.hs

@@ -0,0 +1,72 @@
+{-# 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)
+

authenticate.cabal

@@ -1,8 +1,8 @@
 name:            authenticate
-version:         0.9.2.2
+version:         0.9.2.3
 license:         BSD3
 license-file:    LICENSE
-author:          Michael Snoyman, Hiromi Ishii
+author:          Michael Snoyman, Hiromi Ishii, Arash Rouhani
 maintainer:      Michael Snoyman <michael@snoyman.com>
 synopsis:        Authentication methods for Haskell web applications.
 description:     Focus is on third-party authentication methods, such as OpenID,
@@ -35,13 +35,15 @@ library
                      blaze-builder >= 0.2 && < 0.4,
                      attoparsec >= 0.9   && < 0.10,
                      tls >= 0.7 && < 0.8,
-                     containers
+                     containers,
+                     process >= 1.0.1.1 && < 1.1
     exposed-modules: Web.Authenticate.Rpxnow,
                      Web.Authenticate.OpenId,
                      Web.Authenticate.BrowserId,
                      Web.Authenticate.OpenId.Providers,
                      Web.Authenticate.OAuth,
                      Web.Authenticate.Facebook
+                     Web.Authenticate.Kerberos
     other-modules:   Web.Authenticate.Internal,
                      OpenId2.Discovery,
                      OpenId2.Normalization,