;; See the file LICENSE for the full license governing this code.
;;
;; A program to check for broken links in HTML documents.  It recursively
;; descends into locally referenced file documents, too.  It keeps a table
;; of visited documents, so it won't get into a loop.

;;;;TODO:
;; - need to find a way to check ftp/pri/acl/ag/index.html, because
;;   when I was checking franz.com, documents it referenced had bad links
;;   in them.

(in-package :user)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; debugging...

(defvar .break-before-processing-re.
    #+ignore (compile-re "(cg-ops|cg-vars)")
    nil)
(defvar .break-after-processing-re.
    #+ignore (compile-re "(cg-ops|cg-vars)")
    nil)
(defvar .debug-bookmark-re.
    #+ignore "nudge"
    nil)

;; ...debugging
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar *checklinks-version* "1.97")

(eval-when (compile)
  (when (and (boundp '*debug*) *debug*)
    (push :debug-checklinks-module *features*)))

(eval-when (compile eval load)
  (require :uri)
  (use-package :net.uri)
  (require :phtml (if* (probe-file "sys:code;phtml.fasl")
		     thenret
		     else "../xmlutils/phtml.fasl"))
  (require :aserve (if* (probe-file "sys:code;aserve.fasl")
		      thenret
		      else "../aserve/aserve.fasl")))

;; Some pretty intense string stuff going on here, so crank up the speed:
#-debug-checklinks-module
(declaim (optimize (speed 3)))
#+debug-checklinks-module
(declaim (optimize (speed 0) (safety 3) (debug 3)))

(defvar *timeout*
    #+debug-checklinks-module 300000
    #-debug-checklinks-module 30)

(defvar *default-http-protocol*
    ;; work around bugs in chunking.
    ;; change to :http/1.1 to see the bug.
    :http/1.1)
(defvar *default-headers*
    ;; The following is because some sites won't allow you to
    ;; connect unless it looks like you're coming in from a
    ;; browser.
    '(("User-Agent" . "Mozilla/5.0 (Windows NT 6.2; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/27.0.1453.94 Safari/537.36")))

(defvar *production-mode*
    #+debug-checklinks-module nil #-debug-checklinks-module t)

(defvar *verbose* 0)
(defvar *quiet* nil)

(defvar *check-all-links* nil
  "When given the -a command line argument, verify even http: links.")

(defvar *checklinks-usage*
    "Usage: checklinks [options] -r doc-root files-or-urls

Check files-or-urls for bad links, relative to the document root given
by doc-root.

Options:
-2                       during the orphan finding pass (see -O), ignore
                         non-HTML files
-A hosts                 only allow specific hosts to be checked
-D                       print debugging info - all by itself runs a
                         primitive top-level
-E hosts                 count as bad links URLs that reference these hosts
-L                       stay on the same host and port
                         good for sites which differ by port on the same
                         host
-O                       do not execute the pass to find orphans
-T                       trace net.aserve.client:do-http-request... be
                         prepared for a LOT of output!
-V Vfile                 output to Vfile the path of each file checked
-X dirs                  directories to ignore
-Y dirs                  directories to ignore only in the orphan finding pass
-Z uri                   turn debugging on when uri is seen
-a                       connect to remote sites to check that links exists
                         NOTE: this can dramatically slow operation
--bad-uris uris          Similar to -E, mark uris, if seen as bad
-c directory             the cgi-bin directory, for checking existence of
                         cgi scripts
--check-all-image-types  check all image types, otherwise, certain image
                         types are ignored.  See below.
--check-remote hosts     check that links to hosts are valid, but do
                         not further link check the pages of those hosts
-h hosts                 ignore these hosts (see also -a)
-i directory             the icons directory, for checking existence of
                         icon files
--ignore-uris urls       ignore references to these URLs
-l                       follow links on the current host only
-o orphans-reference     the file name argument is taken to be a list of
                         relative pathnames with respect to the document
                         root, and any file in this list which is not
                         visited during the link check will be reported as
                         an orphan
-p regexs                ignore (and do not follow) URLs that match
                         one or more regexs
-q                       operate quietly
--require-https          mark any links which use HTTP as bad
-s                       exit after checking a single page
-v                       operate verbosely
-x file                  exclude file from scan
-z uri                   like -Z, but break before and after processing
                         uri

All 'hosts' arguments can be a single host or a comma-separate list of
hosts.

All 'dirs' can be a directory or a comma-separated list of directories.

Here is the list of image types which are ignored,
unless '--check-all-image-types' is specified:
~@< ~@;~s~:@>
")

(defvar .status.)

(defvar *break-on-bad-links* nil)

(defvar *local-only* nil)
(defvar *local-only-port* nil)
(defvar *ignore-hosts* nil)
(defvar *ignore-uris* nil)
(defvar *bad-uris* nil)
(defvar *ignore-pattern* nil)
(defvar *allow-hosts* nil)
(defvar *error-on-hosts*
    ;; nil or a list of FQDNs.  If non-nil, then any URIs with these hosts
    ;; are immediate bad links.
    nil)
(defvar *check-remote*
    ;; nil or a list of FQDNs.  Links to these hosts are checked to be
    ;; valid, but they are not followed for further checking.
    nil)
(defvar *require-https*
    ;; if non-nil, then any link that uses http: is a bad link
    nil)
(defvar *debug-on-uri* nil)
(defvar *debug-and-break-on-uri* nil)
(defvar *orphans-reference* nil)
(defvar *link-counter*
    ;; This value aids in interactive debugging
    0)
(defvar *last-visited* nil)
(defvar *wordpress-mode* nil)

;; The profile of WP failures:
;; - they are somewhat rare
;; - the failures can be timeouts or 500 series server errors
;; - when they happen, they persist for a while, then magically work
;; So, allow a lot of retries and up the sleep value, which is multiplied
;; in the retry loop by the retry count.  The goal is to reduce the false
;; negatives to 0.
(defvar *retry-sleep*
    ;; the list of sleeps that happen when 404's occur
    '(3 5 7 9 15 20 30 50 60))

(defvar *total-retries* 0)
(defvar *successful-retries* 0)

(defvar *debug-mode* nil)

;; Used to determine if a URI has been processed already.
;; We used to use the URIs plist, but that has unintended consequences:
;; URIs with a query, that are the same document appear to be different, so
;; we can end up looking at the same page over and over again. The best
;; example of this is the new allegrograph.com.  For whatever reason,
;; Wordpress (WP) links back to the home page with "?p=1234" where the
;; number varies a lot.
;;
;; So, use a #'equal hash-table for the URI w/o the query.
(defvar *processed-uris* nil)

(eval-when (load eval) (require :tpl-debug))

(defmacro with-auto-zoom ((place &key (count 't) (all 't)
					       (exit 't) no-unwind)
				   &body body)
  "Generate a execution stack trace to PLACE, which can be a stream, `t' or
a pathname.  This macro is a wrapper for top-level :zoom command and is
intended to be used in application that want to report unexpected errors.

The COUNT and ALL keywords are passed to the :zoom command and are
documented with that command.

A non-nil value for EXIT cause the running application to terminate.  The
default value of EXIT is `t'.

A non-nil value for NO-UNWIND causes unwind-protects in stack frames above
the error to be ignored.  (This argument is simply passed to exit which
also accepts a NO-UNWIND keyword argument.)  NO-UNWIND is ignored if
EXIT is nil.  The default value of NO-UNWIND is nil (as it is for EXIT)."
  (let ((g-place (gensym))
	(g-count (gensym))
	(g-all (gensym))
	(g-exit (gensym))
	(g-no-unwind (gensym)))
    `(let ((,g-place ,place)
	   (,g-count ,count)
	   (,g-all ,all)
	   (,g-exit ,exit)
	   (,g-no-unwind ,no-unwind))
       (handler-bind
	   ((error (lambda (e)
		     (with-standard-io-syntax
		       (let ((*print-readably* nil)
			     (*print-miser-width* 40)
			     (*print-pretty* t)
			     (top-level:*zoom-print-circle* t)
			     (top-level:*zoom-print-level* nil)
			     (top-level:*zoom-print-length* nil))
			 (ignore-errors	;prevent recursion
			  (format *terminal-io* "~
~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%"
				  e))
			 (ignore-errors	;prevent recursion
			  (flet ((do-zoom (s)
				   (let ((*terminal-io* s)
					 (*standard-output* s))
				     (top-level:do-command "zoom"
				       :from-read-eval-print-loop nil
				       :count ,g-count :all ,g-all))))
			    (when (eq 't ,g-place)
			      (setq ,g-place *terminal-io*))
			    (if* (streamp ,g-place)
			       then (do-zoom ,g-place)
			       else (with-open-file (s ,g-place
						     :direction :output
						     :if-exists :supersede)
				      (do-zoom s)))))
			 (when ,g-exit
			   (exit 1 :no-unwind ,g-no-unwind)))))))
	 ,@body))))

(defvar *ignore-file-types*
    ;; Only used when --check-all-image-types is NOT given on the command
    ;; line.
    '("jpg" "png" "gif" "pdf" "hlp" "txt" "lsp" "Z" "gz" "zip" "el" "cl"
      "lisp" "idl" "cnt" "java" "hh" "cc" "C" "bat" "doc" "fasl" "rpm"
      "exe" "dmg" "bz2" "xml" "wav" "css" "ico" "rdf" "so" "dylib" "dll"))

(defun main ()
  (flet
      ((doit ()
	 (system:with-command-line-arguments
	     (
	      ("2" :short pass2-ignore-non-html)
	      ("A" :short allow-hosts :required)
	      ("D" :short debug-mode)
	      ("E" :short error-on-hosts :required)
	      ("L" :short local-only-port)
	      ("O" :short ignore-orphans)
	      ("T" :short debug-trace)
	      ("V" :short last-visited :required)
	      ("X" :short ignore-directories :required)
	      ("Y" :short pass2-ignore-directories :required)
	      ("Z" :short debug-on-uri :required)
	      ("a" :short check-all)
	      ("bad-uris" :long bad-uris :required-companion)
	      ("c" :short cgi-bin :required)
	      ("check-all-image-types" :long check-all-image-types)
	      ("check-remote" :long check-remote :required-companion)
	      ("h" :short ignore-hosts :required)
	      ("i" :short icons-dir :required)
	      ("ignore-uris" :long ignore-uris :required-companion)
	      ("l" :short local-only)
	      ("o" :short orphans-reference-file :required)
	      ("p" :short ignore-pattern :required :allow-multiple-options)
	      ("q" :short quiet)
	      ("r" :short doc-root :required)
	      ("require-https" :long require-https :required-companion)
	      ("s" :short single-file)
	      ("v" :short verbose :allow-multiple-options)
	      ("version" :long version)
	      ("wordpress" :long wordpress-mode)
	      ("x" :short ignore-files :required)
	      ("z" :short debug-and-break-on-uri :required)
	      )
	     (files
	      ;; cannot specify :usage here because we have extra ~
	      ;; directives in our version.
	      )
	   (format t "checklinks version ~a~%" *checklinks-version*)
	   (when version (exit 0))
	   (setq *quiet* quiet)
	   (setq *wordpress-mode* wordpress-mode)
	   (when cgi-bin (initialize-cgi-bin cgi-bin))
	   (when icons-dir (initialize-icons-dir icons-dir))
	   (when debug-mode
	     (setq *debug-mode* t)
	     (setq *production-mode* nil)
	     (setq *trace-print-length* nil)
	     (setq *trace-print-level* nil)
	     (trace check-links))
	   (when (or debug-on-uri debug-and-break-on-uri)
	     (setq *debug-on-uri*
	       (mapcar #'intern-uri
		       (delimited-string-to-list 
			(or debug-on-uri debug-and-break-on-uri)
			#\,)))
	     (setq *debug-and-break-on-uri* debug-and-break-on-uri)
	     (dolist (u *debug-on-uri*)
	       (format t "DEBUG ON: ~a~%" u)))
	   (when debug-trace 
	     (trace net.aserve.client:do-http-request))
	   (when allow-hosts
	     (setq allow-hosts
	       (delimited-string-to-list allow-hosts #\,)))
	   (when require-https
	     (setq require-https
	       (delimited-string-to-list require-https #\,)))
	   (when ignore-hosts
	     (setq ignore-hosts
	       (delimited-string-to-list ignore-hosts #\,)))
	   (when ignore-uris
	     (setq ignore-uris
	       (handler-case
		   (mapcar
		    #'safe-parse-uri
		    (delimited-string-to-list ignore-uris #\,))
		 (error (c)
		   (error "Error: parsing ~a into URIs: ~a"
			  ignore-uris c)))))
	   (when bad-uris
	     (setq bad-uris
	       (handler-case
		   (mapcar
		    #'safe-parse-uri
		    (delimited-string-to-list bad-uris #\,))
		 (error (c)
		   (error "Error: parsing ~a into URIs: ~a"
			  bad-uris c)))))
	   (when error-on-hosts
	     (setq error-on-hosts
	       (delimited-string-to-list error-on-hosts #\,)))
	   (when check-all-image-types
	     (setq *ignore-file-types* nil))
	   (when check-remote
	     (setq check-remote
	       (delimited-string-to-list check-remote #\,)))
	   (when ignore-pattern
	     (unless (consp ignore-pattern)
	       (setq ignore-pattern (list ignore-pattern)))
	     (setq ignore-pattern
	       (handler-case (mapcar #'compile-re ignore-pattern)
		 (error (c)
		   (error "Error: compiling regex ~a: ~a" ignore-pattern c)))))
	   (when last-visited
	     (setq *last-visited* (open last-visited :direction :output
					:if-exists :supersede
					:if-does-not-exist :create)))
	   (when orphans-reference-file
	     (with-open-file (s orphans-reference-file)
	       (let (line)
		 (setq *orphans-reference*
		   (make-hash-table :size 7001 :test #'equal))
		 (loop
		   (setq line (read-line s nil s))
		   (when (eq line s) (return))
		   (setf (gethash line *orphans-reference*)
		     t)))))
	   (when (null files)
	     (if* debug-mode
		then (break "hack away, dude...")
		else (format t *checklinks-usage* *ignore-file-types*)
		     (exit 0 :quiet t)))
	   (when (null doc-root)
	     (error "You must specify a document root."))
	   (when (and ignore-orphans (null *orphans-reference*))
	     (error "Orphans file (-o) not specified."))
	   (setq doc-root       (safe-parse-uri doc-root)
		 *link-counter* 0
		 .status.       0)
	   (let* ((ignore-files 
		   (when ignore-files
		     (delimited-string-to-list ignore-files #\,)))
		  (ignore-directories
		   (when ignore-directories
		     (delimited-string-to-list ignore-directories #\,)))
		  (pass2-ignore-directories
		   (when pass2-ignore-directories
		     (delimited-string-to-list pass2-ignore-directories #\,)))
		  (args `(:document-root ,doc-root
			  :local-only ,local-only
			  :local-only-port ,local-only-port
			  :allow-hosts ,allow-hosts
			  :find-orphans ,(if* *orphans-reference*
					    then t
					    else nil)
			  :ignore-files ,ignore-files
			  :ignore-pattern ,ignore-pattern
			  :ignore-uris ,ignore-uris
			  :bad-uris ,bad-uris
			  :error-on-hosts ,error-on-hosts
			  :check-remote ,check-remote
			  :require-https ,require-https
			  :ignore-directories ,ignore-directories
			  :pass2-ignore-directories ,pass2-ignore-directories
			  :ignore-hosts ,ignore-hosts
			  :verbose ,(or verbose 0)
			  :single-file ,single-file
			  :check-all ,check-all
			  :pass2 ,(when pass2-ignore-non-html
				    :ignore-non-html))))
	     (apply #'check-links files args))
	   (format t "~&~%Total documents checked: ~D~%" *link-counter*)
	   (when (> *successful-retries* 0)
	     (format t "Successful retries: ~D~%" *successful-retries*))
	   (when (> *total-retries* 0)
	     (format t "Total retries: ~D~%" *total-retries*))
	   (when *last-visited* (close *last-visited*))
	   (exit .status. :quiet t))))

    (if* *production-mode*
       then (handler-case (doit)
	      (excl::asynchronous-operating-system-signal (c)
		(handle-sigint c))
	      (error (c)
		(format t "An error occurred: ~a~%" c)
		(exit 1 :quiet t)))
       else (with-auto-zoom (t)
	      (doit)))))

(defparameter *check-later-uris*
    ;; We delay checking URLs we find in documents until the end of the
    ;; document, to curtail recursion a little.  It's probably easier on
    ;; the gc, too, since we can drop the data structures associated with a
    ;; document after processing it.
    nil)

(declaim (special .printed-file-name. .uri. .base. .referer.))

(defvar .document-root-pathname. nil)
(defvar .document-root. nil)

(defvar .null-uri. nil)

(defvar .debug-output. "checklinks.debug")

(defun .debug (n fs &rest args)
  ;; Send a complete record to .debug-output. if it is a stream, as well as
  ;; the matching debug output, considering *verbose*, to stdout.
  ;;
  ;; Returns T so it can be used in logical expressions.
  (when (> *verbose* n)          (apply #'format t fs args))
  (when (streamp .debug-output.) (apply #'format .debug-output. fs args))
  t)

(defvar *uri-clos-hackery* nil)

;; non-nil when checking links over an HTTP connection.
;; nil when checking local files.
(defvar *client-mode* nil)

(defvar *index-files* '("index.html" "index.htm" "index.lhtml"
			"index.md"))

(defun check-links (files-or-urls
		    &key document-root
			 single-file
			 ignore-files
			 ignore-directories
			 pass2-ignore-directories
			 ((:local-only *local-only*) nil)
			 ((:local-only-port *local-only-port*) nil)
			 ((:ignore-hosts *ignore-hosts*) nil)
			 ((:ignore-pattern *ignore-pattern*) nil)
			 ((:ignore-uris *ignore-uris*) nil)
			 ((:bad-uris *bad-uris*) nil)
			 ((:allow-hosts *allow-hosts*) nil)
			 ((:error-on-hosts *error-on-hosts*) nil)
			 ((:check-remote *check-remote*) nil)
			 ((:require-https *require-https*) nil)
			 (client-mode (when document-root
					(uri-scheme document-root)))
			 (find-orphans (not client-mode))
			 ((:check-all *check-all-links*) nil)
			 ((:verbose *verbose*) 0)
			 (pass2
			  ;; valid values: :ignore-non-html and nil
			  nil)
		    &aux (*global-gc-behavior* :auto)
			 (*print-pretty* nil)
			 (net.uri::*strict-parse* nil)
			 (*uri-clos-hackery* nil)
			 (*processed-uris* nil)
			 (pass2-result '()))
  (declare (ignore pass2))
  
  ;; Check the HTML links in FILE.  Recursively descend into locally
  ;; referenced file documents, and check links there, too.  Keep a table
  ;; of visited documents, so we won't get into a loop.  The :IGNORE
  ;; argument specifies bad links that we should ignore, and must be a list
  ;; of filenames without path elements.  The :DIRECTORY argument specifies
  ;; a web root that should additionally be checked: currently, files that
  ;; are not pointed to by any HTML document are highlighted.
  
  (assert (uri-p document-root))

  (setq *client-mode* client-mode)

  (when *debug-mode*
    (setq .debug-output.
      (open .debug-output. :direction :output :if-exists :supersede)))

  (setq *check-later-uris* nil)
  (setq .status. 0)

  (when *debug-mode*
    (format t "*client-mode* = ~s~%" *client-mode*)
    (format t "*local-only* = ~s~%" *local-only*)
    (format t "*local-only-port* = ~s~%" *local-only-port*)
    (format t "*ignore-hosts* = ~s~%" *ignore-hosts*)
    (format t "*ignore-pattern* = ~s~%" *ignore-pattern*)
    (format t "*ignore-uris* = ~s~%" *ignore-uris*)
    (format t "*ignore-file-types* = ~s~%" *ignore-file-types*)
    (format t "*bad-uris* = ~s~%" *bad-uris*)
    (format t "*allow-hosts* = ~s~%" *allow-hosts*)
    (format t "*error-on-hosts* = ~s~%" *error-on-hosts*)
    (format t "*check-remote* = ~s~%" *check-remote*)
    (format t "*require-https* = ~s~%" *require-https*)
    (format t "*check-all-links* = ~s~%" *check-all-links*))

  (unintern-uri t)

  (setq .document-root. document-root)
  (setq .document-root-pathname.
    (pathname (or (uri-path document-root) "/")))

  ;; Used to find URIs which are solely bookmark references, like
  ;; "#foo".
  (setq .null-uri. (parse-uri ""))

  (setq ignore-directories
    (mapcar #'(lambda (s) (merge-uris s document-root))
	    ignore-directories))
  (setq pass2-ignore-directories
    (mapcar #'(lambda (s) (merge-uris s document-root))
	    pass2-ignore-directories))
  
  (setq *uri-clos-hackery* t)
  
  (dolist (file-or-uri files-or-urls)
    (check-url (intern-uri file-or-uri)
	       (list .document-root. 0)
	       :ignore-files ignore-files
	       :recurse (not single-file)
	       :ignore-directories ignore-directories))
  
  ;; This is our last chance to make sure all bookmarks are checked.
  ;; I do not understand why this is necessary, but it gets triggered, so
  ;; do not remove it!
  (do-all-uris (xuri)
    (when (bookmark-references xuri)
      (.debug 0 "unchecked bookmarks for ~a~%" xuri)
      (let ((.printed-file-name. nil)
	    (.base. xuri)
	    (.uri. xuri))
	(check-pending-bookmarks xuri))))

  (when (streamp .debug-output.) (close .debug-output.))
  
  (when (or (/= 0 .status.) (not *quiet*))
    (format t "~&~%Found ~d bad links.~%" .status.))

  (when (and find-orphans (not single-file))
    (format t "~&~%~
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;~%")
    (format t ";; Looking for files not referenced anywhere...~%")
    (maphash
     (lambda (filespec ignore)
       (declare (ignore ignore))
       (let* ((uri (merge-uris (safe-parse-uri filespec) .document-root.))
	      (is-index 
	       (dolist (index *index-files*)
		 (when (string= index (file-namestring filespec))
		   (return t))))
	      (uri2
	       (when is-index
		 (merge-uris (safe-parse-uri (path-namestring filespec))
			     .document-root.))))
	 (when (or (and (not is-index)
			(not (visited-uri-p uri)))
		   (and is-index
			(not (visited-uri-p uri))
			(not (visited-uri-p uri2))))
	   (push filespec pass2-result))))
     *orphans-reference*)
    
    (dolist (result (sort pass2-result #'string-lessp))
      (format t "~a~%" result)))

  .status.)

(defun ignore-uri-p (uri &key check-all-links)
  ;; Return T if URI should be ignored, due to values of various command
  ;; line arguments, nil otherwise.
  (when (and *ignore-uris*
	     (member uri *ignore-uris* :test #'uri-equal)
	     (.debug 10 "ignore-uri-p YES: on *ignored-uris*: ~a~%" uri))
    (return-from ignore-uri-p t))
  
  (when (and *error-on-hosts*
	     (member (uri-host uri) *error-on-hosts* :test #'equalp))
    (.debug 10 "ignore-uri-p YES: disallowed domain: ~a~%" uri)
    (setf (getf (uri-plist uri) :visited) nil)
    (note-bad-link nil "Bad link (disallowed domain): ~a" (full-uri uri))
    (return-from ignore-uri-p t))
  
  (when (and *bad-uris* (member uri *bad-uris*))
    (.debug 10 "ignore-uri-p YES: disallowed uri: ~a~%" uri)
    (setf (getf (uri-plist uri) :visited) nil)
    (note-bad-link nil "Bad link (disallowed uri): ~a" (full-uri uri))
    (return-from ignore-uri-p t))
  
  (when (and *require-https*
	     (uri-scheme uri)
	     (eq :http (uri-scheme uri))
	     (uri-host uri)
	     (member (uri-host uri) *require-https* :test #'equalp))
    (.debug 10 "ignore-uri-p YES: HTTP disallowed for host: ~a~%" uri)
    (setf (getf (uri-plist uri) :visited) nil)
    (note-bad-link nil "Bad link (HTTP not allowed): ~a" (full-uri uri))
    (return-from ignore-uri-p t))
  
  (let ((path (uri-path uri)))
    (when (and *ignore-pattern* path)
      (dolist (re *ignore-pattern*)
	(when (match-re re path :return nil)
	  (.debug 10 "ignore-uri-p YES: ignored pattern: ~a~%" uri)
	  (return-from ignore-uri-p t)))))
  
  (when (and *ignore-hosts*
	     (member (uri-host uri) *ignore-hosts* :test #'equalp))
    (.debug 10 "ignore-uri-p YES: ignored host: ~a~%" uri)
    (return-from ignore-uri-p t))
  
  (when (and *allow-hosts*
	     (uri-host uri)
	     (not (member (uri-host uri) *check-remote* :test #'equalp))
	     (not (member (uri-host uri) *allow-hosts* :test #'equalp)))
    (.debug 10 "ignore-uri-p YES: not allowed host: ~a~%" uri)
    (return-from ignore-uri-p t))

  (when (and (not *client-mode*)
	     (not check-all-links)
	     (not *check-all-links*))
    (.debug 10 "ignore-uri-p YES: !client mode && !check all links: ~a~%" uri)
    (return-from ignore-uri-p t))

  ;; do NOT ignore:
  (.debug 10 "ignore-uri-p NO: ~a~%" uri)
  nil)

(defun check-html-for-uri-p (uri)
  ;; Return T if URI's HTML should be checked, nil otherwise.
  ;; If nil is returned, then the URI might be checked for existence.
  (when (and
	 ;; client mode and there is a host in the URI
	 *client-mode*
	 (uri-host uri)
	 
	 ;; either
	 ;; - not checking remote sites, or
	 ;; - we are and the host is not in the list *check-remote*
	 (or (null *check-remote*)
	     (not (member (uri-host uri) *check-remote*
			  :test #'equalp)))
	 
	 ;; We are not in local mode AND the URI's scheme is not HTTP/HTTPS.
;;;; I don't understand this... First, I can't find any uses of this
;;;; program with -l, so (not *local-only*) is always true.  Second, the
;;;; (not (http-p uri)) is really just a check for a scheme in uri, and the
;;;; clause would be true for local files.  So, this entire clause boils
;;;; down to "following links on local host and checking local file
;;;; directly" which really doesn't make any sense to me.
;;;;
;;;; For now, disable it, so -L *local-only-port* works.
	 #+ignore
	 (and (not *local-only*) (not (http-p uri)))
	 
	 (or
	  ;; We are in local mode, have a URI host and host isn't local to
	  ;; the domain of our document root
	  (and *local-only*
	       (uri-host uri)
	       (not (local-domain-p (uri-host uri)
				    (uri-host .document-root.))))

	  (and *local-only-port*
	       (or
		(not (equalp (uri-host uri) (uri-host .document-root.)))
		(not (equalp (uri-port uri) (uri-port .document-root.)))))))
    (.debug 10 "check-html-for-uri-p NO: ~a~%" uri)
    (return-from check-html-for-uri-p nil))

  (.debug 10 "check-html-for-uri-p YES: ~a~%" uri)
  ;; DO check the HTML
  t)

(defun local-domain-p (host ref)
  (or (equalp host ref)
;;;;TODO: parameterize this horrible hack:
      (match-re "(nfsforwindows|allegrograph|franz)\\.com$"
		host :return nil)))

(defun http-p (uri)
  (member (uri-scheme uri) '(:http :https) :test #'eq))

(defun check-url (uri referer
		  &key ignore-files
		       ignore-directories
		       (recurse t)
		  &aux .uri. .base. .printed-file-name. current-file
		       (old-verbose *verbose*)
		       debug-on-uri-active)
  (tagbody
   top
    (when (and *debug-on-uri*
	       (member uri *debug-on-uri* :test #'uri-equal))
      (setq old-verbose *verbose*)
      (setq *verbose* 99)
      (setq debug-on-uri-active t)
      (when *debug-and-break-on-uri* (break "processing ~a" uri))
      )

    (.debug 10 ".uri. = ~s~%" uri)
    (.debug 10 ".base. = ~s~%" uri)
    (setq .uri. uri)
    (setq .base. uri)
    (setq current-file (my-uri-to-pathname uri))
    (setq .printed-file-name. nil)
    (setq .referer. referer)

    (if* (processed-uri-p uri)
       then (go next)
       else (setf (processed-uri-p uri) t))

    ;; DO NOT REMOVE THIS (it was once before.  Grrrrrr.)
    (note-visited-uri uri)
    
    (when (and ignore-files
	       (member (file-namestring current-file) ignore-files
		       :test #'equalp :key #'namestring))
      (go next))

    (when (and ignore-directories
	       (dolist (dir ignore-directories nil)
		 (when (excl::subdirectoryp current-file (uri-path dir))
		   (return t))))
      (go next))

    (when (and (pathname-type current-file)
	       (member (pathname-type current-file) *ignore-file-types*
		       :test #'string-equal))
      (if* *client-mode*
	 then (or (ignore-uri-p uri)
;;;;TODO: crikey, I don't think this should be here, but I need to think
;;;;      about where it should be.
		  (check-remote-uri nil uri .document-root.))
	      (go next)
	 else (if* (probe-file current-file)
		 then (go next)
		 else (error "impossible[1]"))))

    (incf *link-counter*)
    
    ;; the @ prefix it so the URI is easy to find in the output
    (.debug 0 "@~a~%" (enough-uri uri .document-root.))

    (if* *client-mode*
       then (multiple-value-bind (body code headers result-uri)
		(http-get uri :head)
		
	      (when (eq :timed-out body) (go next))

	      (when result-uri
		(when (not (string= (uri-host uri) (uri-host result-uri)))
		  ;; URI redirected to a new domain.
		  (.debug 0 "@@redirect: ~a => ~a~%" uri result-uri)
		  (go next))
	      
		(when (and (not (uri-equal uri result-uri))
			   ;; ignore HTTP -> HTTPS
			   (uri-diff uri result-uri :ignore-scheme t))
		  ;; The URI we visited was redirected, so update our
		  ;; accounting state:
		
		  (.debug 0 "@@~a to ~a~%" uri result-uri)
		
		  (setq uri result-uri)
		  (setq .uri. uri)
		  (setq .base. uri)
		  ;; ignore current-file because it's unused from here
		
		  (if* (processed-uri-p uri)
		     then (go next)
		     else (setf (processed-uri-p uri) t))

		  (note-visited-uri uri)))
		
	      (let ((content-type
		     (cdr (assoc :content-type headers
				 :test #'eq))))
		(if* (and (eql 200 code)
			  ;; Just check that the content type
			  ;; starts with text/html.  There might
			  ;; be other junk at the end.
			  (prefixp "text/html" content-type))
		   then ;; now, get the body and check it
			(multiple-value-bind (body code)
			    (http-get uri)
			  (if* (eq :timed-out body)
			     then body
			     else (when (not (eql 200 code))
				    (error "~
expected code 200, got ~a." code))
				  (with-input-from-string (s body)
				    (check-html
				     s uri
				     :ignore-files ignore-files
				     :ignore-directories
				     ignore-directories))))
		 elseif (not (eql 200 code))
		   then (note-bad-link
			 nil "Bad link[1]: ~a referenced from ~a"
			 (full-uri uri)
			 (car referer))
		 elseif (or (equal "text/plain" content-type)
			    (equal "text/css" content-type)
			    (equal "application/octet-stream"
				   content-type)
			    (match-re
			     (load-time-value (compile-re "^image/"))
			     content-type))
		   thenret ;; don't check
		   else nil)))
       else (when (not (file-directory-p current-file))
	      (with-open-file (s current-file :direction :input)
		(check-html s uri
			    :ignore-files ignore-files
			    :ignore-directories ignore-directories))))
  
   next
    
    ;; We've just finished processing the given URI, so now is the time to
    ;; check any pending bookmark references we have to it.
    ;;
    ;; All the bookmarks that will ever be defined are now defined.
    ;; We now check the bookmark references we saw before we processed
    ;; this URI.
    (setf (bookmarks-defined-for-uri-p uri) t)

    (check-pending-bookmarks uri :ignore-directories ignore-directories)
    
    ;; Now check all pending bookmark references
    (do-all-uris (xuri)
      (when (bookmarks-defined-for-uri-p xuri)
	(check-pending-bookmarks
	 xuri :ignore-directories ignore-directories)))
    
    (when debug-on-uri-active
      (setq *verbose* old-verbose)
      (setq debug-on-uri-active nil)
      (when *debug-and-break-on-uri* (break "exit processing ~a" uri)))

    (when (and recurse *check-later-uris*)
      (let (temp)
	(while (setq temp (pop *check-later-uris*))
	  (when (not (processed-uri-p (first temp)))
	    (setq uri (first temp))
	    (setq referer (second temp))
	    (go top)))))
    
    ;; fall through...
    ))

(eval-when (compile)
  (when (find-symbol (symbol-name :uri-parse-error) (find-package :net.uri))
    (pushnew :has-uri-parse-error *features*)))

(eval-when (compile eval)
(defmacro parse-protect (position &rest form)
  `(flet ((doit () ,@form))
     (if* *production-mode*
	then (handler-case (doit)
	       (excl::asynchronous-operating-system-signal (c)
		 (handle-sigint c))
	       #+has-uri-parse-error
	       (uri-parse-error (c)
		 (cond
		  ;; sa3065: archive.org URLs are not valid, according to
		  ;; the URI spec, so we handle then specially and just
		  ;; ignore them:
		  ((match-re "web\\.archive\\.org/" (uri-parse-error-string c))
		   )
		  (t
		   (note-bad-link ,position "problem parsing uri: ~a." c))))
	       (parse-error (c)
		 (note-bad-link ,position "problem parsing uri: ~a." c)))
	else (doit))))
)

(defun clean-href (string)
  ;; clean up the URL.  The HTML is never clean and sometimes
  ;; not under our control (looking at your Wordpress).
  (let ((sans-spaces
	 (string-trim '(#\space #\newline #\return) string)))
    (if* *wordpress-mode*
       then ;; I believe it's a bug in allegrograph.com's WP HTML
	    ;; generation (done in PHP) that outputs this sequence, but
	    ;; since browsers seem OK with it, it seems far easier to hack
	    ;; it here rather than get the people that did the PHP work to
	    ;; fix the problem.  I found references via web searched that
	    ;; seemed to indicate this was allowed (unclear, but it might
	    ;; be).
	    (replace-re sans-spaces
			(load-time-value (compile-re "&#038;"))
			"&")
       else sans-spaces)))

(defun check-html (s myuri
		   &key ignore-files ignore-directories
		   &aux token type position attributes
			(in-script nil)
			(tokenbuf (net.html.parser::get-tokenbuf))
			(checklist '())
			temp)
  (.debug 10 "check-html: ~a~%" myuri)
  (when (and .break-before-processing-re.
	     (match-re .break-before-processing-re.
		       (namestring (my-uri-to-pathname myuri))
		       :return nil))
    (break "just about to process URI ~s" myuri))
  (loop
    (tagbody
      (setq position (file-position s))
      (multiple-value-setq (token type)
	(net.html.parser::next-token s t nil nil tokenbuf nil))
      (when (eq :eof type) (return))
      
      (when (or (eq :script token)
		(and (consp token)
		     (eq :script (car token))))
	(if* (eq :end-tag type)
	   then (setq in-script nil)
	 elseif (eq :start-tag type)
	   then (setq in-script t)
	   else (error "next-token, bad values: ~s ~s" token type)))
      
      (when in-script (go :next))
      
      (when (or (stringp token) (symbolp token)) (go :next))
      (when (not (consp token)) (error "read token: ~s" token))
      (setq attributes (cdr token))
      (setq token (car token))
      
      ;;#+ignore ;; too verbose, wait until needed
      (.debug 10 "token=~s, attr=~s~%" token attributes)

      (let ((bookmark (second (member :id attributes :test #'eq))))
        (when bookmark
	  (.debug 10 "bookmark(id): ~a; myuri=~a~%" bookmark myuri)
	  (note-bookmark-definition bookmark)))
      
      (case token
	(:base
	 (let ((href (second (member :href attributes :test #'eq))))
	   (when href
	     (setq href (clean-href href))
	     (setq .base. (safe-parse-uri href)))))
	
	((:overlay :fig :bgsound)
	 (check-image token attributes position :src (list myuri position) t))
	
	(:img
	 (check-image token attributes position :src (list myuri position) t)
	 (check-image token attributes position :lowsrc (list myuri position))
	 (check-image token attributes position :dynsrc (list myuri position)))

        ((:a :area :frame)
	 (parse-protect
	  position
	  (let ((href (second
		       (member (if* (eq :frame token)
				  then :src
				  else :href)
			       attributes
			       :test #'eq)))
		(bookmark (second (member :name attributes :test #'eq))))
	    (when (and href
		       (setq href (clean-href href))
		       (setq temp
			 ;; make sure the URI is parsable
			 (ignore-errors (safe-parse-uri href))))
	      ;; HREF is a reference to a URL.  There are two cases in the
	      ;; COND below, reference to
	      ;; - another document
	      ;; - a bookmark (defined by :name)
	      (.debug 10 "**raw href: ~s~%" temp)
	      (let*((unmerged-uri temp)
		    (merged-uri nil))
		(cond
		 ((uri-equal unmerged-uri .null-uri.)
		  ;; We have only a reference to a bookmark.  Ignore it,
		  ;; since the INITIALIZE-INSTANCE :after method for URIs
		  ;; will note the reference.
		  )
		 (t
		  (.debug 10 "- unmerged-uri: ~s~%" unmerged-uri)
		  ;;(.debug 10 "  - plist: ~s~%" (uri-plist unmerged-uri))
		  
		  ;; The URI we use to access the resource (i.e., check
		  ;; that it is valid).
		  (setq merged-uri
		    (or
		     ;; If it is malformed HTML, we might get an error
		     ;; merging.
		     (ignore-errors (merge-uris unmerged-uri .base.))
		     (note-bad-link position
				    "Bogus uri:~{ ~a~}"
				    ;; make it a list, to fool
				    ;; note-bad-link, which does something
				    ;; special of the first format argument
				    ;; is a uri...
				    (list (full-uri unmerged-uri)))))
		  
		  (when merged-uri
		    ;; MERGED-URI is a non-null URI, and while it might be a
		    ;; reference to the document we are processing, it might
		    ;; not be.  There may or may not be a bookmark reference.
		    (.debug 10 "**merged-uri: ~s~%" merged-uri)
		    ;;(.debug 10 "  - plist: ~s~%" (uri-plist merged-uri))

		    ;; MERGE-URIS doesn't touch the plist, where the
		    ;; fragment and query live, so we have to merge/copy
		    ;; them manually.
		    (copy-plist-values unmerged-uri merged-uri)

		    (if* (or *client-mode*
			     (uri-scheme unmerged-uri))
		       then ;; Something to be checked via HTTP
			    (.debug 2 "Queued: ~a~%" merged-uri)
			    (push ;; position uri referrer
			     (list position merged-uri (list myuri position))
			     checklist)
		       else (.debug 10 "- check-filespec: ~s~%" merged-uri)
			    (if* (not (check-filespec merged-uri
						      (list myuri position)
						      :ignore-files ignore-files
						      :ignore-directories
						      ignore-directories))
			       then (note-bad-link
				     position
				     "Broken link[1]: ~a referenced from ~a"
				     (full-uri merged-uri)
				     myuri)
			       else (note-link merged-uri
					       (list myuri position)))))))))
	    (when bookmark
	      (.debug 10 "bookmark: ~s~%" bookmark)
	      (note-bookmark-definition bookmark)))))

	(:link
	 (check-image token attributes position :href (list myuri position)))
	
	((:body :table)
	 (check-image token attributes position
		      :background (list myuri position))))
     :next))
  
;;;;TODO: I don't think this should be here, but I don't have time to
;;;;      figure out where it should.
  (dolist (item checklist)
    (destructuring-bind (pos u referer)
	;; position uri referer
	item
      (if* (or (not (http-p u))
	       (visited-uri-p u)
	       (ignore-uri-p u))
	 thenret ;; nothing to do!
       elseif (check-html-for-uri-p u)
	 then ;; put it on the queue to check
	      (note-link u referer)
	 else ;; just make sure the URI exists
	      (check-remote-uri pos u referer))))

  (when (and .break-after-processing-re.
	     (match-re .break-after-processing-re.
		       (namestring (my-uri-to-pathname myuri))
		       :return nil))
    (break "finished processing URI ~s" myuri)))

(defun check-image (token attributes position key referer &optional must-exist)
  (declare (ignore token))
  (parse-protect
   position
   (let ((value (second (member key attributes :test #'eq))))
     (when (and value (not (match-re "^data:image/" value)))
       (if* (and must-exist (null value))
	  then #+ignore
	       (note-bad-link position "~a tag with no ~s (attributes: ~s)"
			      token key attributes)
	       ;; Do nothing, since it's likely this condition is legal
	       nil
	elseif value
	  then (check-image-url (merge-uris value .base.) position referer))))))

(defun check-image-url (uri position referer)
  (when (not (ignore-uri-p uri))
    (if* *client-mode*
       then (check-remote-uri position uri referer)
       else (let ((p (my-uri-to-pathname uri)))
	      (note-visited-uri uri)
	      (when (not (probe-file p))
		(note-bad-link position "Broken link[2]: ~a"
			       (full-uri uri)))))))

(defun check-filespec (uri referer &key ignore-files ignore-directories)
  (if* (cgi-script-p uri)
     then (cgi-script-exists-p uri)
   elseif (icons-file-p uri)
     then (icons-file-exists-p uri referer)
     else (let ((p (my-uri-to-pathname uri)))
	    (or (and ignore-files
		     (member (file-namestring p) ignore-files
			     :test #'equalp :key #'namestring))
		(and ignore-directories
		     (dolist (dir ignore-directories nil)
		       (when (excl::subdirectoryp p (uri-path dir))
			 (return t))))
		(probe-file p)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utility functions

(defun my-uri-to-pathname (uri)
  (if* *client-mode*
     then (pathname (or (uri-path (merge-uris uri .document-root.))
			"/"))
     else ;; If uri is relative, just return a pathname of it.
	  ;; If uri is absolute, then return a pathname relative to
	  ;; document-root.
	  (let* ((s (uri-path uri))
		 (path (uri-parsed-path uri)))
	    (assert (or (consp path) (null path)))
	    (if* (null path)
	       then "/"
	     elseif (eq :absolute (car path))
	       then ;; absolute
		    (concat-pathnames .document-root-pathname. s)
	       else ;; (eq :relative (car path))
		    (namestring s)))))

;; the following two are used to calculate orphans  

(defun note-visited-uri (uri)
  (.debug 10 "note visited: ~a~%" uri)
  (setf (getf (uri-plist uri) :visited) t))

(defun visited-uri-p (uri)
  (getf (uri-plist uri) :visited))

(defun note-link (uri referer)
  ;; Put URI on a queue for later processing.
  
;;;;TODO: these tests shouldn't be here
  (when (or (and (not *client-mode*)
		 (uri-scheme uri))
	    (and *client-mode*
		 (or (null *allow-hosts*)
		     (not (member (uri-host uri) *allow-hosts*
				  :test #'equalp)))
		 (not (equalp (uri-host uri) (uri-host .document-root.)))))
    #+ignore ;; too verbose
    (comment nil "Ignoring URL to other host: ~a" uri)
    (return-from note-link))

  (when (and (cgi-script-p uri) (not *client-mode*))
    (when (not (cgi-script-exists-p uri))
      (note-bad-link nil "CGI script does not exist: ~a" (full-uri uri)))
    (return-from note-link))

  (when (icons-file-p uri)
    (when (not (icons-file-exists-p uri referer))
      (note-bad-link nil "icons file does not exist: ~a" (full-uri uri)))
    (return-from note-link))

  (when (not (excl::subdirectoryp (my-uri-to-pathname uri)
				  .document-root-pathname.))
    (comment nil "Ignoring file outside document root: ~a" uri)
    (return-from note-link))

  (push (list uri referer) *check-later-uris*))

(defun maybe-init-processed-uris-hash-table ()
  (when (not *processed-uris*)
    (setq *processed-uris*
      (make-hash-table :size 777 :test #'eq))))

(defun uri-equal (uri1 uri2)
  ;; Return true if URI1 and URI2 are the same, sans query and fragment.
  (assert (and uri1 uri2))
  (when (not (eq (uri-scheme uri1) (uri-scheme uri2)))
    (return-from uri-equal nil))
  (let ((default-port (case (uri-scheme uri1)
			(:http 80)
			(:https 443)
			(:ftp 21)
			(:telnet 23))))
    (and (equalp (uri-host uri1) (uri-host uri2))
	 (equalp (uri-userinfo uri1) (uri-userinfo uri2))
	 (eql (or (uri-port uri1) default-port)
	      (or (uri-port uri2) default-port))
	 (string= (uri-path uri1) (uri-path uri2))
	 ;; Ignore query and fragment
	 )))

(defun uri-diff (uri1 uri2 &key ignore-scheme)
  ;; Return a list of difference between the two URIs, ignoring
  ;; query and fragment.  If there is a single differnce, return the
  ;; keyword for that difference.
  ;;
  ;; The keywords are :path, :port, :userinfo, :host and :scheme.
  ;;
  ;; A path of nil or / is considered the same.  Ignore trailing slashes,
  ;; too.
  ;;
  (or (and uri1 uri2) (error "uri-diff: both arguments must be URIs."))
  (let ((res '())
	(p1 (or (uri-path uri1) "/"))
	(p2 (or (uri-path uri2) "/"))
	len)
    (or (string= p1 p2)
	(and (= 1 (- (setq len (length p1))
		     (length p2)))
	     (char= #\/ (elt p1 (1- len))))
	(and (= 1 (- (setq len (length p2))
		     (length p1)))
	     (char= #\/ (elt p2 (1- len))))
	(push :path res))
    (or (eql (uri-port uri1) (uri-port uri2))
	(push :port res))
    (or (equalp (uri-userinfo uri1) (uri-userinfo uri2))
	(push :userinfo res))
    (or (equalp (uri-host uri1) (uri-host uri2))
	(push :host res))
    (when (not ignore-scheme)
      (or (eq (uri-scheme uri1) (uri-scheme uri2))
	  (push :scheme res)))
    (if* (cdr res)
       then res
       else (car res))))

(defun processed-uri-p (uri)
  (maybe-init-processed-uris-hash-table)
  (values (gethash uri *processed-uris*)))

(defun (setf processed-uri-p) (new-val uri)
  (maybe-init-processed-uris-hash-table)
  (setf (gethash uri *processed-uris*) new-val)
  (when *last-visited* (format *last-visited* "~a~%" uri))
  new-val)

(defun note-bad-link (location format-string &rest format-args)
  (incf .status.)
  (apply #'comment location format-string
	 (if* (uri-p (car format-args))
	    then (cons (enough-uri (car format-args) .document-root.)
		       (cdr format-args))
	    else format-args))
  ;; So it can be used in logical expressions:
  nil)

(defun announce-url (&optional condition)
  (declare (ignore condition))
  (when (null .printed-file-name.)
    (.debug -1 "~&~%~a~%" (enough-uri .uri. .document-root.))
    (setq .printed-file-name. t)))

(defun comment (location format-string &rest format-args)
  (announce-url)
  (.debug -1 "~&")
  (let ((*print-pretty* t)
	(format-string
	 (concatenate 'simple-string
	   "- "
	   "~@<"
	   format-string
	   "~@[ [at file position ~d]~].~%"
	   "~:@>"))
	(format-args (append format-args (list location))))
    (if* *break-on-bad-links*
       then (apply #'break format-string format-args)
       else (apply #'.debug -1 format-string format-args))))

(defvar *cgi-prefix* nil)
(defvar *cgi-directory* nil)

(defun initialize-cgi-bin (string)
  (let* ((a-list (delimited-string-to-list string #\=))
	 (name (first a-list))
	 (value (second a-list)))
    (setq *cgi-prefix* (pathname-as-directory name))
    (setq *cgi-directory* (pathname-as-directory value))
    t))

(defun cgi-script-p (uri)
  (when *cgi-prefix*
    (excl::subdirectoryp (pathname (or (uri-path uri) "/")) *cgi-prefix*)))

(defun cgi-script-exists-p (uri)
  (let* ((ns (uri-path uri))
	 (len (substringp (namestring *cgi-prefix*) ns))
	 (base (when len (subseq ns len))))
    (probe-file (merge-pathnames base *cgi-directory*))))

(defvar *icons-prefix* nil)
(defvar *icons-directory* nil)

(defun initialize-icons-dir (string)
  (let* ((a-list (delimited-string-to-list string #\=))
	 (name (first a-list))
	 (value (second a-list)))
    (setq *icons-prefix* (pathname-as-directory name))
    (setq *icons-directory* (pathname-as-directory value))
    t))

(defun icons-file-p (uri)
  (when *icons-prefix*
    (and (equalp (uri-host uri) (uri-host .document-root.))
	 (excl::subdirectoryp
	  (pathname (or (uri-path uri) "/")) *icons-prefix*))))

(defun icons-file-exists-p (uri referer)
  (if* *client-mode*
     then (check-remote-uri nil uri referer)
     else (let* ((ns (uri-path uri))
		 (len (substringp (namestring *icons-prefix*) ns))
		 (base (when len (subseq ns len))))
	    (probe-file (merge-pathnames base *icons-directory*)))))

(defun check-remote-uri (position uri referer &aux result)
  ;; Return T on success, nil on failure.  A nil value means the resource
  ;; failed the "does it exist" check.
  (declare (ignore referer))
  (.debug 20 "check-remote-uri: ~a~%" uri)
  (unwind-protect
      (if* (null (setq result (check-remote-uri-2 uri)))
	 then ;; success
	      t
       elseif (fixnump result)
	 then ;; simulate success here, but comment on it
	      (comment position "Unknown server code ~a: result ~a"
		       uri result)
	      t
       elseif (eq :not-found result)
	 then ;; Revoke the "this link is good and visited" status:
	      (setf (getf (uri-plist uri) :visited) nil)
	      (note-bad-link position "Bad link[2]: ~a" (full-uri uri))
	      nil
       elseif (eq :timed-out result)
	 then ;; we simulate success with timed out URIs, but we note 
	      (comment position "Request for ~a timed out" uri)
	      t
	 else (error "internal error: check-remote-uri result: ~s." result))
    (note-visited-uri uri)))

(defparameter .url-transformations.
    (list (compile-re "^/franz/[^/]+(/.*)\\.l?html.*$")))

(defun check-remote-uri-2 (uri &optional (method :head) &aux path)
  ;; Check that URI exists, returning one of these values:
  ;; - nil        :: access to the URI was successful
  ;; - :timed-out :: returned if access to the URI timed out
  ;; - :not-found :: the classic 404
  ;; - fixnum     :: some unhandled HTTP server code
  (when (and uri .url-transformations.
	     (setq path (net.uri:uri-path uri)))
    (dolist (re-trans .url-transformations.)
      (multiple-value-bind (matched whole new-path)
	  (match-re re-trans path)
	(declare (ignore whole))
	(when matched
	  (setq uri (net.uri:merge-uris new-path uri))
	  (.debug 1 "transformed uri: ~a~%" uri)
	  (return)))))
  (multiple-value-bind (body code)
      (http-get uri method)
    (if* (eq :timed-out body)
       then body
     elseif (eql 200 code)
       then nil
     elseif (eql 404 code)
       then :not-found
       else (.debug 10 "UNHANDLED HTTP CODE: ~s~%" code)
	    code)))

(defun http-get (uri &optional (method :get))
  ;; Return the first 4 values from NET.ASERVE.CLIENT:DO-HTTP-REQUEST,
  ;; which are:
  ;;   1. body
  ;;   2. response code
  ;;   3. an alist of headers
  ;;   4. uri of page accessed
  ;; Pass METHOD through to DO-HTTP-REQUEST.
  ;;
  ;; Impose a timeout on the calls.
  ;;
  ;; If HEAD returns a 404, then retry it as a GET.
  ;;
  ;; If DO-HTTP-REQUEST times out, then :timed-out is returned.
  ;;
  ;; When *wordpress-mode* is non-nil, then use *retry-sleep* to retry
  ;; 404's.  Increment *successful-retries* when a retry works, and
  ;; *total-retries* when we do a retry.
  ;;
  (let ((full (full-uri uri))
	(server-error-retries 0)
	(max-server-error-retries 4)
	(wp-mode *wordpress-mode*)
	(sleep *retry-sleep*)
	(retries 0))
    (tagbody
     retry
      (flet ((http-get-1 (method)
	       (net.aserve.client:do-http-request full
		 :method method
		 :headers *default-headers*
		 :compress (not (eq method :head))
		 :protocol *default-http-protocol*))
	     (debug (n code url)
	       (format t "DEBUG: retry ~d: ~s, ~a~%" n code url)))
	(if* (eq :get method)
	   then (multiple-value-bind (body code headers result-uri)
		    (mp:with-timeout (*timeout* :timed-out)
		      (.debug 2 "probe: ~s ~a~%" :get full)
		      (handler-case (http-get-1 :get)
			(error () (values nil 404 nil))))
		  (if* (eq :timed-out body)
		     then (when (and wp-mode sleep)
			    (incf retries)
			    (incf *total-retries*)
			    (debug retries code full)
			    (sleep (car sleep))
			    (setq sleep (cdr sleep))
			    (go retry))
			  (.debug 2 "probe: :get timed out~%")
			  :timed-out
		   elseif (and (<= 500 code 599)
			       (< server-error-retries
				  max-server-error-retries))
		     then (incf server-error-retries)
			  (go retry)
		   elseif (and (not (eql code 200))
			       wp-mode sleep)
		     then (incf retries)
			  (incf *total-retries*)
			  (debug retries code full)
			  (sleep (car sleep))
			  (setq sleep (cdr sleep))
			  (go retry)
		     else ;; just pass it to caller
			  (.debug 40 "probe-get: ~s code ~s~%" uri code)
			  (when (and (eql code 200)
				     (> retries 0))
			    (incf *successful-retries*))
			  (return-from http-get
			    (values body code headers result-uri))))
	   else ;; :head
		(multiple-value-bind (body code headers result-uri)
		    (mp:with-timeout (*timeout* :timed-out)
		      (.debug 2 "probe: ~s ~a~%" :head full)
		      (handler-case (http-get-1 :head)
			(error () (values nil 404 nil))))
		  (if* (eq :timed-out body)
		     then (when (and wp-mode sleep)
			    (incf retries)
			    (incf *total-retries*)
			    (debug retries code full)
			    (sleep (car sleep))
			    (setq sleep (cdr sleep))
			    (go retry))
			  (.debug 2 "probe: :head timed out~%")
			  :timed-out
		   elseif (and (<= 500 code 599)
			       (< server-error-retries
				  max-server-error-retries))
		     then (incf server-error-retries)
			  (go retry)
		   elseif (eql 200 code)
		     then (.debug 40 "probe-head: ~s code 200~%" uri)
			  (when (> retries 0) (incf *successful-retries*))
			  (return-from http-get
			    (values body code headers result-uri))
		     else (.debug 2 "probe: :head failed, try :get~%")
			  (return-from http-get (http-get uri :get)))))))))

(defun handle-sigint (c)
  (if* *production-mode*
     then (format t "~a~%" c)
	  (exit 1 :no-unwind t :quiet t)
     else (break "~a" c)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Bookmark handling
;;
;; We check bookmark references by saving bookmark definitions as the HTML
;; is parsed.  All the info for the references and definitions are saved on
;; URI plists, when the URI is created, and the uri-fragment slot is nil'd
;; out.  Because of this and that URIs are interned, URIs with different
;; fragments are EQ.  This is an important property of how this program
;; works.

;; Called directly by the HTML parser, for the :id and :a :name cases.
(defun note-bookmark-definition (bookmark)
  (let ((bookmark (net.aserve:uridecode-string bookmark)))
    (when (and .debug-bookmark-re.
	       (match-re .debug-bookmark-re. bookmark :return nil))
      (format t "ZZ: definition: ~a ~a~%" bookmark .uri.))
    (.debug 10 "noting bookmark: ~a in ~a~%" bookmark .uri.)
    ;; .uri. already has the query/fragment removed
    (push bookmark (getf (uri-plist .uri.) :bookmarks-definitions))))

(defun bookmark-defined-p (bookmark uri &aux res debug)
  (when (and .debug-bookmark-re.
	     (match-re .debug-bookmark-re. bookmark :return nil))
    (format t "ZZ: defined-p: ~a ~a~%" bookmark uri)
    (setq debug t))
  (setq res (member bookmark (bookmark-definitions uri) :test #'string=))
  (when debug (format t "ZZ:    => ~s~%" res))
  res)

(defun bookmark-definitions (uri)
  (getf (uri-plist uri) :bookmarks-definitions))

;;;;; References
;;
;; Bookmark references - when a uri is created, the :after method for the
;; initialize-instance (below) calls note-bookmark-reference if the URI has
;; a fragment.

(defun note-bookmark-reference (from-uri to-uri bookmark &aux debug)
  (let ((bookmark (net.aserve:uridecode-string bookmark)))
    ;; href="#" is a special link which takes the user to the top of the
    ;; page and we just ignore it, because it can't be bad.
    (when (string/= "" bookmark)
      (when (and .debug-bookmark-re.
		 (match-re .debug-bookmark-re. bookmark :return nil))
	(setq debug t)
	(format t "ZZ: reference: ~a~%" bookmark from-uri to-uri)
	(format t "ZZ:     from: ~a~%" from-uri)
	(format t "ZZ:       to: ~a~%" to-uri))
      (.debug 10 "noting bookmark ref: ~a from ~a to ~a~%" bookmark
	      from-uri to-uri)
      (if* (bookmarks-defined-for-uri-p to-uri)
	 then ;; we've already processed to-uri, so we know all the bookmarks
	      ;; defined in it.
	      (when debug (format t "ZZ:    checking now~%"))
	      (when (not (bookmark-defined-p bookmark to-uri))
		(note-bad-bookmark nil from-uri to-uri bookmark))
	 else (push (cons from-uri bookmark)
		    (getf (uri-plist to-uri) :bookmark-references))))))

(defun check-pending-bookmarks (uri
				&key ignore-directories
				&aux (*verbose* 10))
  (when (and
	 ;; Only proceed if this is a document we have already processed.
	 ;; This keeps us from giving false positives, since if we haven't
	 ;; processed it then we don't know if the bookmark is good or
	 ;; bad.
	 (processed-uri-p uri)
	 ;; the URI is not ignored
	 (not (ignore-uri-p uri :check-all-links t)))
    (let ((references (bookmark-references uri))
	  from-uri
	  bookmark)
      (.debug 10 "bookmark (~d) post-processing for ~a~%"
	      (length references) uri)
      (when (and .break-before-processing-re.
		 (match-re .break-before-processing-re.
			   (namestring (my-uri-to-pathname uri))
			   :return nil))
	(let ((len (length references)))
	  (when (> len 0)
	    (format t "ZZ: CPB1: ~a have ~d~%" uri len)
	    (dolist (r references)
	      (format t "ZZ:   CPB1: ~s~%" r)))))
      (dolist (item references)
	(setq from-uri (car item))
	(setq bookmark (cdr item))
	(when (and .debug-bookmark-re.
		   (match-re "nudge" bookmark :return nil))
	  (format t "ZZ: CPB2: ~a ~a~%" bookmark from-uri))
	(.debug 10 "check bookmark: ~a for ~a~%" bookmark from-uri)
	(when (and (not (bookmark-defined-p bookmark uri))
		   (or (null ignore-directories)
		       (dolist (dir ignore-directories t)
			 (when (excl::subdirectoryp
				(my-uri-to-pathname uri)
				(uri-path dir))
			   (return nil)))))
	  (note-bad-bookmark nil from-uri uri bookmark)))
      (setf (bookmark-references uri) nil))))


;; Relevant to bookmarks, so it's here:
(defun copy-plist-values (from-uri to-uri)
  ;; Copy from FROM-URI to TO-URI the plist values associated with:
  ;; bookmarks, queries and fragments.
  (when (not (eq from-uri to-uri))
    (.debug 10 "copy-fragment-and-query: ~s ~s~%"
	    from-uri to-uri)
    
    ;; :query and :fragment are copied, not merged, though I believe the
    ;; way we do URIs, the fragment will already be the same for both.
    (dolist (prop '(:query :fragment))
      (setf (getf (uri-plist to-uri) prop) (getf (uri-plist from-uri) prop)))

    ;; Bookmark definitions
    ;;   NOTE: in Mar '23 I fixed a typo in the following keyword, which
    ;;         makes me believe either the following form is not needed or
    ;;         I do not have a test case for when it is needed.  For now,
    ;;         I'm leaving it in, because I'm nervious about removing it.
    (dolist (bookmark (getf (uri-plist from-uri) :bookmarks-definitions))
      (pushnew bookmark (getf (uri-plist to-uri) :bookmarks-definitions)
	       :test #'string=))

    ;; Bookmark references
    (dolist (from-reference (bookmark-references from-uri))
      ;; FROM-REFERENCE is a list of cons, of the form:
      ;;   (uri . bookmark-string)
      (pushnew
       from-reference
       (getf (uri-plist to-uri) :bookmark-references)
       :test (lambda (item place-item)
	       ;; The arguments both have the form: (URI . fragment).
	       ;; - ITEM is FROM-REFERENCE
	       ;; - PLACE-ITEM is one of the existing :bookmark-references
	       ;; Return true if they are the same.
	       (and (uri-equal (car item) (car place-item))
		    (string= (cdr item) (cdr place-item))))))))

(defun bookmarks-defined-for-uri-p (uri)
  ;; Return nil if no bookmarks are defined for URI.
  (getf (uri-plist uri) :bookmarks-defined))

(defun (setf bookmarks-defined-for-uri-p) (new-val uri)
  ;; Assert that bookmarks are defined for URI.
  (setf (getf (uri-plist uri) :bookmarks-defined)
    new-val))


(defun bookmark-references (uri)
  (getf (uri-plist uri) :bookmark-references))

(defun (setf bookmark-references) (new-val uri)
  (setf (getf (uri-plist uri) :bookmark-references)
    new-val))


(defun note-bad-bookmark (location from-uri to-uri bookmark)
  (incf .status.)
  (if* (eq from-uri to-uri)
     then (comment location "Reference to non-existent bookmark ~s" bookmark)
     else (comment
	   location
	   "Reference to a non-existent bookmark ~s in ~a, from file ~a"
	   bookmark to-uri from-uri)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; modified behavior of the `uri' module.

(defvar *merge-interns* t)

(defvar *temp-uri* (make-instance 'uri))
(defvar *temp-uri2* (make-instance 'uri))

net.uri::
(defmethod initialize-instance :after ((uri uri) &key)
  (when user::*uri-clos-hackery*
    (let ((user::*uri-clos-hackery* nil))
      (with-slots (scheme host path query fragment plist) uri
	;; The following is a ugly hack, but necessary given our overall
	;; strategy.  I need the URIs /foo/ and /foo/index.html to be `eq',
	;; so the plist of a single URI is used.  Problem is, the default
	;; document is defined in the server, so I'm making a guess here.
	;; It's even worse, because the default document can usually be one
	;; of many choices.  So, this leads me to looking at the filesystem
	;; to see which of the default choices I know about are there.
	;; Ugh.
	;;
	;; We also need "foo" and "foo#" to be eq.
	(when (and fragment (string= "" fragment))
	  (setq fragment nil))
	(let (p)
	  (when (and (null user::*client-mode*)
		     (null scheme)
		     (null fragment)
		     (or (null path)
			 (and (setq p (user::my-uri-to-pathname uri))
			      (let ((*default-pathname-defaults*
				     ;; the probe-file needs to be relative
				     ;; to where the file is
				     (path-pathname p)))
				(and (probe-file p)
				     (file-directory-p p))))))
	    (setq path
	      (or (dolist (file user::*index-files*)
		    (let* ((user::*merge-interns* nil)
			   (temp (merge-uris
				  (copy-uri nil :path file
					    :place user::*temp-uri*
					    :class 'uri)
				  uri
				  user::*temp-uri2*))
			   (p (user::my-uri-to-pathname temp))
			   (*default-pathname-defaults*
			    ;; the probe-file needs to be relative to where
			    ;; the file is
			    (path-pathname p)))
		      (when (probe-file p)
			(return (uri-path temp)))))
		  (error "neither index.html nor index.htm exists!")))))
	
	;; In all cases, we need to note this reference.  If the URI was
	;; something like "#foo" we need to make sure it's a valid
	;; reference.  .URI. and URI will be URI-EQUAL, but that doesn't
	;; matter.
	(when fragment
	  (let ((to (if* (user::uri-equal user::.null-uri. uri)
		       then ;; if URI is the null URI, then we really want
			    ;; to note the reference to the document we are
			    ;; currently checking, which is:
			    user::.uri.
		       else uri)))
	    (user::note-bookmark-reference user::.uri. to fragment)))
	
	;; Save the query and fragment, so they can be used in HTTP
	;; requests to check the page.  Then, set them to nil, so when the
	;; URI is interned they will be ignored in comparisons, etc.
	;; See full-uri below.
	(when (and query (not (equal query (getf plist :query))))
	  ;;(user::.debug 2 "QUERY: ~a: existing plist is ~s~%" uri plist)
	  ;;(user::.debug 2 "     new query is ~s~%" query)
	  (setf (getf plist :query) query)
	  (setq query nil))
	(when (and fragment
		   ;; we handle this case above
		   #+ignore (string/= "" fragment)
		   (not (equal fragment (getf plist :fragment))))
	  ;;(user::.debug 2 "FRAGMENT: ~a: existing plist is ~s~%" uri plist)
	  ;;(user::.debug 2 "     new fragment is ~s~%" fragment)
	  (setf (getf plist :fragment) fragment)
	  (setq fragment nil))))))

(defun full-uri (uri)
  ;; Reconstruct the original URL from the :query and :fragment plist items
  ;;
  ;; Use in calls to do-http-request or presentation of URIs to the user.
  (let ((query (getf (uri-plist uri) :query))
	(fragment (getf (uri-plist uri) :fragment)))
    (when (and fragment (string= "" fragment))
      (setq fragment nil))
    (if* (or query fragment)
       then (let ((user::*uri-clos-hackery* nil))
	      (let ((u (copy-uri uri :query query :fragment fragment)))
		;;(.debug 2 "FULL-URI: ~a~%" u)
		u))
       else uri)))

(defvar *uri-space* (uri-space))

net.uri::
(defmethod intern-uri :around
	   ((new-uri uri) &optional (uri-space user::*uri-space*))
  ;; Merge plists in the possibly different URIs, the one given to
  ;; intern-uri and the one returned.
  (declare (ignore uri-space))
  (flet ((merge-plists (p1 p2)
	   (do* ((new (copy-list p1))
		 (p2 p2 (cddr p2))
		 tmp)
	       ((null p2) new)
	     (if* (setq tmp (cdr (member (car p2) new :test #'eq)))
		then (let* ((v1 (car tmp))
			    (v2 (cadr p2)))
		       (if* (null v1)
			  then (setf (car tmp) v2)
			elseif (null v2)
			  then (setf (car tmp) v1)
			elseif (atom v1)
			  then (when (not (equal v1 v2))
				 (error "plist values not equal: ~s, ~s."
					v1 v2))
			  else (assert (and (consp v1) (consp v2)))
			       (setf (car tmp)
				 (union v1 v2 :test #'equal))))
		else (push (cadr p2) new)
		     (push (car  p2) new)))))
    (if* user::*uri-clos-hackery*
       then (let ((user::*uri-clos-hackery* nil)
		  (old-uri (call-next-method)))
	      (when (not (eq old-uri new-uri))
		(setf (uri-plist old-uri)
		  (merge-plists (uri-plist old-uri) (uri-plist new-uri))))
	      old-uri)
       else (call-next-method))))

net.uri::
(defmethod merge-uris :around (uri base &optional place)
  ;; Define this :around method so that merge-uris automatically interns
  ;; URIs.
  (when (stringp uri)
    (setq uri (user::clean-uri-string uri)))
  (if* user::*uri-clos-hackery*
     then (let ((user::*uri-clos-hackery* nil)
		(new (user::sanity-check-uri
		      (call-next-method uri base place) uri base)))
	    (if* user::*merge-interns*
	       then (let ((res (intern-uri new user::*uri-space*)))
		      ;;(format t "merge ~a ~a -> ~a~%" uri base res)
		      res)
	       else ;;(format t "merge ~a ~a -> ~a~%" uri base new)
		    new))
     else ;; Being called inside initialize-instance above.
	  (let ((new (call-next-method uri base place)))
	    (user::sanity-check-uri new uri base)
	    ;;(format t "merge ~a ~a -> ~a~%" uri base new)
	    new)))

(defun sanity-check-uri (result uri base)
  ;; make sure it doesn't start with ``/../'', which means there were too
  ;; many ..'s in the uri of a merge-uris.
  (when (substringp "/../" (uri-path result))
    (error "Merge of ~a and ~a yields bad result: ~a." uri base result))
  result)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; these things should be elsewhere:

(defun concat-pathnames (p1 p2)
  (setq p1 (pathname p1))
  (setq p2 (pathname p2))
  (assert (and (excl::absolute-pathname-p p1)
	       (excl::absolute-pathname-p p2)))
  (let ((np2
	 (make-pathname
	  :host (pathname-host p2)
	  :device (pathname-device p2)
	  :directory (let ((d (pathname-directory p2)))
		       (cons :relative (cdr d)))
	  :name (pathname-name p2)
	  :type (pathname-type p2))))
    (merge-pathnames np2 p1)))

(defun substringp (test sequence)
  ;; return length of `test' if `sequence' starts with `test'
  (let ((test-len (length test))
	(seq-len (length sequence)))
    (when (>= test-len seq-len)
      (return-from substringp nil))
    (do* ((i 0 (1+ i)))
	((= i test-len) test-len)
      (when (not (char= (schar test i)
			(schar sequence i)))
	(return nil)))))


;; This is needed because of ABUSE of the URIs RFC by Cloudflare and others.
;; They transform URIs into illegal URIs, like this:
;;   https://cdn.allegrograph.com/spai/q_glossy+ret_img+to_webp/https://allegrograph.com/wp-content/uploads/2017/04/favicon.png
;; Why the f did they have to use an unparsable syntax? They could easily
;; have used more queries to make it parsable.
;;
;; The old solution of removing everything before the 2nd "https://" does
;; not work because it produces bad URIs, too.  Consider:
;;   https://foo.com/mumble?u=https://blarg.com/rox&source=space
;; The problem is, the 2nd URI is embedded in the query parameter 'u'.
;;
;; The new strategy to deal with them is to transform the 2nd
;; "https://" into "https___" so the URI is valid, from a parsing
;; standpoint, but can be ignored from a link check standpoint.
;; Note that URIs with these illegal patterns are all going to be external,
;; so there really isn't anything to ignore on the link check side.
(defun clean-uri-string (string)
  (multiple-value-bind (matched whole before after)
      (match-re "(https://.*)https://(.*)" string)
    (declare (ignore whole))
    (if* matched
       then (concatenate 'simple-string before "https___" after)
       else string)))

(defun safe-parse-uri (string)
  (parse-uri (clean-uri-string string)))


(defun zoom (stream &rest zoom-command-args
	     &key (count t) (all t)
	     &allow-other-keys)
  "Generate a execution stack trace to STREAM.  This function is a wrapper
for top-level :zoom command and is intended to be used in application that
want to report unexpected errors.  See with-auto-zoom-and-exit.

This function is only useful when used in conjunction with HANDLER-BIND.
For example:

 (handler-bind
    ((error (lambda (condition)
	      ;; write info about CONDITION to a log file...
              (format *log-stream* \"Error in app: ~a~%\" condition)

	      ;; send a zoom to the log file, too
	      (top-level.debug:zoom *log-stream*))))
  (application-init-function))

The COUNT and ALL keywords are passed to the :zoom command and are
documented with that command."
  (with-standard-io-syntax
    (let ((*print-readably* nil)
	  (*print-miser-width* 40)
	  (*print-pretty* t)
	  (top-level:*zoom-print-circle* t)
	  (top-level:*zoom-print-level* nil)
	  (top-level:*zoom-print-length* nil)
	  (*terminal-io* stream)
	  (*standard-output* stream))
      (apply #'top-level:do-command "zoom"
	     :from-read-eval-print-loop nil
	     :count count :all all zoom-command-args))))
