;;; ntlm-tests.el --- tests for ntlm.el            -*- lexical-binding: t -*-

;; Copyright (C) 2020-2021 Free Software Foundation, Inc.

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; Run this with `NTLM_TESTS_VERBOSE=1' to get verbose debugging.

;;; Code:

(require 'ert)
(require 'ert-x)
(require 'ntlm)

(defsubst ntlm-tests-message (format-string &rest arguments)
  "Print a message conditional on an environment variable being set.
FORMAT-STRING and ARGUMENTS are passed to the message function."
  (when (getenv "NTLM_TESTS_VERBOSE")
    (apply #'message (concat "ntlm-tests: " format-string) arguments)))


;; This is the Lisp bignum implementation of `ntlm--time-to-timestamp',
;; for reference.

(defun ntlm-tests--time-to-timestamp (time)
  "Convert TIME to an NTLMv2 timestamp.
Return a unibyte string representing the number of tenths of a
microsecond since January 1, 1601 as a 64-bit little-endian
signed integer.  TIME must be on the form (HIGH LOW USEC PSEC)."
  (let* ((s (+ (ash (nth 0 time) 16) (nth 1 time)))
         (us (nth 2 time))
         (ps (nth 3 time))
         (tenths-of-us-since-jan-1-1601
          (+ (* s 10000000) (* us 10) (/ ps 100000)
	     ;; tenths of microseconds between 1601-01-01 and 1970-01-01
	     116444736000000000)))
    (apply #'unibyte-string
           (mapcar (lambda (i)
                     (logand (ash tenths-of-us-since-jan-1-1601 (* i -8))
                             #xff))
                   (number-sequence 0 7)))))

(ert-deftest ntlm-time-to-timestamp ()
  ;; Verify poor man's bignums in implementation that can run on Emacs < 27.1.
  (let ((time '(24471 63910 412962 0)))
    (should (equal (ntlm--time-to-timestamp time)
                   (ntlm-tests--time-to-timestamp time))))
  (let ((time '(397431 65535 999999 999999)))
    (should (equal (ntlm--time-to-timestamp time)
                   (ntlm-tests--time-to-timestamp time)))))

(defvar ntlm-tests--username-oem "ntlm"
  "The username for NTLM authentication tests, in OEM string encoding.")
(defvar ntlm-tests--username-unicode
  (ntlm-ascii2unicode ntlm-tests--username-oem
		      (length ntlm-tests--username-oem))
  "The username for NTLM authentication tests, in Unicode string encoding.")

(defvar ntlm-tests--password "ntlm"
  "The password used for NTLM authentication tests.")

(defvar ntlm-tests--client-supports-unicode nil
  "Non-nil if client supports Unicode strings.
If client only supports OEM strings, nil.")

(defvar ntlm-tests--challenge nil "The global random challenge.")

(defun ntlm-server-build-type-2 ()
  "Return an NTLM Type 2 message as a string.
This string will be returned from the NTLM server to the NTLM client."
  (let ((target (if ntlm-tests--client-supports-unicode
		    (ntlm-ascii2unicode "DOMAIN" (length "DOMAIN"))
		  "DOMAIN"))
	(target-information ntlm-tests--password)
	;; Flag byte 1 flags.
	(_negotiate-unicode 1)
	(negotiate-oem 2)
	(request-target 4)
	;; Flag byte 2 flags.
	(negotiate-ntlm 2)
	(_negotiate-local-call 4)
	(_negotiate-always-sign 8)
	;; Flag byte 3 flags.
	(_target-type-domain 1)
	(_target-type-server 2)
	(target-type-share 4)
	(_negotiate-ntlm2-key 8)
	(negotiate-target-information 128)
	;; Flag byte 4 flags, unused.
	(_negotiate-128 32)
	(_negotiate-56 128))
    (concat
     ;; Signature.
     "NTLMSSP" (unibyte-string 0)
     ;; Type 2.
     (unibyte-string 2 0 0 0)
     ;; Target length
     (unibyte-string (length target) 0)
     ;; Target allocated space.
     (unibyte-string (length target) 0)
     ;; Target offset.
     (unibyte-string 48 0 0 0)
     ;; Flags.
     ;; Flag byte 1.
     ;; Tell the client that this test server only supports OEM
     ;; strings.  This test server will handle Unicode strings
     ;; anyway though.
     (unibyte-string (logior negotiate-oem request-target))
     ;; Flag byte 2.
     (unibyte-string negotiate-ntlm)
     ;; Flag byte 3.
     (unibyte-string (logior negotiate-target-information target-type-share))
     ;; Flag byte 4.	Not sure what 2 means here.
     (unibyte-string 2)
     ;; Challenge.  Set this to (unibyte-string 1 2 3 4 5 6 7 8)
     ;; instead of (ntlm-generate-nonce) to hold constant for
     ;; debugging.
     (setq ntlm-tests--challenge (ntlm-generate-nonce))
     ;; Context.
     (make-string 8 0)
     (unibyte-string (length target-information) 0)
     (unibyte-string (length target-information) 0)
     (unibyte-string 54 0 0 0)
     target
     target-information)))

(defun ntlm-server-hash (challenge blob username password)
  "Hash CHALLENGE, BLOB, USERNAME and PASSWORD for a Type 3 check."
  (hmac-md5 (concat challenge blob)
	    (hmac-md5 (concat
		       (upcase
			;; This calculation always uses
			;; Unicode username, even when the
			;; server only supports OEM strings.
			(ntlm-ascii2unicode username (length username))) "")
		      (cadr (ntlm-get-password-hashes password)))))

(defun ntlm-server-check-authorization (authorization-string)
  "Return t if AUTHORIZATION-STRING correctly authenticates the user."
  (let* ((binary (base64-decode-string
		  (caddr (split-string authorization-string " "))))
	 (_lm-response-length (md4-unpack-int16 (substring binary 12 14)))
	 (_lm-response-offset
	  (cdr (md4-unpack-int32 (substring binary 16 20))))
	 (ntlm-response-length (md4-unpack-int16 (substring binary 20 22)))
	 (ntlm-response-offset
	  (cdr (md4-unpack-int32 (substring binary 24 28))))
	 (ntlm-hash
	  (substring binary ntlm-response-offset (+ ntlm-response-offset 16)))
	 (username-length (md4-unpack-int16 (substring binary 36 38)))
	 (username-offset (cdr (md4-unpack-int32 (substring binary 40 44))))
	 (username (substring binary username-offset
			      (+ username-offset username-length))))
    (if (equal ntlm-response-length 24)
	(let* ((expected
		(ntlm-smb-owf-encrypt
		 (cadr (ntlm-get-password-hashes ntlm-tests--password))
		 ntlm-tests--challenge))
	       (received (substring binary ntlm-response-offset
				    (+ ntlm-response-offset
				       ntlm-response-length))))
	  (ntlm-tests-message "Got NTLMv1 response:")
	  (ntlm-tests-message "Expected hash:     ===%S===" expected)
	  (ntlm-tests-message "Got      hash:     ===%S===" received)
	  (ntlm-tests-message "Expected username: ===%S==="
			      ntlm-tests--username-oem)
	  (ntlm-tests-message "Got      username: ===%S===" username)
	  (and (or (equal username ntlm-tests--username-oem)
		   (equal username ntlm-tests--username-unicode))
	       (equal expected received)))
      (let* ((ntlm-response-blob
	      (substring binary (+ ntlm-response-offset 16)
			 (+ (+ ntlm-response-offset 16)
			    (- ntlm-response-length 16))))
	     (_ntlm-timestamp (substring ntlm-response-blob 8 16))
	     (_ntlm-nonce (substring ntlm-response-blob 16 24))
	     (_target-length (md4-unpack-int16 (substring binary 28 30)))
	     (_target-offset
	      (cdr (md4-unpack-int32 (substring binary 32 36))))
	     (_workstation-length (md4-unpack-int16 (substring binary 44 46)))
	     (_workstation-offset
	      (cdr (md4-unpack-int32 (substring binary 48 52)))))
	(cond
	 ;; This test server claims to only support OEM strings,
	 ;; but also checks Unicode strings.
	 ((or (equal username ntlm-tests--username-oem)
	      (equal username ntlm-tests--username-unicode))
	  (let* ((password ntlm-tests--password)
		 (ntlm-hash-from-type-3 (ntlm-server-hash
					 ntlm-tests--challenge
					 ntlm-response-blob
					 ;; Always -oem since
					 ;; `ntlm-server-hash'
					 ;; always converts it to
					 ;; Unicode.
					 ntlm-tests--username-oem
					 password)))
	    (ntlm-tests-message "Got NTLMv2 response:")
	    (ntlm-tests-message "Expected hash: ==%S==" ntlm-hash)
	    (ntlm-tests-message "Got      hash: ==%S==" ntlm-hash-from-type-3)
	    (ntlm-tests-message "Expected username: ===%S==="
				ntlm-tests--username-oem)
	    (ntlm-tests-message "      or username: ===%S==="
		     ntlm-tests--username-unicode)
	    (ntlm-tests-message "Got      username: ===%S===" username)
	    (equal ntlm-hash ntlm-hash-from-type-3)))
	 (t
	  nil))))))

(require 'eieio)
(require 'cl-lib)

;; Silence some byte-compiler warnings that occur when
;; web-server/web-server.el is not found.
(declare-function ws-send nil)
(declare-function ws-parse-request nil)
(declare-function ws-start nil)
(declare-function ws-stop-all nil)

(require 'web-server nil t)
(require 'url-http-ntlm nil t)

(defun ntlm-server-do-token (request _process)
  "Process an NTLM client's REQUEST.
PROCESS is unused."
  (with-slots (process headers) request
    (let* ((header-alist (cdr headers))
	   (authorization-header (assoc ':AUTHORIZATION header-alist))
	   (authorization-string (cdr authorization-header)))
      (if (and (stringp authorization-string)
	       (string-match "NTLM " authorization-string))
	  (let* ((challenge (substring authorization-string (match-end 0)))
		 (binary (base64-decode-string challenge))
		 (type (aref binary 8))
		 ;; Flag byte 1 flags.
		 (negotiate-unicode 1)
		 (negotiate-oem 2)
		 (flags-byte-1 (aref binary 12))
		 (client-supports-unicode
		  (not (zerop (logand flags-byte-1 negotiate-unicode))))
		 (client-supports-oem
		  (not (zerop (logand flags-byte-1 negotiate-oem))))
		 (connection-header (assoc ':CONNECTION header-alist))
		 (_keep-alive
		  (when connection-header (cdr connection-header)))
		 (response
		  (cl-case type
		    (1
		     ;; Return Type 2 message.
		     (when (and (not client-supports-unicode)
				(not client-supports-oem))
		       (warn (concat
			      "Weird client supports neither Unicode"
			      " nor OEM strings, using OEM.")))
		     (setq ntlm-tests--client-supports-unicode
			   client-supports-unicode)
		     (concat
		      "HTTP/1.1 401 Unauthorized\r\n"
		      "WWW-Authenticate: NTLM "
		      (base64-encode-string
		       (ntlm-server-build-type-2) t) "\r\n"
		      "WWW-Authenticate: Negotiate\r\n"
		      "WWW-Authenticate: Basic realm=\"domain\"\r\n"
		      "Content-Length: 0\r\n\r\n"))
		    (3
		     (if (ntlm-server-check-authorization
			  authorization-string)
			 "HTTP/1.1 200 OK\r\n\r\nAuthenticated.\r\n"
		       (progn
			 (if process
			     (set-process-filter process nil)
			   (error "Type 3 message found first?"))
			 (concat "HTTP/1.1 401 Unauthorized\r\n\r\n"
				 "Access Denied.\r\n")))))))
	    (if response
		(ws-send process response)
	      (when process
		(set-process-filter process nil)))
	    (when (equal type 3)
	      (set-process-filter process nil)
	      (process-send-eof process)))
	(progn
	  ;; Did not get NTLM anything.
	  (set-process-filter process nil)
	  (process-send-eof process)
	  (concat "HTTP/1.1 401 Unauthorized\r\n\r\n"
		  "Access Denied.\r\n"))))))

(defun ntlm-server-filter (process string)
  "Read from PROCESS a STRING and treat it as a request from an NTLM client."
  (let ((request (make-instance 'ws-request
				:process process :pending string)))
    (if (ws-parse-request request)
	(ntlm-server-do-token request process)
      (error "Failed to parse request"))))

(defun ntlm-server-handler (request)
  "Handle an HTTP REQUEST."
  (with-slots (process headers) request
    (let* ((header-alist (cdr headers))
	   (authorization-header (assoc ':AUTHORIZATION header-alist))
	   (connection-header (assoc ':CONNECTION header-alist))
	   (keep-alive (when connection-header (cdr connection-header)))
	   (response (concat
		      "HTTP/1.1 401 Unauthorized\r\n"
		      "WWW-Authenticate: Negotiate\r\n"
		      "WWW-Authenticate: NTLM\r\n"
		      "WWW-Authenticate: Basic realm=\"domain\"\r\n"
		      "Content-Length: 0\r\n\r\n")))
      (if (null authorization-header)
	  ;; Tell client to use NTLM.	 Firefox will create a new
	  ;; connection.
	  (progn
	    (process-send-string process response)
	    (process-send-eof process))
	(progn
	  (ntlm-server-do-token request nil)
	  (set-process-filter process #'ntlm-server-filter)
	  (if (equal (upcase keep-alive) "KEEP-ALIVE")
	      :keep-alive
	    (error "NTLM server expects keep-alive connection header")))))))

(defun ntlm-server-start ()
  "Start an NTLM server on port 8080 for testing."
  (ws-start 'ntlm-server-handler 8080))

(defun ntlm-server-stop ()
  "Stop the NTLM server."
  (ws-stop-all))

(defvar ntlm-tests--result-buffer nil "Final NTLM result buffer.")

(require 'url)

(defun ntlm-tests--url-retrieve-internal-around (original &rest arguments)
  "Save the result buffer from a `url-retrieve-internal' to a global variable.
ORIGINAL is the original `url-retrieve-internal' function and
ARGUMENTS are passed to it."
  (setq ntlm-tests--result-buffer (apply original arguments)))

(defun ntlm-tests--authenticate ()
  "Authenticate using credentials from the authinfo resource file."
  (setq ntlm-tests--result-buffer nil)
  (let ((auth-sources (list (ert-resource-file "authinfo")))
	(auth-source-do-cache nil)
	(auth-source-debug (when (getenv "NTLM_TESTS_VERBOSE") 'trivia)))
    (ntlm-tests-message "Using auth-sources: %S" auth-sources)
    (url-retrieve-synchronously "http://localhost:8080"))
  (sleep-for 0.1)
  (ntlm-tests-message "Results are in: %S" ntlm-tests--result-buffer)
  (with-current-buffer ntlm-tests--result-buffer
    (buffer-string)))

(defun ntlm-tests--start-server-authenticate-stop-server ()
  "Start an NTLM server, authenticate against it, then stop the server."
  (advice-add #'url-retrieve-internal
	      :around #'ntlm-tests--url-retrieve-internal-around)
  (ntlm-server-stop)
  (ntlm-server-start)
  (let ((result (ntlm-tests--authenticate)))
    (advice-remove #'url-retrieve-internal
		   #'ntlm-tests--url-retrieve-internal-around)
    (ntlm-server-stop)
    result))

(defvar ntlm-tests--successful-result
  (concat "HTTP/1.1 200 OK\n\nAuthenticated." (unibyte-string 13) "\n")
  "Expected result of successful NTLM authentication.")

(require 'find-func)
(defun ntlm-tests--ensure-ws-parse-ntlm-support ()
  "Ensure NTLM special-case in `ws-parse'."
  (let* ((hit (find-function-search-for-symbol
	       'ws-parse nil (locate-file "web-server.el" load-path)))
	 (buffer (car hit))
	 (position (cdr hit)))
    (with-current-buffer buffer
      (goto-char position)
      (search-forward-regexp
       ":NTLM" (save-excursion (forward-sexp) (point)) t))))

(require 'lisp-mnt)
(defvar ntlm-tests--dependencies-present
  (and (featurep 'url-http-ntlm)
       (version<= "2.0.4"
		  (lm-version (locate-file "url-http-ntlm.el" load-path)))
       (featurep 'web-server)
       (ntlm-tests--ensure-ws-parse-ntlm-support))
  "Non-nil if GNU ELPA test dependencies were loaded.")

(ert-deftest ntlm-authentication ()
  "Check ntlm.el's implementation of NTLM authentication over HTTP."
  (skip-unless ntlm-tests--dependencies-present)
  (should (equal (ntlm-tests--start-server-authenticate-stop-server)
		 ntlm-tests--successful-result)))

(ert-deftest ntlm-authentication-old-compatibility-level ()
  (skip-unless ntlm-tests--dependencies-present)
  (setq ntlm-compatibility-level 0)
  (should (equal (ntlm-tests--start-server-authenticate-stop-server)
		 ntlm-tests--successful-result)))

(provide 'ntlm-tests)

;;; ntlm-tests.el ends here