(use-modules (alterator http template)
             (alterator http html)

             (alterator configd woo)
             (alterator configd form)
	     (alterator configd translate)
             (alterator configd html))

(define (skip-scm scm url-args)
  (let ((head (cond-car scm)))
    (cond
      ((cond-assoc "async" url-args) scm)
      ((eq? head 'quote) (cdr scm))
      ((eq? head 'redirect) scm)
      (else #f))))

(define (scm-content scm name)
 (call-with-current-continuation
   (lambda(return)
    (template
      scm (tag: name (lambda (options content) (return content))))
    '())))

;;; menu tree
(define (html:menu-group group-name items)
  (html: "div"
	 (@ 'class "menu-group")
	 (html: "div"
		(@ 'class "menu-group-name") group-name)
	 items))

(define (html:menu-item item current)
  (html: "div"
	 (@ 'class (if current "menu-item-selected" "menu-item-normal"))
	 (html: "a" (@ 'href (woo-get-option item 'name))
                   (woo-get-option item 'label))))

(define (current-menu-item? item url)
  (string-prefix? (woo-get-option item 'name) url))

(define (menu-items url language)
  (let* ((help "index")
	 (title "System management center")
	 (items (map (lambda(group)
		       (html:menu-group
			 (cdr group)
			 (map (lambda(item)
				(let ((current (current-menu-item? item url)))
				  (if current
				    (begin (set! help (woo-get-option item 'help))
					   (set! title (woo-get-option item 'label))))
				  (html:menu-item item current)))
			      (woo-list (string-append "/menu/" (car group)) 'language language 'ui "html"))))
		     (woo-list/name+label "/menu" 'language language 'ui "html"))))
    (vector help title items)))

(define (help-tag url help)
  (replace-tag: "div"
		(@ 'class "help")
		(lambda (options content)
		  `(div ,@options
			,(@ 'style (format #f "visibility:~A;"
					   (if (string=? "/help" url) "hidden" "visible")))
			,(html: "a"
				(@ 'href (format #f "/help?topic=~A" help))
				content)))))

(define (menu-tag items)
  (tag: "div" (@ 'id "menu") items))

(define (main-tag scm)
  (and (pair? scm)
    (tag: "div" (@ 'id "main") (scm-content scm "body"))))

(define (title? x)
  (and (pair? x) (eq? (car x) 'title)))

(define (head-tag scm title)
  (and (pair? scm)
    (replace-tag: "head"
		  (lambda(options content)
		    (list 'head
			  (remove title? content)
			  (remove title? (scm-content scm "head"))
			  (html: "title" title))))))

(define (title-tag title)
    (tag: "span" (@ 'id "hostinfo") title))

(define (apply-po-domain scm po-domain)
  (if (string? po-domain)
    (template scm
	      (replace-tag: "html" (lambda (options content)
				     `(html ,@options ,@content
					    ,(@ 'po-domain po-domain)))))
    scm))

;;; main
(define (workflow-acc url url-args template-args)
  (let* ((scm (cond-assq 'scm template-args))
	 (scm2 (cond-assq 'scm2 template-args))
	 (po-domain (and (pair? scm2) (find-po-domain scm2)))
	 (language (cond-assoc "language" url-args '("en_US")))
	 (help+title+items (menu-items url language)))
    (or (skip-scm scm2 url-args)
       (apply-po-domain
	 (template scm
		   (help-tag url (vector-ref help+title+items 0))
		   (head-tag scm2 (vector-ref help+title+items 1))
		   (title-tag (vector-ref help+title+items 1))
		   (menu-tag (vector-ref help+title+items 2))
		   (main-tag scm2))
	 po-domain))))

(lambda (self objects options)
  (let ((url (string-append "/" (string-join objects "/")))
        (url-args (cond-plistq 'url-args options))
        (template-args (cond-plistq 'template-args options)))
    (list
     'scm
     (woo-catch
      (thunk (workflow-acc url url-args template-args))
      (html:exception url-args)))))

