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)
This commit is contained in:
Thomas Fitzsimmons
parent
5977de581c
commit
32e790f251
4 changed files with 377 additions and 2 deletions
|
|
@ -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).
|
||||
|
|
|
|||
|
|
@ -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
|
||||
<https://hydra.nixos.org/jobset/gnu/emacs-trunk> (see
|
||||
|
|
|
|||
1
test/lisp/net/ntlm-resources/authinfo
Normal file
1
test/lisp/net/ntlm-resources/authinfo
Normal file
|
|
@ -0,0 +1 @@
|
|||
machine localhost port http user ntlm password ntlm
|
||||
|
|
@ -17,11 +17,26 @@
|
|||
;; 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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue