(define *not-found* (lambda() #t))
(define (not-founded? x) (eq? x *not-found*))
(define (founded? x) (not (not-founded? x)))

;; ip address checker
(define ipv4-regex
  (make-regexp
   "^([1-9]?[0-9]|1[0-9]{2}|2[0-4][0-9]|25[0-5])([.]([1-9]?[0-9]|1[0-9]{2}|2[0-4][0-9+]|25[0-5])){3}$"
   regexp/extended))

(define (invalid-ipv4? x)
  (not (regexp-exec ipv4-regex x)))

;; hostname checker
(define hostname-regex (make-regexp "^[a-zA-Z_][.a-zA-Z0-9_-]*$" regexp/extended))
(define (invalid-hostname? x)
  (not (regexp-exec hostname-regex x)))

;;translator
(define (translator-from-args args)
  (make-translator "alterator" (cond-plistq 'language args '("en"))))

(define (resolve-type type params value args)
  (let ((_ (translator-from-args args)))
    (case type
      ;;types
      ((hostname)
       (and params
            (string? value)
            (find invalid-hostname? (string-cut-repeated value #\newline))
            (_ "invalid hostname")))
      ((ipv4-address)
       (and params
            (string? value)
            (find invalid-ipv4? (string-cut-repeated value #\newline))
            (_ "invalid ipv4 address")))
      ;;commons
      ((match)
       (let ((pattern (if (pair? params) (car params) params))
             (message (if (pair? params)
                          (cadr params)
                          (string-append (_ "doesn't match to pattern") " '" params "'"))))
         (and (string? value)
              (not (string-match pattern value))
              message)))
      ((enum)
       (and (founded? value)
            (not (member value params))
            (string-append (_ "should be one of:") (string-join (map ->string params) ","))))
      ((equal)
       (let ((other-value (cond-plistq params args *not-found*)))
         (and (or (founded? value) (founded? other-value))
              (not (equal? value other-value))
              (_ "values not equal"))))
      ((required) (and params
                       (or (not-founded? value) (empty-string? value))
                       (string-append (_ "required, but missing"))))
      (else #f))))

(define (failed-constraint value args)
  (lambda(type params)
    (resolve-type type params value args)))

(define (resolve-option name value constraints args)
  (let ((result (plist-any (failed-constraint value args)
                           constraints)))
    (and result
         (string-append
          (cond-plistq 'label constraints (->string name))
          " : " result))))

;;return list of unsatisfied constraints for all specified constraints
(define (resolve-constraints constraints args)
  (define (cond-cons x y) (if (string? x) (cons x y) y))
  (plist-fold (lambda(name type result)
                (cond-cons
                 (resolve-option name
                                 (cond-plistq name args *not-found*)
                                 type
                                 args)
                 result))
              '()
              constraints))


;;;;;;;;;;;;;;;;; excludes

;;return all exclude rules
(define (get-excludes value constraints)
  (plist-fold (lambda (type params result)
                (if (and (eq? type 'exclude)
                         (equal? value (car params)))
                    (cons (cadr params) result)
                    result))
              '()
              constraints))

(define (exclude-args args excludes)
  (plist-filter
   (lambda(arg value) (member arg excludes))
   args))

(define (process-excludes constraints args)
  (car+cdr
   (plist-fold (lambda (name constraints c+a)
                 (let* ((c (car c+a))
                        (a (cdr c+a))
                        (rules (get-excludes (cond-plistq name a "") constraints)))
                   (cons (exclude-args c rules)
                         (exclude-args a rules))))
               (cons constraints args)
	       constraints)))

(define (quote-answer x)
   (cons 'quote x))

;;entry point for constraints solver
(lambda (self name args)
  (let*-values (( (action) (cond-plistq 'action args) )
                ;;exclude action from args to avoid side effects in underlying woo calls
                ( (args) (exclude-args args '(action)) )
                ( (constraints) (read-constraints action name args) )
                ( (args) (process-defaults constraints args) )
                ( (constraints args) (process-excludes constraints args) )
                ( (result) (resolve-constraints constraints args) )
                ( (_) (translator-from-args args) ))
    (if (null? result)
        (map quote-answer (apply woo-try action name args))
        (woo-throw (_ "Constraints failed:")
                   (string #\newline)
                   (string-join result (string #\newline))))))
