#lang scheme/base

(require (file "util.scm")
         (lib "xml.ss" "xml")
         (lib "url.ss" "net")
         (planet "web.scm" ("soegaard" "web.plt" 2 1))
         )

(provide request-all-bindings
         remove-group-tags
         xexpr->de-grouped-xexprs
         wrap-each-in-list
         wrap-each-in-list-with-attrs
         redirect-to
         web-link
         raw-str
         with-binding ; from web.plt
         list-response
         )

(define (list-response content-lst #:type (type #"text/html") #:extras (extras '()))
  (make-response/full 200 "all good" (current-seconds) type extras
                      (append-map (lambda (content)
                                    (map xexpr->string (xexpr->de-grouped-xexprs content)))
                                  content-lst)))

;; if you are doing a post, this gives you post and get vars.  if a get, it's just reg.
(define (request-all-bindings req)
  (append (request-bindings req)
          (if (request-post-data/raw req) ; there a better way to check if it's a post?
              (url-query (request-uri req))
              '())))

(define (group-tag? xexpr)
  (match xexpr ((list-rest 'group children) #t) (else #f)))

(define (remove-group-tags xexpr)
  (let ((result (xexpr->de-grouped-xexprs xexpr)))
    (if (length= result 1)
          (first result)
          (e "Cannot remove-group-tags because I found ~A exprs in ~A. Expected just one."
             (length result) result))))

(define (xexpr->de-grouped-xexprs xexpr)
  (cond ((not xexpr) '())
        ((not (list? xexpr)) (list xexpr))
        ((group-tag? xexpr) (append-map xexpr->de-grouped-xexprs (rest xexpr)))
          (else (receive (tag attrs children) (xexpr->tag*attrs*children xexpr)
                  (list (create-xexpr tag attrs
                                      (append-map xexpr->de-grouped-xexprs children)))))))

(define (attrs? thing)
  (and (list? thing)
       (or (empty? thing) (not (symbol? (first thing))))))

(define (create-xexpr tag attrs children)
  (if (empty? attrs)
      `(,tag ,@children)
      `(,tag ,attrs ,@children)))

(define (xexpr->tag*attrs*children xexpr)
    (let ((tag (first xexpr))
          (but-tag (rest xexpr)))
      (if (empty? but-tag)
          (values tag '() '())
          (let ((next (first but-tag)))
            (if (attrs? next)
                (values tag next (rest but-tag))
                (values tag '() but-tag))))))

;; the wrap-each-in* fns filter out #f values from elts: 
(define (wrap-each-in-list tag elts)
  (filter-map (lambda (e) (and e `(,tag ,e))) elts))

(define (wrap-each-in-list-with-attrs tag attrs elts)
  (filter-map (lambda (e) (and e `(,tag ,attrs ,e))) elts))

(define (web-link label url #:class (class #f) #:extra-attrs (extra-attrs '()))
  `(a ((href ,url) ,@(append (if class `((class ,class)) '())
                             extra-attrs))
      ,label))

(define (raw-str str)
  (make-cdata #f #f str))