(defpackage :cl-taint
  (:use :common-lisp #+fiveam :it.bese.fiveam)
  (:export :taint :untaint :tainted-p :detaint :with-detaint)
  (:documentation "Simple package to taint and untaint values.
The basic idea is to wrap a value in a struct, making the value unusable directly.
This means you have to explicitly untaint it to get back a useful value.

Usage follows this pattern: your functions that return data from the outside
(such as parameters from a web client) return their value via (taint value).
Later, when the function is desired, you use (untaint #'parse-integer tainted-value),
WITH-DETAINT, DETAINT, or the like."))

(in-package cl-taint)

(defstruct tainted-value
    (value nil))
(defmethod print-object ((obj tainted-value) stream)
  (if *print-escape*
      (print-unreadable-object (obj stream :type t :identity t)
	(format stream "~S" (tainted-value-value obj)))
      (princ "TAINTED" stream)))

(defun taint (value)
  "Taints a value
Wraps a value in a lambda so that it no longer makes sense by itself."
  (make-tainted-value :value value))

(defun untaint (func tainted-value)
  "Untaints a value, returning it
Takes a function of one argument which will be passed the tainted value."
  (funcall func (tainted-value-value tainted-value)))

(defun tainted-p (tainted-value)
  "Returns T if argument is tainted."
  (typep tainted-value 'tainted-value))


;;;; Below here lies the code for detaint

(defun string->integer (string &key strict min max pred)
  "Parses an integer from string.
If strict, then every character in the string must be an integer.
If not strict, then the first integer sequence in the string will be parsed.
If min is specified, the number must be at least min
If max is specified, the number must be at least max
If pred is specified, the (funcall pred number) must be true

If any of these do not hold, nil is returned"
  (declare (type string string)
	   (type (or null function) pred))
  (labels ((number-char-p (c)
	     (member c '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\0)))
	   (find-legal-start-pos (some-string)
	     (loop for i upto (length some-string)
		   when (or (number-char-p (elt some-string i))
			    (and (eql #\- (elt some-string i))
				 (number-char-p (elt some-string (min (length some-string) (1+ i))))))
		     return i
		   finally (return 0)))) ; it should NEVER be possible to hit this - this function won't be called unless there is a legal character
    (when (or (and (not strict)
		   (some #'number-char-p string))
	      (and strict
		   (or (number-char-p (elt string 0)) (eql #\- (elt string 0)))
		   (every #'number-char-p (subseq string 1))))
      (let ((int (if strict
		     (parse-integer string)
		     (parse-integer string :start (find-legal-start-pos string) :junk-allowed t))))
	(when int
	  (if (and (or (not min)
		       (>= int min))
		   (or (not max)
		       (<= int max))
		   (or (not (functionp pred))
		       (funcall pred int)))
	      int
	      nil))))))

(defun string->string (string &key min-length max-length match imatch every some pred)
  "Checks a string for certain attributes.
If min-length, then string must be at least that long
If max-length, then string must be no more than that long
If match, then string must match match
If imatch, then string must case-insensitively match match
If every, then every character in the string must return true for (funcall every c)
If some, then at least one character in the string must return true for (funcall some c)
If pred, then (funcall pred string) must return true

If any of these do not hold, nil is returned"
  (declare (type string string)
	   (type (or null integer) min-length max-length)
	   (type (or null function) every some pred))
  (if (and (or (not min-length)
	       (>= (length string) min-length))
	   (or (not max-length)
	       (<= (length string) max-length))
	   (or (not match)
	       (equal string match))
	   (or (not imatch)
	       (string-equal string imatch))
	   (or (not (functionp every))
	       (every every string))
	   (or (not (functionp some))
	       (some some string))
	   (or (not (functionp pred))
	       (funcall pred string)))
      string
      nil))

(defun string->symbol (string &key package uppercase)
  "Turns a string into a symbol in :package, optionally uppercasing it"
  (multiple-value-bind (symbol package) ; if we return multiple values, detaint assumes that this was not handled!
      (intern (if uppercase
		  (string-upcase string)
		  string)
	      package)
    (declare (ignore package))
    symbol))

(defun local-symbol (symbol)
  "Guarantees that the symbol will be in the current package"
  (intern (symbol-name symbol) :cl-taint))

(defun unwrap-value (value)
  "Unconditionally get the value, whether tainted or not"
  (if (tainted-p value)
      (untaint #'identity value)
      value))

(defun handle-integer-type (value args strict)
  (when value
    (destructuring-bind (&key min max pred) args
      (string->integer value :strict strict :min min :max max :pred (when pred (symbol-function pred))))))

(defun handle-string-type (value args)
  (when value
    (destructuring-bind (&key min-length max-length every some pred match imatch) args
      (string->string value
		      :min-length min-length
		      :max-length max-length
		      :match match
		      :imatch imatch
		      :every (when every (symbol-function every))
		      :some (when some (symbol-function some))
		      :pred (when pred (symbol-function pred))))))

(defun handle-nestring-type (value args)
  (declare (ignore args))
  (when value
    (if (equal value "")
	nil
	value)))

(defun handle-symbol-type (value args keywordp uppercasep)
  (when value
    (destructuring-bind (&key package) args
      (string->symbol value
		      :package (if keywordp
				   :keyword
				   (if package package *package*))
		      :uppercase uppercasep))))

(defun coerce-char (char)
  (cond
    ((characterp char) char)
    ((symbolp char) (if (= (length (symbol-name char)) 1)
			(elt (symbol-name char) 0)
			(error "~S is not a valid character specifier for a filter (bad length)" char)))
    ((stringp char) (if (= (length char) 1)
			(elt char 0)
			(error "~S is not a valid character specifier for a filter (bad length)" char)))
    ((integerp char) (elt (princ-to-string char) 0))))
      
(defun filter-specifier-matches-p (specifier c case-sensitive)
  (cond
    ((atom specifier) (if case-sensitive
			  (eql (coerce-char specifier) c)
			  (char-equal (coerce-char specifier) c)))
    ((consp specifier)
     (ecase (local-symbol (car specifier))
       ((any or union) (some (lambda (sub-spec) (filter-specifier-matches-p sub-spec c case-sensitive))
			     (cdr specifier)))
       ((iany ior iunion) (some (lambda (sub-spec) (filter-specifier-matches-p sub-spec c nil))
				(cdr specifier)))
       ((every and intersection) (every (lambda (sub-spec) (filter-specifier-matches-p sub-spec c case-sensitive))
					(cdr specifier)))
       ((ievery iand iintersection) (every (lambda (sub-spec) (filter-specifier-matches-p sub-spec c nil))
					   (cdr specifier)))
       (difference (and (notany (lambda (sub-spec) (filter-specifier-matches-p sub-spec c case-sensitive))
				(cddr specifier))
			(filter-specifier-matches-p (cadr specifier) c case-sensitive)))
       (not (not (filter-specifier-matches-p (cadr specifier) c case-sensitive)))

       ((nocase icase) (filter-specifier-matches-p (cadr specifier) c nil))
       (case (filter-specifier-matches-p (cadr specifier) c t))

       (pred (funcall (symbol-function (cadr specifier)) c))
       (not-pred (not (funcall (symbol-function (cadr specifier)) c)))

       (range (destructuring-bind (start end) (cdr specifier)
		(let ((c-code (char-code (if case-sensitive c (char-upcase c))))
		      (start-code (char-code (if case-sensitive (coerce-char start) (char-upcase (coerce-char start)))))
		      (end-code (char-code (if case-sensitive (coerce-char end) (char-upcase (coerce-char end))))))
		  (and (>= c-code start-code)
		       (<= c-code end-code)))))
       (not-range (not (filter-specifier-matches-p (cons 'range (cdr specifier)) c case-sensitive)))))))

(defun gather-filter (specifier value)
  (coerce (remove-if (complement (lambda (c)
				   (filter-specifier-matches-p specifier c t)))
		     (coerce value 'cons))
	  'string))

(defun remove-filter (specifier value)
  (coerce (remove-if (lambda (c)
		       (filter-specifier-matches-p specifier c t))
		     (coerce value 'cons))
	  'string))

(defun %example-match (input pattern in-variable-length-integer)
  (declare (type list input pattern)
	   (type boolean in-variable-length-integer))
  (if (or (null input)
	  (null pattern))
      (if (and (null input)
	       (null pattern))
	  t
	  nil)
      (cond
	(in-variable-length-integer (if (digit-char-p (car input))
					(%example-match (cdr input) pattern t)
					(%example-match input pattern nil)))
	(t
	 (case (car pattern)
	   (#\x (when (lower-case-p (car input))
		  (%example-match (cdr input) (cdr pattern) nil)))
	   (#\X (when (upper-case-p (car input))
		  (%example-match (cdr input) (cdr pattern) nil)))
	   ((#\i #\I) (when (alpha-char-p (car input))
			(%example-match (cdr input) (cdr pattern) nil)))
	   ((#\* #\_) (%example-match (cdr input) (cdr pattern) nil))
	   ((#\1 #\2 #\3 #\4 #\5
		 #\6 #\7 #\8 #\9) (when (digit-char-p (car input))
				    (%example-match (cdr input) (cdr pattern) nil)))
	   (#\0 (when (digit-char-p (car input))
		  (%example-match (cdr input)
				  (loop for sub on (cdr pattern)
					when (not (digit-char-p (car sub)))
					return sub)
				  t)))
	   (otherwise (when (eql (car pattern) (car input))
			(%example-match (cdr input) (cdr pattern) nil))))))))

(defun example-match (input pattern)
  (if (or (zerop (length input))
	  (zerop (length pattern)))
      (if (and (zerop (length input))
	       (zerop (length pattern)))
	  input
	  nil)
      (%example-match (coerce input 'cons)
		      (coerce pattern 'cons)
		      nil)))

(defun handle-filter-pass (value args)
  (when value
    (destructuring-bind ((filter-type specifier) sub-type) args
      (ecase (local-symbol filter-type)
	((gather pass) (detaint (gather-filter specifier value) sub-type))
	((drop remove fail) (detaint (remove-filter specifier value) sub-type))))))

(defun handle-match-pass (value args)
  (when value
    (destructuring-bind ((match-type specifier) sub-type) args
      (ecase (local-symbol match-type)
	(example (when (example-match value specifier)
		   (detaint value sub-type)))))))
		      
(defun handle-type (value type args)
  (case (local-symbol type)
    ((integer loose-integer) (handle-integer-type value args nil))
    (strict-integer (handle-integer-type value args t))

    (string (handle-string-type value args))
    (nestring (handle-nestring-type value args))

    (symbol (handle-symbol-type value args nil t))
    ((exact-symbol msymbol) (handle-symbol-type value args nil t))
    (keyword (handle-symbol-type value args t t))
    ((exact-keyword mkeyword) (handle-symbol-type value args t nil))

    (with-filter (handle-filter-pass value args))
    (with-match (handle-match-pass value args))
    (otherwise (values nil t))))


(defun detaint (value type)
  "A declarative form of untaint.
Passed a string (can deal with tainted and untainted strings) and a declarative form describing
and constrainting the result.

Usually used through with-detaint.

DETAINT is (fully?) documented in doc/taint.html, but here is an EBNF-like description of valid
constructs

(DETAINT possibly-tainted-value detaint-declaration)

detaint-declaration: type
                   | statement
                   | literal

type: simple-type
    | complex-type

integer-specifier: integer | loose-integer | strict-integer
string-specifier: string | nestring
symbol-specifier: symbol | exact-symbol | msymbol | keyword | exact-keyword | mkeyword

simple-type: integer-specifier
           | string-specifier
           | symbol-specifier

complex-type: (integer-specifier <:min literal> <:max literal> <:pred literal>)
            | (string-specifier <:min-length literal> <:max-length literal> <:every literal> <:some literal> <:pred literal> <:match literal> <:imatch literal>)
            | (symbol-specifier <:package literal>)

statement:  ([or|any] <detaint-declaration>*)
          | (if detaint-declaration detaint-declaration <detaint-declaration>)
          | (when detaint-declaration detaint-declaration)
          | (with-match match-specifier detaint-declaration)
          | (with-filter filter-specifier detaint-declaration)

match-specifier: (example example-match-string)

filter-specifier: ([gather|pass] character-filter)
                | ([drop|remove|fail] character-filter)

character-filter: char-literal
                | ([any|or|union] <character-filter>*)
                | ([iany|ior|iunion] <character-filter>*)
                | ([every|and|intersection] <character-filter>*)
                | ([ievery|iand|iiintersection] <character-filter>*)
		| (difference character-filter <character-filter>*)
                | (not character-filter)
                | (case character-filter)
                | ([nocase|icase] character-filter)
                | (pred function)
                | (not-pred function)
                | (range char-literal char-literal)
                | (not-range char-literal char-literal)

char-literal: character | one-letter-symbol | one-letter-string

...as you can see, there's a little bit to it."
  (declare (type (or string tainted-value null) value))
  (let ((value (unwrap-value value)))
    (cond
      ((atom type)
       (cond
	 ((symbolp type) (multiple-value-bind (ret-value unhandled) (handle-type value type nil)
			   (if unhandled
			       type
			       ret-value)))
	 (t type)))
      ((consp type)
       (case (local-symbol (car type))
	 ((or any) (loop for try in (cdr type)
			 when (detaint value try)
			 return it))
	 (if (destructuring-bind (if then &optional else) (cdr type)
	       (if (detaint value if)
		   (detaint value then)
		   (detaint value else))))
	 (when (destructuring-bind (if then) (cdr type)
		 (when (detaint value if)
		   (detaint value then))))
	 (otherwise (multiple-value-bind (ret-value unhandled) (handle-type value (local-symbol (car type)) (cdr type))
		      (if unhandled
			  (error "Unknown detaint construct ~S" type)
			  ret-value))))))))

(defmacro with-detaint (detaints &body body)
  "Execute body with detainted variables.
Usage will look like:
(with-detaint ((integer x y z)
	       (string string1 string2)
	       ((or strict-integer
		    string) integer-or-string))
  (format t \"x: ~S y: ~S z: ~S string1: ~S string2: ~S integer-or-string: ~S\" x y z string1 string2 integer-or-string))

See the documentation for detaint to see all of the constructs that you can use.
The test suite in test-server.lisp has many examples."
  `(let ,(mapcan (lambda (detaint-statement)
		   (mapcar (lambda (var)
			     `(,var (detaint ,var ',(car detaint-statement))))
			   (cdr detaint-statement)))
		 detaints)
    ,@body))