safsaf/safsaf/params.scm

;; Safsaf, a Guile web framework
;; Copyright (C) 2026  Christopher Baines <mail@cbaines.net>

;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
;; as published by the Free Software Foundation, either version 3 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this program.  If not, see
;; <https://www.gnu.org/licenses/>.

(define-module (safsaf params)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (web uri)
  #:autoload (safsaf handler-wrappers csrf) (current-csrf-token)
  #:export (<invalid-param>
            make-invalid-param
            invalid-param?
            invalid-param-value
            invalid-param-message

            parse-params
            parse-form-params
            any-invalid-params?
            invalid-param-ref
            field-errors
            params->query-string
            guard-against-mutually-exclusive-params

            ;; Built-in processors
            as-string
            as-integer
            as-number
            as-checkbox
            as-one-of
            as-matching
            as-predicate))

;;;
;;; Error record — appears inline as a value in the result alist
;;;

(define-immutable-record-type <invalid-param>
  (make-invalid-param value message)
  invalid-param?
  (value   invalid-param-value)
  (message invalid-param-message))

;;;
;;; Built-in processors
;;;
;;; A processor is a procedure: string → value | <invalid-param>.
;;; It both validates and transforms the input string.
;;;

(define as-string identity)

(define (as-integer s)
  (let ((n (string->number s)))
    (if (and n (exact-integer? n))
        n
        (make-invalid-param s "Must be a whole number"))))

(define (as-number s)
  (let ((n (string->number s)))
    (if n
        n
        (make-invalid-param s "Must be a number"))))

(define (as-checkbox s)
  (string=? s "on"))

