From 32e790f2514154c72927c414f43c3e277b1344ac Mon Sep 17 00:00:00 2001 From: Thomas Fitzsimmons Date: Thu, 18 Feb 2021 18:05:38 -0500 Subject: [PATCH] Implement NTLM server for ntlm.el testing * test/Makefile.in (GNU_ELPA_DIRECTORY, elpa_dependencies, elpa_els, elpa_opts): New variables. (EMACSOPT, ert_opts): Add elpa_opts. * test/README: Document GNU_ELPA_DIRECTORY make variable. * test/lisp/net/ntlm-tests.el: Fix checkdoc-reported issues. (ntlm-tests-message, ntlm-server-build-type-2, ntlm-server-hash) (ntlm-server-check-authorization, ntlm-server-do-token) (ntlm-server-filter, ntlm-server-handler, ntlm-server-start) (ntlm-server-stop, ntlm-tests--url-retrieve-internal-around) (ntlm-tests--authenticate) (ntlm-tests--start-server-authenticate-stop-server): New functions. (ntlm-tests--username-oem, ntlm-tests--username-unicode) (ntlm-tests--client-supports-unicode, ntlm-tests--challenge) (ntlm-tests--result-buffer, ntlm-tests--successful-result): New variables. (ntlm-authentication) (ntlm-authentication-old-compatibility-level): New tests. * test/lisp/net/ntlm-resources/authinfo: New file. (Bug#43566) --- test/Makefile.in | 13 +- test/README | 5 + test/lisp/net/ntlm-resources/authinfo | 1 + test/lisp/net/ntlm-tests.el | 360 ++++++++++++++++++++++++++ 4 files changed, 377 insertions(+), 2 deletions(-) create mode 100644 test/lisp/net/ntlm-resources/authinfo diff --git a/test/Makefile.in b/test/Makefile.in index f907602a622..ff228d1261e 100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@ -71,6 +71,15 @@ am__v_at_0 = @ am__v_at_1 = +# Load any GNU ELPA dependencies that are present, for optional tests. +GNU_ELPA_DIRECTORY ?= $(srcdir)/../../elpa +# Keep elpa_dependencies dependency-ordered. +elpa_dependencies = \ + url-http-ntlm/url-http-ntlm.el \ + web-server/web-server.el +elpa_els = $(addprefix $(GNU_ELPA_DIRECTORY)/packages/,$(elpa_dependencies)) +elpa_opts = $(foreach el,$(elpa_els),$(and $(wildcard $(el)),-L $(dir $(el)) -l $(el))) + # We never change directory before running Emacs, so a relative file # name is fine, and makes life easier. If we need to change # directory, we can use emacs --chdir. @@ -81,7 +90,7 @@ EMACS_EXTRAOPT= # Command line flags for Emacs. # Apparently MSYS bash would convert "-L :" to "-L ;" anyway, # but we might as well be explicit. -EMACSOPT = --no-init-file --no-site-file --no-site-lisp -L "$(SEPCHAR)$(srcdir)" $(EMACS_EXTRAOPT) +EMACSOPT = --no-init-file --no-site-file --no-site-lisp -L "$(SEPCHAR)$(srcdir)" $(elpa_opts) $(EMACS_EXTRAOPT) # Prevent any settings in the user environment causing problems. unexport EMACSDATA EMACSDOC EMACSPATH GREP_OPTIONS @@ -105,7 +114,7 @@ export TEST_LOAD_EL ?= \ $(if $(findstring $(MAKECMDGOALS), all check check-maybe),no,yes) # Additional settings for ert. -ert_opts = +ert_opts += $(elpa_opts) # Maximum length of lines in ert backtraces; nil for no limit. # (if empty, use the default ert-batch-backtrace-right-margin). diff --git a/test/README b/test/README index 5f3c10adbe1..877f77ab947 100644 --- a/test/README +++ b/test/README @@ -108,6 +108,11 @@ to a suitable value in order to overwrite the default value: env REMOTE_TEMPORARY_FILE_DIRECTORY=/ssh:host:/tmp make ... +Some optional tests require packages from GNU ELPA. By default +../../elpa will be checked for these packages. If GNU ELPA is checked +out somewhere else, use + + make GNU_ELPA_DIRECTORY=/path/to/elpa ... There are also continuous integration tests on (see diff --git a/test/lisp/net/ntlm-resources/authinfo b/test/lisp/net/ntlm-resources/authinfo new file mode 100644 index 00000000000..698391e9313 --- /dev/null +++ b/test/lisp/net/ntlm-resources/authinfo @@ -0,0 +1 @@ +machine localhost port http user ntlm password ntlm diff --git a/test/lisp/net/ntlm-tests.el b/test/lisp/net/ntlm-tests.el index 6408ac13349..0ed430afe68 100644 --- a/test/lisp/net/ntlm-tests.el +++ b/test/lisp/net/ntlm-tests.el @@ -17,11 +17,26 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see . +;;; 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 @@ -49,4 +64,349 @@ signed integer. TIME must be on the form (HIGH LOW USEC PSEC)." (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.") + +(defvar ntlm-tests--dependencies-present + (and (featurep 'url-http-ntlm) (featurep 'web-server)) + "Non-nil if GNU ELPA test dependencies were loaded.") + +(when (not ntlm-tests--dependencies-present) + (warn "Cannot find one or more GNU ELPA packages") + (when (not (featurep 'url-http-ntlm)) + (warn "Need url-http-ntlm/url-http-ntlm.el")) + (when (not (featurep 'web-server)) + (warn "Need web-server/web-server.el")) + (warn "Skipping NTLM authentication tests") + (warn "See GNU_ELPA_DIRECTORY in test/README")) + +(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 -- 2.39.2