Revision: 6131
Author: iratqq
Date: Thu Dec 31 15:51:15 2009
Log: * scm/uim-pref-http.scm:
- New file.
- This module has not work yet (get only).
http://code.google.com/p/uim/source/detail?r=6131
Added:
/trunk/scm/uim-pref-http.scm
=======================================
--- /dev/null
+++ /trunk/scm/uim-pref-http.scm Thu Dec 31 15:51:15 2009
@@ -0,0 +1,238 @@
+;;;
+;;; Copyright (c) 2010 uim Project http://code.google.com/p/uim/
+;;;
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 3. Neither the name of authors nor the names of its contributors
+;;; may be used to endorse or promote products derived from this
software
+;;; without specific prior written permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
``AS IS'' AND
+;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
CONTRIBUTORS BE LIABLE
+;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
STRICT
+;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY
WAY
+;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+;;; SUCH DAMAGE.
+;;;;
+
+(module-load "custom-enabler")
+
+(define (write-tree tree out)
+ (let loop ((tree tree))
+ (cond ((null? tree))
+ ((pair? tree) (write-tree (car tree) out) (loop (cdr tree)))
+ (else (display tree out)))))
+
+(define (tree->string tree)
+ (call-with-output-string
+ (lambda (port)
+ (write-tree tree port))))
+
+(define (uim-pref-http:make-primary-group-sxml)
+ `(div (% (id "menu"))
+ (ul
+ ,@(map (lambda (g)
+ `(li
+ (a (% (href ,(format "/~a" (symbol->string g))))
+ ,(ugettext (custom-group-label g)))))
+ (custom-list-primary-groups)))))
+
+
+(define uim-pref-http:menu
+ (uim-pref-http:make-primary-group-sxml))
+
+(define (uim-pref-http:top-page resource req-header req-body)
+ (tree->string
+ (sxml:sxml->xml
+ `(html
+ (title "uim setup")
+ (body
+ (h1 "uim setup")
+ ,uim-pref-http:menu)))))
+
+(define (uim-pref-http:make-item-boolean group sub csym)
+ (let* ((rec (custom-rec csym))
+ (types (custom-rec-type rec))
+ (type (car types))
+ (active? (custom-active? csym))
+ (input-attribute `(% (type "checkbox")
+ (name ,(symbol->string csym))
+ (value ,(symbol->string csym))
+ ,(if (custom-value csym)
+ '(checked "checked")
+ '(id "nochecked")))))
+ `(input ,(if active?
+ input-attribute
+ (append input-attribute '((disabled "disabled"))))
+ ,(ugettext (custom-rec-label rec)))))
+
+(define (uim-pref-http:integer-length num)
+ (+ (string-length (number->string num)) 1))
+(define (uim-pref-http:make-item-integer group sub csym)
+ (let* ((rec (custom-rec csym))
+ (types (custom-rec-type rec))
+ (type (car types))
+ (active? (custom-active? csym))
+ (input-attribute `(% (type "text")
+ (name ,(symbol->string csym))
+ (value ,(number->string (custom-value csym)))
+ (size ,(number->string
+ (uim-pref-http:integer-length
(list-ref types 2)))))))
+ `(,(ugettext (custom-rec-label rec)) ": "
+ (input ,(if active?
+ input-attribute
+ (append input-attribute '((disabled "disabled"))))))))
+
+(define (uim-pref-http:make-item-string group sub csym)
+ (let* ((rec (custom-rec csym))
+ (types (custom-rec-type rec))
+ (type (car types))
+ (active? (custom-active? csym))
+ (input-attribute `(% (type "text")
+ (name ,(symbol->string csym))
+ (value ,(custom-value csym)))))
+ `(,(ugettext (custom-rec-label rec)) ": "
+ (input ,(if active?
+ input-attribute
+ (append input-attribute '((disabled "disabled"))))))))
+
+(define (uim-pref-http:make-item-pathname group sub csym)
+ (let* ((rec (custom-rec csym))
+ (types (custom-rec-type rec))
+ (type (car types))
+ (active? (custom-active? csym))
+ (input-attribute `(% (type "text")
+ (name ,(symbol->string csym))
+ (value ,(custom-value csym)))))
+ `(,(ugettext (custom-rec-label rec)) ": "
+ (input ,(if active?
+ input-attribute
+ (append input-attribute '((disabled "disabled"))))))))
+
+(define (uim-pref-http:make-item-choice group sub csym)
+ (let* ((rec (custom-rec csym))
+ (types (custom-rec-type rec))
+ (type (car types))
+ (choiced (custom-value csym))
+ (active? (custom-active? csym))
+ (select-attribute `(% (name ,(symbol->string csym)))))
+ `(,(ugettext (custom-rec-label rec)) ": "
+ (select ,(if active?
+ select-attribute
+ (append select-attribute '((disabled "disabled"))))
+ ,(map (lambda (opt)
+ `(option ,(if (eq? choiced (list-ref opt 0))
+ '(% (selected "selected"))
+ "")
+ ,(ugettext (list-ref opt 1))))
+ (cdr types))))))
+
+(define (uim-pref-http:make-item-ordered-list group sub csym)
+ (let* ((rec (custom-rec csym))
+ (types (custom-rec-type rec))
+ (type (car types))
+ (text (apply string-append
+ (map (lambda (x)
+ (string-append (write-to-string
(symbol->string x)) " "))
+ (custom-value csym))))
+ (active? (custom-active? csym))
+ (input-attribute `(% (type "text")
+ (name ,(symbol->string csym))
+ (value ,text))))
+ `(,(ugettext (custom-rec-label rec)) ": "
+ (input ,(if active?
+ input-attribute
+ (append input-attribute '((disabled "disabled"))))))))
+
+(define (uim-pref-http:make-item-key group sub csym)
+ (let* ((rec (custom-rec csym))
+ (types (custom-rec-type rec))
+ (type (car types))
+ (text (apply string-append
+ (map (lambda (x)
+ (string-append (write-to-string x) " "))
+ (custom-value csym))))
+ (active? (custom-active? csym))
+ (input-attribute `(% (type "text")
+ (name ,(symbol->string csym))
+ (value ,text))))
+ `(,(ugettext (custom-rec-label rec)) ": "
+ (input ,(if active?
+ input-attribute
+ (append input-attribute '((disabled "disabled"))))))))
+
+(define (uim-pref-http:make-item group sub csym)
+ (let* ((rec (custom-rec csym))
+ (types (custom-rec-type rec))
+ (type (car types)))
+ `(li
+ ,(cond ((eq? type 'boolean)
+ (uim-pref-http:make-item-boolean group sub csym))
+ ((eq? type 'integer)
+ (uim-pref-http:make-item-integer group sub csym))
+ ((eq? type 'string)
+ (uim-pref-http:make-item-string group sub csym))
+ ((eq? type 'pathname)
+ (uim-pref-http:make-item-pathname group sub csym))
+ ((eq? type 'choice)
+ (uim-pref-http:make-item-choice group sub csym))
+ ((eq? type 'ordered-list)
+ (uim-pref-http:make-item-ordered-list group sub csym))
+ ((eq? type 'key)
+ (uim-pref-http:make-item-key group sub csym))
+ (else
+ (format "~a: not supported widget"
+ (ugettext (custom-rec-label rec))))))))
+
+
+(define (uim-pref-http:make-contents-page group sub)
+ `(div (% (id "entry"))
+ (h2 ,(ugettext (custom-group-label sub)))
+ (form (% (method "post") (action ,(symbol->string group)))
+ (ul
+ ,(map (lambda (csym)
+ (uim-pref-http:make-item group sub csym))
+ (custom-collect-by-group group sub)))
+ (input (% (type "submit") (value "set"))))))
+
+(define (uim-pref-http:regist-pages server)
+ (for-each (lambda (group)
+ (http-server-regist-resource!
+ server
+ (format "/~a" (symbol->string group))
+ (lambda (resource req-header req-body)
+ ;; (print (format "resource:~a header:~a body:~a"
resource req-header req-body))
+ (tree->string
+ (sxml:sxml->xml
+ `(html
+ (title ,(format "uim setup: ~a" (ugettext
(custom-group-label group))))
+ (body
+ (h1 (format "uim setup: " ,(ugettext
(custom-group-label group))))
+ ,uim-pref-http:menu
+ (div (% (id "contents"))
+ ,(map (lambda (sub)
+ (uim-pref-http:make-contents-page group
sub))
+ (custom-group-subgroups group))))))))))
+ (custom-list-primary-groups)))
+
+
+(define (uim-http-server:start args)
+ (let ((server (make-http-server)))
+ (http-server-regist-resource! server "/" uim-pref-http:top-page)
+ (uim-pref-http:regist-pages server)
+ (http-server-resource server)
+ (http-server-start server "localhost" 8569)
+ 1))
