#lang scheme/base

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

(provide request-all-bindings
         final-prep-of-response
         xexpr->de-grouped-xexprs
         wrap-each-in-list
         wrap-each-in-list-with-attrs
         redirect-to
         web-link
         img
         raw-str
         with-binding ; from web.plt
         list-response
         basic-response
         xexpr-if
         url+query
         url->string
         get-url
         )

(define (list-response content-lst #:type (type #"text/html") #:extras (extras '()))
  (basic-response (append-map (lambda (content) (map xexpr->string
                                                     (xexpr->de-grouped-xexprs content)))
                              content-lst)
                  #:type type
                  #:extras extras))

(define (basic-response content-lst #:type (type #"text/html") #:extras (extras '()))
  ;; right now we always no-cache.  we'll probably eventually want something more
  ;; subtle.
  (let ((no-cache (make-header #"Cache-Control" (string->bytes/utf-8 "no-cache;"))))
    (make-response/full 200 "all good" (current-seconds)
                        type (cons no-cache extras)
                        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 (final-prep-of-response xexpr-or-response)
  (let ((result (xexpr->de-grouped-xexprs xexpr-or-response)))
    (if (and (length= result 1) (response? (first result)))
        (first result)
        (list-response 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 ,(if (string? url) url (url->string url)))
       ,@(append (if class `((class ,class)) '()) extra-attrs))
      ,label))

;; image-file is relative to /i/
(define (img image-file #:class (class #f))
  `(img ((src ,(string-append "/i/" image-file)) (border "0")
         ,@(splice-if class `(class ,class)))))

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

;;
;; xexpr-if
;;
;; Use if you only want to create an xexpr if a condition is true.  E.g.,
;;  (ul (li "Item 1") ,(xexpr-if (= 2 2) `(li "Item 2")))
;;
(define-syntax xexpr-if
  (syntax-rules ()
    ((_ test)
     (or test ""))
    ((_ test body ...)
     (if test (begin body ...) ""))))

;;
;; url+query
;;
;; query-alist is ((key . str) ...)
;; given query strs should *not* be url encoded (this will be done by url+query).
;;
(define (url+query url-str query-alist)
  (let ((tmp-url (string->url url-str)))
    (make-url (url-scheme tmp-url)
              (url-user tmp-url)
              (url-host tmp-url)
              (url-port tmp-url)
              (url-path-absolute? tmp-url)
              (url-path tmp-url)
              (append (url-query tmp-url) query-alist)
              (url-fragment tmp-url))))

;;
;; get-url
;;
;; exn-handler: exn -> any
;;
(define (get-url url port-handler #:exn-handler (exn-handler #f))
  (let ((thunk (lambda () (call/input-url (if (url? url) url (string->url url))
                                          get-pure-port
                                          port-handler))))

    (if exn-handler
        (with-handlers ((exn:fail:network? exn-handler)) (thunk))
        (thunk))))