(define* (as-one-of choices #:key (message #f))
  "Return a processor that accepts only values in CHOICES (a list of strings)."
  (lambda (s)
    (if (member s choices)
        s
        (make-invalid-param
         s (or message
                (string-append "Must be one of: "
                               (string-join choices ", ")))))))

(define* (as-matching regex #:key (message "Invalid format"))
  "Return a processor that accepts values matching REGEX."
  (let ((rx (if (string? regex) (make-regexp regex) regex)))
    (lambda (s)
      (if (regexp-exec rx s)
          s
          (make-invalid-param s message)))))

(define* (as-predicate pred #:key (message "Invalid value"))
  "Return a processor that accepts values for which PRED returns true."
  (lambda (s)
    (if (pred s)
        s
        (make-invalid-param s message))))

;;;
;;; Core parsing
;;;

(define (parse-params param-specs raw-params)
  "Parse and transform parameters from RAW-PARAMS according to PARAM-SPECS.

RAW-PARAMS is an alist of (string . string) pairs, as returned by
parse-query-string or parse-form-body.

PARAM-SPECS is a list of specifications.  Each spec is a list whose first
element is the parameter name (a symbol), second is a processor procedure
(string -> value | <invalid-param>), and the rest are keyword options:

  (name processor)                                         ; optional
  (name processor #:required)                              ; must be present
  (name processor #:default value)                         ; fallback
  (name processor #:multi-value)                           ; collect all occurrences
  (name processor #:multi-value #:default value)           ; multi-value with fallback
  (name processor #:no-default-when (fields) #:default value) ; conditional default

Returns an alist of (symbol . value) pairs.  Values that fail validation
appear as <invalid-param> records inline.  Missing optional params without
defaults are omitted."
  (let ((sym-params (map (match-lambda
                           ((name . value)
                            (cons (if (symbol? name) name (string->symbol name))
                                  value)))
                         raw-params)))
    (filter-map
     (match-lambda
       ((name processor)
        (match (assq name sym-params)
          (#f #f)
          ((_ . "") #f)
          ((_ . value) (cons name (processor value)))))

       ((name processor #:required)
        (match (assq name sym-params)
          (#f (cons name (make-invalid-param #f "This field is required")))
          ((_ . "") (cons name (make-invalid-param "" "This field is required")))
          ((_ . value) (cons name (processor value)))))

       ((name processor #:multi-value)
        (match (filter-map
                (match-lambda
                  ((k . value)
                   (and (eq? k name)
                        (match value
                          (#f #f)
                          ("" #f)
                          (v (processor v))))))
                sym-params)
          (() #f)
          (x (cons name x))))

       ((name processor #:multi-value #:default default)
        (match (filter-map
                (match-lambda
                  ((k . value)
                   (and (eq? k name)
                        (match value
                          (#f #f)
                          ("" #f)
                          (v (processor v))))))
                sym-params)
          (() (cons name default))
          (x (cons name x))))

       ((name processor #:no-default-when fields #:default default)
        (let ((use-default?
               (every (lambda (field)
                        (not (assq field sym-params)))
                      fields)))
          (match (assq name sym-params)
            (#f (if use-default?
                    (cons name default)
                    #f))
            ((_ . "") (if use-default?
                         (cons name default)
                         #f))
            ((_ . value) (cons name (processor value))))))

       ((name processor #:default default)
        (match (assq name sym-params)
          (#f (cons name default))
          ((_ . "") (cons name default))
          ((_ . value) (cons name (processor value))))))
     param-specs)))

;;;
;;; CSRF integration
;;;

(define (csrf-processor s)
  (let ((expected (current-csrf-token)))
    (if (and expected s (string? s) (string=? s expected))
        #t
        (make-invalid-param s "Invalid CSRF token"))))

(define* (parse-form-params param-specs raw-params
                            #:key (csrf-field 'csrf-token))
  "Like parse-params but prepends a CSRF token check.
Uses current-csrf-token from (safsaf handler-wrappers csrf)."
  (parse-params (cons (list csrf-field csrf-processor #:required)
                      param-specs)
                raw-params))

;;;
;;; Result inspection
;;;

(define (any-invalid-params? parsed-params)
  "Return #t if any values in PARSED-PARAMS are invalid."
  (any (match-lambda
         ((_ . value)
          (if (list? value)
              (any invalid-param? value)
              (invalid-param? value))))
       parsed-params))

(define (invalid-param-ref parsed-params name)
  "Return the <invalid-param> record for NAME, or #f if valid or absent."
  (let ((v (assq-ref parsed-params name)))
    (and (invalid-param? v) v)))

(define (field-errors parsed-params name)
  "Return a list of error message strings for NAME, or '().
Convenient for rendering form fields with per-field errors."
  (let ((v (assq-ref parsed-params name)))
    (cond
     ((invalid-param? v)
      (let ((msg (invalid-param-message v)))
        (if msg (list msg) '())))
     ((and (list? v) (any invalid-param? v))
      (filter-map (lambda (x)
                    (and (invalid-param? x) (invalid-param-message x)))
                  v))
     (else '()))))

;;;
;;; Mutual exclusion
;;;

(define (guard-against-mutually-exclusive-params parsed-params groups)
  "Check PARSED-PARAMS for mutually exclusive parameter groups.
GROUPS is a list of lists of symbols, e.g. '((limit_results all_results)).
If parameters from the same group co-occur, the later ones are replaced
with <invalid-param> records."
  (map (match-lambda
         ((name . value)
          (if (invalid-param? value)
              (cons name value)
              (or
               (any (lambda (group)
                      (if (memq name group)
                          (let ((other-names
                                 (filter (lambda (other-name)
                                           (and (not (eq? name other-name))
                                                (assq other-name parsed-params)))
                                         group)))
                            (if (not (null? other-names))
                                (cons
                                 name
                                 (make-invalid-param
                                  value
                                  (string-append
                                   "cannot be specified along with "
                                   (string-join (map symbol->string
                                                     other-names)
                                                ", "))))
                                #f))
                          #f))
                    groups)
               (cons name value)))))
       parsed-params))

;;;
;;; Serialization
;;;

(define (params->query-string parsed-params)
  "Serialize PARSED-PARAMS back to a URI query string.
Skips invalid params.  Handles multi-value (list) entries.
Useful for building pagination links that preserve current filters."
  (define (value->text value)
    (cond
     ((eq? value #f) "")
     ((eq? value #t) "on")
     ((number? value) (number->string value))
     ((string? value) value)
     (else (object->string value))))

  (string-join
   (append-map
    (match-lambda
      ((_ . (? invalid-param?)) '())
      ((key . value)
       (if (list? value)
           (filter-map
            (lambda (v)
              (if (invalid-param? v)
                  #f
                  (string-append (uri-encode (symbol->string key))
                                 "="
                                 (uri-encode (value->text v)))))
            value)
           (list (string-append (uri-encode (symbol->string key))
                                "="
                                (uri-encode (value->text value)))))))
    parsed-params)
   "&"))