#lang scheme/base

(require (file "util.scm")
         (file "repository.scm")
         (file "record.scm")
         (file "closures.scm")
         (file "web-support.scm")
         (planet "web.scm" ("soegaard" "web.plt" 2 1))
         (lib "" "net"))

(provide form

(define-struct form-obj (markup id))
(define form-id form-obj-id)
(define form-markup form-obj-markup)

;; the call-back : bindings-from-form -> content
;; does not save any records
(define (grab-user-input fields call-back
                         #:submit-label (submit-label "Submit")
                         #:init (init '())
                         #:skip-br (skip-br #f)
                         #:stay-on-same-page (stay-on-same-page #f))
  (form fields
        #:on-done (lambda (r) (call-back (rec-data r)))
        #:stay-on-same-page stay-on-same-page
        #:submit-label submit-label
        #:skip-save #t
        #:skip-br skip-br
        #:init init))

;; form
;; Example:
;; (form '((title "Title" text) (content "Post" long-text))
;;       #:init '((type . meta-made-data) (kind . text))
;;       #:submit-label "Add post"
;;       #:before-save (lambda (r) ...)
;;       #:on-done (lambda (r) "all done"))
;; * fields: a list of lists.  each sublist is of the form (title "Title" text).
;;     the field name (the first elt of the sub-list) must
;;     match what you want the prop name of the record to be.
;; * init: same form as previous, but provide fixed/default values for record props.
;;         You also can use init as a way of "editing".  This happens if you provide
;;         init values for fields of the form.
;;         You can also provide a record to init in which case the record is used instead
;;         of making a fresh one.
;; * submit-label: the label for the submit button of the form.
;; * before-save: a fn : rec -> / which lets you do something with r before it's saved.
;;     this is run even if skip-save=#t.
;; * on-done: this is a fn : rec -> content
;; * skip-save: set to #t if you don't want to save (on-done thunk is still executed)
;; * fail: a fn; if evals to non-#f, then return it as the answer.
;; * validate: like fail, but if returns a non-#f value then stick it in a div above
;;   the form, re-populating the form with what you typed in (i.e., fn should return
;;   an error message).
;; * use-if-exists: if set to a property name, then don't create a fresh record
;;    if there's already one that's equal to it. (XXX bad name)
;; * stamp-user: if a rec is given then assume it's a user rec and stamp it on the record
;;   in the created-by property.
;; * stamp-time: if non-#f, then stamp the current time for the created_at property.
;;    default is #t
;; * return-form-obj: returns a form struct instead of raw form markup.
;; "form" is defined just below "form-aux".
(define (form-aux fields
                  #:recur recur ; provided automatically by form
                  #:init (init '())
                  #:submit-label (submit-label "Save")
                  #:before-save (before-save (lambda (r) 'done))
                  #:skip-save (skip-save #f)
                  #:stamp-user (stamp-user #f)
                  #:stamp-time (stamp-time #t)
                  #:stay-on-same-page (stay-on-same-page #f)
                  #:fail (fail (lambda (rec) #f))
                  #:validate (validate (lambda (rec) #f))
                  #:error-wrapper (error-wrapper default-error-wrapper)
                  #:error-msg (error-msg #f)
                  #:on-submit (on-submit #f) ; #f or a JS string
                  #:use-if-exists (use-if-exists #f)
                  #:skip-br (skip-br #f)
                  #:class (css-class #f)
                  #:auto-submit (auto-submit #f)
                  #:return-form-obj (return-form-obj #f)
                  #:on-done (on-done (lambda (rec) (redirect-to (setting *WEB_APP_URL*)))))
  (let ((init-data (if (rec? init) (rec-data init) init))
        (is-upload (has-upload-field? fields)))
    ;; attempt to save the rec that's presumably in the request as generated by the form:
    (define (store-form-rec! req)
      (let* ((bindings (request-bindings req))
             ;; note that if a field is specified but not present in bindings,
             ;; it gets a #f assigned to it:
              (map (match-lambda ((list name label type)
                                  (cons name (field-value-lift (assoc-val name bindings)
             (data (alist-merge init-data relevant-req-bindings))
             (a-rec (if (rec? init)
                        (update-edited-rec-with-merge! init data fields)
                        (fresh-rec-from-data data #:stamp-time stamp-time)))
             (the-rec (or (and use-if-exists
                                `((,use-if-exists . ,(rec-prop a-rec use-if-exists)))))
        (when stamp-user (rec-set-rec-prop! the-rec 'created-by stamp-user))
        (or (fail the-rec)
            (aand (validate the-rec)
                  (let ((form-meat (recur #:init (append relevant-req-bindings init)
                                          #:error-msg it)))
                    (error-wrapper (if (form-obj? form-meat)
                                       (form-markup form-meat)
            (begin (before-save the-rec)
                   (unless skip-save (store-rec! the-rec))
                   (let ((finally (on-done the-rec)))
                     (if stay-on-same-page
                         (e "feature missing")
    (let* ((form-id (number->string (random 1000000)))
           (f `(form
                ((action "/")
                 (id ,form-id)
                 ,@(splice-if css-class `(class ,css-class))
                 (method "post")
                 ;; XXX see this if pattern?
                 ,@(if is-upload '((enctype "multipart/form-data")) '())
                 ,@(if on-submit `((onsubmit ,on-submit)) '()))
                ,@(splice-if error-msg `(div ((class "errors")) ,error-msg))
                (input ((type "hidden")
                        (name ,(symbol->string (setting *CLOSURE_URL_KEY*)))
                        (value ,(body-as-closure-key (req) (store-form-rec! req)))))
                ,@(form-body fields submit-label init-data form-id
                             #:skip-br skip-br #:auto-submit auto-submit))))
      (if return-form-obj (make-form-obj f form-id) f))))

(define form (make-recursive-keyword-version-of-fn form-aux "recur"))

;; we refresh the rec-to-edit in case, e.g., a comment has come in.
;; we only update the relevant fields too (so we don't, e.g., overwrite a comment
;; that came in in the meanwhile.)
(define (update-edited-rec-with-merge! rec-to-edit new-data fields)
  (let ((field-names (map first fields)))
    (rec-set-each-prop! (refresh rec-to-edit)
                        (filter (lambda (k.v) (memq (car k.v) field-names))

(define (has-upload-field? fields)
  (any (lambda (f) (eq? (last f) 'image)) fields))

;; paint-field
;; Note that field-value is a "lifted" (Scheme) value.
(define (paint-field field-name field-type form-id
                     #:field-value (field-value #f) #:auto-submit (auto-submit #f))
  (let ((field-name (symbol->string field-name))
        (field-type-name (if (field-type? field-type)
                             (field-type-name field-type)
        (auto '(onchange "this.form.submit();")))
    (case field-type-name
       `(input ((type "text") (name ,field-name) (class "text-input") (size "40")
                (value ,(or field-value "")))))
       `(textarea ((name ,field-name) (class "text-input")
                   (cols "20") (rows "4")) ,(or field-value "")))
       `(input ((type "text") (name ,field-name) (size "5") (class "text-input")
                (value ,(or (and field-value (number->string field-value)) "")))))
       `(input ((type "password") (class "text-input") (name ,field-name))))
       `(input ((type "file") (name ,field-name))))
       (if field-value ; then it is checked
           `(span (input ((type "checkbox") (checked "yup") (name ,field-name)
                          (class "checkbox")
                          ,@(splice-if auto-submit auto)))
                  (input ((type "hidden") (name ,field-name) (value "off"))))
           `(input ((type "checkbox") (name ,field-name) (class "checkbox")
                    ,@(splice-if auto-submit auto)))))
       (generic-picker (field-type-params field-type)
                       (lambda (val disp is-selected)
                         `(tr (td (input ((type "radio") (name ,field-name) (value ,val)
                                          ,@(if is-selected `((checked "yup")) '()))))
                              (td ,@disp)))
                       (lambda (elts) `(table ((class "big-radio")) ,@elts))
                       #:current-pick field-value))
       `(group ,(generic-picker (field-type-params field-type)
                                (lambda (val disp is-selected)
                                  `(option ((value ,val)
                                            ,@(if is-selected `((selected "yup")) '()))
                                (lambda (elts) `(select ((name ,field-name)) ,@elts))
                                #:current-pick field-value)
      (else (error (format "Field type '~A' for field '~A' not understood."
                           field-type field-name))))))

;; elt-wrapper : val-str X display X is-selected -> content
;; whole-wrapper : list(elt-content) -> content
(define (generic-picker sym.=>display elt-wrapper whole-wrapper
                        #:current-pick (current-pick #f))
  (whole-wrapper (map (match-lambda ((list-rest sym disp)
                                     (elt-wrapper (symbol->string sym)
                                                  (eq? sym current-pick))))

;; go from form value to Scheme value
(define (field-value-lift field-val field-type)
  (case field-type
     (if (equal? field-val "on") #t #f))
     (if (string=? field-val "") #f (string->number field-val)))
     (save-uploaded-file! field-val))
    (else (if (and (string? field-val) (string=? field-val ""))

(define (save-uploaded-file! raw-file-bytes)
  ;; XXX assuming it's JPG ... should use the real filename here, but don't
  ;; know how.
  (let ((filename (format "~A.jpg" (random-key-string 10))))
    (write-bytes raw-file-bytes
                 (open-output-file (format "../htdocs/img/usr/~A" filename) 'error))

(define (paint-rich-text-editor field-name field-value form-id)
  `(div ((class "yui-skin-sam"))
        (textarea ((name ,field-name) (id ,field-name) (cols "50") (rows "10"))
        (script ,(format "render_rich_text_editor('~A', '~A')" field-name form-id))))

;; returns a list of html objects, so you'll need to splice in to the caller.
(define (form-body fields submit-label init-data form-id
                   #:skip-br (skip-br #f) #:auto-submit (auto-submit #f))
  (define (paint-segment field-name display-name field-type)
    (let* ((is-checkbox (eq? field-type 'checkbox))
           (lbl-inp-lst (list (if is-checkbox
                                  `(label ,display-name))
                              (paint-field field-name field-type form-id
                                           #:field-value (assoc-val field-name init-data)
                                           #:auto-submit auto-submit)
                              (if skip-br "" '(br)))))
      ;; we want the checkbox to come before the label:
      (when (and is-checkbox display-name (or (not (string? display-name))
                                              (not (string=? display-name ""))))
        (set! lbl-inp-lst (cons-to-end '(br) (reverse lbl-inp-lst))))
      `(group ,@lbl-inp-lst)))
   (map (match-lambda ((list field-name display-name field-type)
                       (paint-segment field-name display-name field-type)))
   `((input ((type "submit") (value ,submit-label))))))

(define-struct field-type (name params))

(define (default-error-wrapper form-meat)