From 1f0f26ddcf7846113713a7c7ba2a40296a6faac8 Mon Sep 17 00:00:00 2001
From: Arash Rouhani <miffoljud@gmail.com>
Date: Sun, 14 Aug 2011 21:32:53 +0200
Subject: [PATCH 1/5] version bump authenticate

---
 yesod-auth/yesod-auth.cabal | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal
index 3436a8d4..b1d49cb2 100644
--- a/yesod-auth/yesod-auth.cabal
+++ b/yesod-auth/yesod-auth.cabal
@@ -20,7 +20,7 @@ library
         cpp-options:     -DGHC7
     else
         build-depends:   base                      >= 4        && < 4.3
-    build-depends:   authenticate            >= 0.9.2     && < 0.10
+    build-depends:   authenticate            >= 0.9.2.3   && < 0.10
                    , bytestring              >= 0.9.1.4   && < 0.10
                    , yesod-core              >= 0.9       && < 0.10
                    , wai                     >= 0.4       && < 0.5

From fbf4d9c4d359ecea244331e587209fa6fa66c30b Mon Sep 17 00:00:00 2001
From: Arash Rouhani <miffoljud@gmail.com>
Date: Sun, 14 Aug 2011 21:43:08 +0200
Subject: [PATCH 2/5] Added Kerberos yesod wrapper and added to modules

---
 yesod-auth/Yesod/Auth/Kerberos.hs | 97 +++++++++++++++++++++++++++++++
 yesod-auth/yesod-auth.cabal       |  1 +
 2 files changed, 98 insertions(+)
 create mode 100644 yesod-auth/Yesod/Auth/Kerberos.hs

