<commit_before>;;;; Copyright (c) <NAME> 2015 <<EMAIL>>
;;;; This code is licensed under the MIT license.

;;; This file contains the codes necessary to wrap the underlying
;;; kerberos calls in a gss-like API
;;; 

(in-package #:cerberus)

;; 
;; gss requires us to encode a structure to put into the checksum of the authenticator 
;; the checksum type is #x8003 (see rfc1964 sec 1.1.1)
;; (defun encode-gss-checksum ()
;;   (flexi-streams:with-output-to-sequence (s)
;;     (nibbles:write-ub32/le 16 s) ;; length of bind field
;;     ;; md5 hash of channel bindings
;;     ;; flags

;; -------------------- for everyone ------------
;; everyone calls this, but the semantics are different if you are a server or client 

(defclass kerberos-credential ()
  ())

(defclass kerberos-client-credential (kerberos-credential)
  ((tgt :initarg :tgt :reader client-credential-tgt)
   (creds :initarg :creds :reader client-credential-creds)))

(defclass kerberos-server-credential (kerberos-credential)
  ((keylist :initarg :keylist :reader server-credential-keylist)))

(defmethod print-object ((cred kerberos-credential) stream)
  (print-unreadable-object (cred stream :type t :identity t)))


;; it is assumed the user has already logged in using LOGON-USER
(defmethod glass:acquire-credentials ((mech-type (eql :kerberos)) principal &key)
  (cond
    ((null *current-user*)
     (error 'glass:gss-error :major :no-cred))
    ((null principal)
     ;; application server providing keylist
     (make-instance 'kerberos-server-credential 
		    :keylist (login-token-keylist *current-user*)))
    (principal 
     (multiple-value-bind (principal realm) (string-principal principal)
       ;; try to get a tgt we already have
       (let ((tgt *current-user*))		      
	 ;; check the realms match because we don't support cross-realm requests yet
	 (unless (or (null realm) (string= realm (login-token-realm tgt)))
	   (error "Cross-realm requests not currently supported"))
	 (let ((creds (request-credentials tgt principal)))
	   (make-instance 'kerberos-client-credential
			  :tgt tgt
			  :creds creds)))))))
    
;; ------------------- for the client ------------------------


(defclass kerberos-context ()
  ((req :initarg :req :initform nil :accessor kerberos-context-req)
   (key :initform nil :accessor kerberos-context-key)
   (seqno :initform 0 :accessor kerberos-context-seqno)))

(defclass kerberos-client-context (kerberos-context)
  ())

(defmethod print-object ((context kerberos-context) stream)
  (print-unreadable-object (context stream :type t :identity t)))
      
(defmethod glass:initialize-security-context ((credentials kerberos-client-credential) &key mutual)
  (let ((context (make-instance 'kerberos-client-context)))				
    (let* ((req (make-ap-request (client-credential-creds credentials)
				 :mutual mutual
				 :seqno (kerberos-context-seqno context))) ;; FIXME: also need the special packed checksum!
	   (buffer (pack-initial-context-token req)))
    (setf (kerberos-context-req context) req
	  (kerberos-context-key context)
	  ;; the session key can be found in the crednetials (which is a kdc-rep)
	  (enc-kdc-rep-part-key (kdc-rep-enc-part (client-credential-creds credentials))))
    (values context buffer))))

;; this method is used by clients to authenticate servers (when mutual authentication is required)
(defmethod glass:initialize-security-context ((context kerberos-client-context) &key buffer)
  ;; the buffer contains a packed ap-rep structure
  (let ((ap-rep (unpack-initial-context-token buffer)))
    (declare (ignore ap-rep))
    ;; FIXME: validate the timestamps in the ap-rep match those we sent in the ap-req 
    context))

;; ---------- for the application server -----------

(defclass kerberos-server-context (kerberos-context)
  ())

(defmethod glass:accept-security-context ((credentials kerberos-server-credential) buffer &key)
  (let ((ap-req (unpack-initial-context-token buffer)))
    (let ((cxt 
           (make-instance 'kerberos-server-context 
                          :req (valid-ticket-p (server-credential-keylist credentials) ap-req))))
      (setf (kerberos-context-key cxt) 
	    (enc-ticket-part-key (ticket-enc-part (ap-req-ticket ap-req))))
      ;; if mutual authentication required then we need to pack a response buffer (an AP-REP structure)
      ;; to reply with
      (if (member :mutual-required (ap-req-options ap-req))
	  (values cxt (pack-initial-context-token 
		       (make-ap-response (kerberos-context-key cxt)
					 ap-req)))
	  (values cxt nil)))))

;; this is for context deletion, do we need it?
;;(defgeneric gss-process-context-token (mech-type context &key)
;;  (:documentation "CONTEXT is returned from ACCEPT-SECURITY-CONTEXT. c.f. GSS_Process_context_token"))
<commit_msg>adding new function to get a string representing the authenticated caller<commit_after>;;;; Copyright (c) <NAME> 2015 <<EMAIL>>
;;;; This code is licensed under the MIT license.

;;; This file contains the codes necessary to wrap the underlying
;;; kerberos calls in a gss-like API
;;; 

(in-package #:cerberus)

;; 
;; gss requires us to encode a structure to put into the checksum of the authenticator 
;; the checksum type is #x8003 (see rfc1964 sec 1.1.1)
;; (defun encode-gss-checksum ()
;;   (flexi-streams:with-output-to-sequence (s)
;;     (nibbles:write-ub32/le 16 s) ;; length of bind field
;;     ;; md5 hash of channel bindings
;;     ;; flags

;; -------------------- for everyone ------------
;; everyone calls this, but the semantics are different if you are a server or client 

(defclass kerberos-credential ()
  ())

(defclass kerberos-client-credential (kerberos-credential)
  ((tgt :initarg :tgt :reader client-credential-tgt)
   (creds :initarg :creds :reader client-credential-creds)))

(defclass kerberos-server-credential (kerberos-credential)
  ((keylist :initarg :keylist :reader server-credential-keylist)))

(defmethod print-object ((cred kerberos-credential) stream)
  (print-unreadable-object (cred stream :type t :identity t)))


;; it is assumed the user has already logged in using LOGON-USER
(defmethod glass:acquire-credentials ((mech-type (eql :kerberos)) principal &key)
  (cond
    ((null *current-user*)
     (error 'glass:gss-error :major :no-cred))
    ((null principal)
     ;; application server providing keylist
     (make-instance 'kerberos-server-credential 
		    :keylist (login-token-keylist *current-user*)))
    (principal 
     (multiple-value-bind (principal realm) (string-principal principal)
       ;; try to get a tgt we already have
       (let ((tgt *current-user*))		      
	 ;; check the realms match because we don't support cross-realm requests yet
	 (unless (or (null realm) (string= realm (login-token-realm tgt)))
	   (error "Cross-realm requests not currently supported"))
	 (let ((creds (request-credentials tgt principal)))
	   (make-instance 'kerberos-client-credential
			  :tgt tgt
			  :creds creds)))))))
    
;; ------------------- for the client ------------------------


(defclass kerberos-context ()
  ((req :initarg :req :initform nil :accessor kerberos-context-req)
   (key :initform nil :accessor kerberos-context-key)
   (seqno :initform 0 :accessor kerberos-context-seqno)))

(defclass kerberos-client-context (kerberos-context)
  ())

(defmethod print-object ((context kerberos-context) stream)
  (print-unreadable-object (context stream :type t :identity t)))
      
(defmethod glass:initialize-security-context ((credentials kerberos-client-credential) &key mutual)
  (let ((context (make-instance 'kerberos-client-context)))				
    (let* ((req (make-ap-request (client-credential-creds credentials)
				 :mutual mutual
				 :seqno (kerberos-context-seqno context))) ;; FIXME: also need the special packed checksum!
	   (buffer (pack-initial-context-token req)))
    (setf (kerberos-context-req context) req
	  (kerberos-context-key context)
	  ;; the session key can be found in the crednetials (which is a kdc-rep)
	  (enc-kdc-rep-part-key (kdc-rep-enc-part (client-credential-creds credentials))))
    (values context buffer))))

;; this method is used by clients to authenticate servers (when mutual authentication is required)
(defmethod glass:initialize-security-context ((context kerberos-client-context) &key buffer)
  ;; the buffer contains a packed ap-rep structure
  (let ((ap-rep (unpack-initial-context-token buffer)))
    (declare (ignore ap-rep))
    ;; FIXME: validate the timestamps in the ap-rep match those we sent in the ap-req 
    context))

;; ---------- for the application server -----------

(defclass kerberos-server-context (kerberos-context)
  ())

(defmethod glass:accept-security-context ((credentials kerberos-server-credential) buffer &key)
  (let ((ap-req (unpack-initial-context-token buffer)))
    (let ((cxt 
           (make-instance 'kerberos-server-context 
                          :req (valid-ticket-p (server-credential-keylist credentials) ap-req))))
      (setf (kerberos-context-key cxt) 
	    (enc-ticket-part-key (ticket-enc-part (ap-req-ticket ap-req))))
      ;; if mutual authentication required then we need to pack a response buffer (an AP-REP structure)
      ;; to reply with
      (if (member :mutual-required (ap-req-options ap-req))
	  (values cxt (pack-initial-context-token 
		       (make-ap-response (kerberos-context-key cxt)
					 ap-req)))
	  (values cxt nil)))))

;; this is for context deletion, do we need it?
;;(defgeneric gss-process-context-token (mech-type context &key)
;;  (:documentation "CONTEXT is returned from ACCEPT-SECURITY-CONTEXT. c.f. GSS_Process_context_token"))

;; this is used to generate a stringy name which corresponds to the person who has been authenticated by this context
(defmethod glass:context-principal-name ((context kerberos-server-context) &key)
  (let ((req (kerberos-context-req context)))
    (principal-string (authenticator-cname (ap-req-authenticator req))
		      (authenticator-crealm (ap-req-authenticator req)))))

{'fraction_non_alphanumeric': 0.14018411046627977, 'fraction_numerical': 0.004202521512907745, 'mean_word_length': 3.53905540417802, 'pattern_counts': {'":': 0, '<': 9, '<?xml version=': 0, '>': 9, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2687251', 'n_tokens_mistral': 3217, 'n_tokens_neox': 3037, 'n_words': 934}