From f660f7dd3d71d2588eb55a9bb92ccbf5bba0ed71 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Thu, 17 May 2007 18:44:27 +0000
Subject: [PATCH] Support for Kerberos auth

---
 config.sig |  1 +
 config.sml |  2 ++
 init.sml   | 54 +++++++++++++++++++++++++++++++-----------------------
 3 files changed, 34 insertions(+), 23 deletions(-)

diff --git a/config.sig b/config.sig
index 1fe37f8..d3ca805 100644
--- a/config.sig
+++ b/config.sig
@@ -5,5 +5,6 @@ val urlPrefix : string
 val emailSuffix : string
 val boardEmail : string
 val dbstring : string
+val kerberosSuffix : string
 
 end
diff --git a/config.sml b/config.sml
index 25a4cdb..ab7cfec 100644
--- a/config.sml
+++ b/config.sml
@@ -7,4 +7,6 @@ val boardEmail = "board" ^ emailSuffix
 
 val dbstring = "dbname='hcoop_hcoop' user='www-data'"
 
+val kerberosSuffix = "@HCOOP.NET"
+
 end
diff --git a/init.sml b/init.sml
index d6aae9c..9352b3e 100644
--- a/init.sml
+++ b/init.sml
@@ -43,32 +43,40 @@ fun init () =
 	case Web.getCgi "REMOTE_USER" of
 	    NONE => raise Fail "Not logged in"
 	  | SOME name =>
-	    (case C.oneOrNoRows c ($`SELECT id, name, rname, bal, joined, app, shares
-  				     FROM WebUserActive
-				     WHERE name=^(C.stringToSql name)`) of
-		 NONE => raise Fail "User not found"
-	       | SOME r =>
-		 let
-		     val r = mkUserRow r
-		 in
-		     user := SOME r;
-		     case C.oneOrNoRows c ($`SELECT ipaddr
+	    let
+		val name =
+		    if String.isSuffix kerberosSuffix name then
+			String.substring (name, 0, size name - size kerberosSuffix)
+		    else
+			name
+	    in
+		case C.oneOrNoRows c ($`SELECT id, name, rname, bal, joined, app, shares
+  				        FROM WebUserActive
+					WHERE name=^(C.stringToSql name)`) of
+		    NONE => raise Fail "User not found"
+		  | SOME r =>
+		    let
+			val r = mkUserRow r
+		    in
+			user := SOME r;
+			case C.oneOrNoRows c ($`SELECT ipaddr
 					        FROM MemberApp
 					        WHERE id = ^(C.intToSql (#app r))
-						   AND ipaddr IS NOT NULL`) of
-			 NONE =>
-			 if Web.getParam "agree" = "on" then
-			     (case Web.getCgi "REMOTE_ADDR" of
-				  NONE => raise Fail "REMOTE_ADDR not set"
-				| SOME ra =>
-				  ignore (C.dml c ($`UPDATE MemberApp
+								AND ipaddr IS NOT NULL`) of
+			    NONE =>
+			    if Web.getParam "agree" = "on" then
+				(case Web.getCgi "REMOTE_ADDR" of
+				     NONE => raise Fail "REMOTE_ADDR not set"
+				   | SOME ra =>
+				     ignore (C.dml c ($`UPDATE MemberApp
 					                SET ipaddr = ^(C.stringToSql ra),
-						            applied = CURRENT_TIMESTAMP
-						        WHERE id = ^(C.intToSql (#app r))`)))
-			 else
-			     raise NeedTos
-		       | _ => ()
-		 end)
+						          applied = CURRENT_TIMESTAMP
+							WHERE id = ^(C.intToSql (#app r))`)))
+			    else
+				raise NeedTos
+			  | _ => ()
+		    end
+	    end
     end
 
 fun done () =
-- 
2.20.1