diff --git a/yesod-auth/Yesod/Auth/Kerberos.hs b/yesod-auth/Yesod/Auth/Kerberos.hs
new file mode 100644
index 00000000..c30d86ff
--- /dev/null
+++ b/yesod-auth/Yesod/Auth/Kerberos.hs
@@ -0,0 +1,97 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Yesod.Auth.Kerberos
+    ( authKerberos,
+      genericAuthKerberos,
+      KerberosConfig(..)
+    ) where
+
+#include "qq.h"
+
+import Yesod.Auth
+import Web.Authenticate.Kerberos
+import Data.Text (Text)
+import qualified Data.Text as T
+import Text.Hamlet
+import Yesod.Handler
+import Yesod.Widget
+import Control.Monad.IO.Class (liftIO)
+import Yesod.Form
+import Control.Applicative ((<$>), (<*>))
+
+data KerberosConfig = KerberosConfig {
+    -- | When a user gives username x, f(x) will be passed to Kerberos
+    usernameModifier :: Text -> Text
+    -- | When a user gives username x, f(x) will be passed to Yesod
+  , identifierModifier :: Text -> Text
+  }
+
+defaultKerberosConfig :: KerberosConfig
+defaultKerberosConfig = KerberosConfig id id
+
+genericAuthKerberos :: YesodAuth m => KerberosConfig -> AuthPlugin m
+genericAuthKerberos config = AuthPlugin "kerberos" dispatch $ \tm -> addHamlet
+    [hamlet|
+    <div id="header">
+        <h1>Login
+
+    <div id="login">
+        <form method="post" action="@{tm login}">
+            <table>
+                <tr>
+                    <th>Username:
+                    <td>
+                        <input id="x" name="username" autofocus="" required>
+                <tr>
+                    <th>Password:
+                    <td>
+                        <input type="password" name="password" required>
+                <tr>
+                    <td>&nbsp;
+                    <td>
+                        <input type="submit" value="Login">
+
+            <script>
+                if (!("autofocus" in document.createElement("input"))) {
+                    document.getElementById("x").focus();
+                }
+|]
+  where
+    dispatch "POST" ["login"] = postLoginR config >>= sendResponse
+    dispatch _ _              = notFound
+
+login :: AuthRoute
+login = PluginR "kerberos" ["login"]
+
+authKerberos :: YesodAuth m => AuthPlugin m
+authKerberos = genericAuthKerberos defaultKerberosConfig
+
+-- | Handle the login form
+postLoginR :: (YesodAuth y) => KerberosConfig -> GHandler Auth y ()
+postLoginR config = do
+    (mu,mp) <- runInputPost $ (,)
+        <$> iopt textField "username"
+        <*> iopt textField "password"
+
+    let errorMessage (message :: Text) = do
+        setMessage [html| Error: #{message} |]
+        toMaster <- getRouteToMaster
+        redirect RedirectTemporary $ toMaster LoginR
+
+    case (mu,mp) of
+        (Nothing, _      ) -> errorMessage "Please fill in your username"
+        (_      , Nothing) -> errorMessage "Please fill in your password"
+        (Just u , Just p ) -> do
+          result <- liftIO $ loginKerberos (usernameModifier config u) p
+          case result of
+            Ok -> do
+                let creds = Creds
+                      { credsIdent  = identifierModifier config u
+                      , credsPlugin = "Kerberos"
+                      , credsExtra  = []
+                      }
+                setCreds True creds
+            kerberosError -> errorMessage (T.pack $ show kerberosError)
+
diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal
index b1d49cb2..e9c5fb79 100644
--- a/yesod-auth/yesod-auth.cabal
+++ b/yesod-auth/yesod-auth.cabal
@@ -55,6 +55,7 @@ library
                      Yesod.Auth.Rpxnow
                      Yesod.Auth.HashDB
                      Yesod.Auth.Message
+                     Yesod.Auth.Kerberos
     ghc-options:     -Wall
     include-dirs: include
 

From 52f2051e8b4cbf68f250b5b60605c6bd8da1c0c0 Mon Sep 17 00:00:00 2001
From: Arash Rouhani <miffoljud@gmail.com>
Date: Sun, 14 Aug 2011 22:54:37 +0200
Subject: [PATCH 3/5] Added minimal example of using kerberos

---
 yesod-auth/kerberos.hs | 42 ++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 42 insertions(+)
 create mode 100644 yesod-auth/kerberos.hs

diff --git a/yesod-auth/kerberos.hs b/yesod-auth/kerberos.hs
new file mode 100644
index 00000000..38d5647a
--- /dev/null
+++ b/yesod-auth/kerberos.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+import Yesod
+import Yesod.Auth
+import Yesod.Form
+import Yesod.Auth.Kerberos
+
+data Kerberos = Kerberos
+type Handler = GHandler Kerberos Kerberos
+
+mkYesod "Kerberos" [parseRoutes|
+/ RootR GET
+/after AfterLoginR GET
+/auth AuthR Auth getAuth
+|]
+
+getRootR :: Handler ()
+getRootR = redirect RedirectTemporary $ AuthR LoginR
+
+getAfterLoginR :: Handler RepHtml
+getAfterLoginR = defaultLayout $ return ()
+
+instance Yesod Kerberos where
+    approot _ = "http://localhost:3000"
+
+instance YesodAuth Kerberos where
+    type AuthId Kerberos = String
+    loginDest _ = AfterLoginR
+    logoutDest _ = AuthR LoginR
+    getAuthId _ = do
+        liftIO $ putStrLn "getAuthId"
+        return $ Just "foo"
+    authPlugins = [authKerberos]
+
+instance RenderMessage Kerberos FormMessage where
+    renderMessage _ _ = defaultFormMessage
+
+main :: IO ()
+main = warpDebug 3000 Kerberos

From 4589a7b08e58de5127cb95e18d5e55391856e358 Mon Sep 17 00:00:00 2001
From: Arash Rouhani <miffoljud@gmail.com>
Date: Mon, 15 Aug 2011 00:01:07 +0200
Subject: [PATCH 4/5] Added exporting of defaultKerberosConfig

---
 yesod-auth/Yesod/Auth/Kerberos.hs | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/yesod-auth/Yesod/Auth/Kerberos.hs b/yesod-auth/Yesod/Auth/Kerberos.hs
index c30d86ff..b3196248 100644
--- a/yesod-auth/Yesod/Auth/Kerberos.hs
+++ b/yesod-auth/Yesod/Auth/Kerberos.hs
@@ -5,7 +5,8 @@
 module Yesod.Auth.Kerberos
     ( authKerberos,
       genericAuthKerberos,
-      KerberosConfig(..)
+      KerberosConfig(..),
+      defaultKerberosConfig
     ) where
 
 #include "qq.h"

From 0c1dde8209c06901866a1e62def43050d5d558fa Mon Sep 17 00:00:00 2001
From: Arash Rouhani <miffoljud@gmail.com>
Date: Mon, 15 Aug 2011 00:01:42 +0200
Subject: [PATCH 5/5] Added documentation for Kerberos module

---
 yesod-auth/Yesod/Auth/Kerberos.hs | 20 ++++++++++++++++++++
 1 file changed, 20 insertions(+)

diff --git a/yesod-auth/Yesod/Auth/Kerberos.hs b/yesod-auth/Yesod/Auth/Kerberos.hs
index b3196248..319ee72d 100644
--- a/yesod-auth/Yesod/Auth/Kerberos.hs
+++ b/yesod-auth/Yesod/Auth/Kerberos.hs
@@ -2,6 +2,22 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE OverloadedStrings #-}
+-- | In-built kerberos authentication for Yesod.
+--
+-- 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 Yesod.Auth.Kerberos
     ( authKerberos,
       genericAuthKerberos,
@@ -29,9 +45,12 @@ data KerberosConfig = KerberosConfig {
   , identifierModifier :: Text -> Text
   }
 
+-- | A configuration where the username the user provides is the one passed
+-- to both kerberos and yesod
 defaultKerberosConfig :: KerberosConfig
 defaultKerberosConfig = KerberosConfig id id
 
+-- | A configurable version of 'authKerberos'
 genericAuthKerberos :: YesodAuth m => KerberosConfig -> AuthPlugin m
 genericAuthKerberos config = AuthPlugin "kerberos" dispatch $ \tm -> addHamlet
     [hamlet|
@@ -66,6 +85,7 @@ genericAuthKerberos config = AuthPlugin "kerberos" dispatch $ \tm -> addHamlet
 login :: AuthRoute
 login = PluginR "kerberos" ["login"]
 
+-- | Kerberos with 'defaultKerberosConfig'
 authKerberos :: YesodAuth m => AuthPlugin m
 authKerberos = genericAuthKerberos defaultKerberosConfig