diff options
Diffstat (limited to 'test/lisp/net/ntlm-tests.el')
| -rw-r--r-- | test/lisp/net/ntlm-tests.el | 427 |
1 files changed, 427 insertions, 0 deletions
diff --git a/test/lisp/net/ntlm-tests.el b/test/lisp/net/ntlm-tests.el new file mode 100644 index 00000000000..a02d97f19a8 --- /dev/null +++ b/test/lisp/net/ntlm-tests.el @@ -0,0 +1,427 @@ +;;; ntlm-tests.el --- tests for ntlm.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020-2022 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. +(eval-when-compile (cl-pushnew 'headers eieio--known-slot-names) + (cl-pushnew 'process eieio--known-slot-names)) +(declare-function ws-send nil) +(declare-function ws-parse-request nil) +(declare-function ws-start nil) +(declare-function ws-stop-all nil) + +(eval-and-compile + (push (expand-file-name "../elpa/packages/web-server/" source-directory) + load-path) + (require 'web-server nil t) + (push (expand-file-name "../elpa/packages/url-http-ntlm/" source-directory) + load-path) + (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 |