えんどう

えんどうやすゆき

Chaton Radar

chaton.client使用版

#!/usr/bin/env gosh

(use chaton.client)
(use gauche.parameter)
(use gauche.parseopt)
(use gauche.process)
(use gauche.threads)
(use util.list)
(use util.match)

(define-class <chaton-config> ()
   ((client :init-keyword :client
            :accessor client-of :init-value #f)
    (url    :init-keyword :url
            :accessor url-of :init-value #f)
    (npath   :init-keyword :npath
             :accessor npath-of :init-value #f)
    (ipath   :init-keyword :ipath
             :accessor ipath-of :init-value #f)))

(define *chaton-config*
  (make-parameter
   (make <chaton-config> :client "ChatonRadar"
         :url "http://practical-scheme.net/chaton/gauche"
         :npath "/usr/local/bin/growlnotify"
         :ipath "/Users/yasuyuki/Downloads/chaton-room-gauche.gif")))

(define (send-notify npath ipath title message)
  (process-output->string
   (list #?=npath "--image" #?=ipath "-t" #?=title "-m" #?=message)))

(define (radar-handler response)
  (when (pair? response)
    (let1 content (assoc-ref response 'content)
      (match content [((name (sec mil) body) ... )
                      (for-each (cut send-notify
                                     (npath-of (*chaton-config*))
                                     (ipath-of (*chaton-config*)) <> <>)
                                name body)])))
  #f)

(define (show-help progname)
  (print #`",|progname| [-c conf-file]"))

(define (read-config cfile)
  (let* ((sx (and cfile (call-with-input-file cfile (cut read <>))))
         (url (and sx (assoc-ref sx 'url)))
         (npath (and sx (assoc-ref sx 'npath)))
         (ipath (and sx (assoc-ref sx 'ipath)))
         (conf (*chaton-config*)))
    (when url (set! (url-of conf) url))
    (when npath (set! (npath-of conf) npath))
    (when ipath (set! (ipath-of conf) ipath))
    (*chaton-config* conf)))

(define (main args)
  (let-args (cdr args)
      ((cfile "c|conf=s" => (cut read-config <>))
       (help  "h|help" => (cut show-help <>)))
    (let1 client (chaton-connect
                  (url-of (*chaton-config*))
                  (client-of (*chaton-config*))
                  radar-handler)
      (thread-join! (ref client 'observer-thread)))))

初期バージョン

#!/usr/bin/env gosh

(use gauche.parameter)
(use gauche.parseopt)
(use gauche.process)
(use rfc.http)
(use rfc.uri)
(use srfi-27)
(use text.tree)
(use util.list)
(use util.match)

(define-class <chaton-config> ()
   ((client :init-keyword :client
            :accessor client-of :init-value #f)
    (url    :init-keyword :url
            :accessor url-of :init-value #f)
    (login  :init-keyword :login
            :accessor login-of :init-value #f)
    (npath   :init-keyword :npath
             :accessor npath-of :init-value #f)
    (ipath   :init-keyword :ipath
             :accessor ipath-of :init-value #f)))

(define *chaton-config*
  (make-parameter
   (make <chaton-config> :client "ChatonRader"
         :url "http://practical-scheme.net/chaton/gauche"
         :login "http://practical-scheme.net/chaton/gauche/apilogin"
         :npath "/usr/local/bin/growlnotify"
         :ipath "/Users/yasuyuki/Downloads/chaton-room-gauche.gif")))

(define (make-mime alist)
  (let1 boundary (format "boundary-~a"
                         (number->string (* (random-integer (expt 2 64))
                                            (sys-time) (sys-getpid))
                                         36))
    (values (tree->string
             `(,(map (lambda (k&v)
                       `("\r\n--",boundary"\r\n"
                         "Content-disposition: form-data; name=\"",(car k&v)"\"\r\n\r\n"
                         ,(x->string (cdr k&v))))
                     alist)
               "\r\n--",boundary"--\r\n"))
            boundary)))

(define (POST room-url uri params)
  (receive (host path) (host&path uri)
    (receive (body boundary) (make-mime params)
      (receive (status hdrs body)
          (http-post host path body
                     :mime-version "1.0"
                     :content-type #`"multipart/form-data; boundary=,boundary")
        (unless (equal? status "200")
          (cerrf room-url "POST to ~a failed with ~a" uri status))
        (safe-parse room-url body)))))

(define (host&path uri)
  (receive (scheme specific) (uri-scheme&specific uri)
    (receive (host path q f) (uri-decompose-hierarchical specific)
      (values host path))))

(define (safe-parse room-url text)
  (guard (e [(<read-error> e)
             (cerrf room-url "invalid reply from server: ~s" reply)])
    ;;(print text)
    (read-from-string text)))

(define (cerrf room-url fmt . args)
  (apply errorf <chaton-error> :room-url room-url fmt args))

(define-condition-type <chaton-error> <error>
  (room-url #f))

(define (send-notify config name body)
  (let ((client (client-of config))
        (npath (npath-of config))
        (ipath (ipath-of config)))
    (process-output->string
     (list npath "-t" name "-m" body))))

(define (fetch comet-uri pos cid)
  (receive (host path) (host&path comet-uri)
    (receive (code head body)
        (http-get host #`",|path|?s=1&t=,(sys-time)&p=,|pos|&c=,|cid|")
      (let* ((sx (call-with-input-string body (cut read <>)))
             (pos2 (assoc-ref sx 'pos))
             (cid2 (assoc-ref sx 'cid))
             (text (assoc-ref sx 'text)))
        (match text
               [((name (sec mil) body) ...)
                (for-each
                 (cut send-notify (*chaton-config*) <> <>)
                 name body)])
        (fetch comet-uri pos2 cid2)))))

(define (show-help progname)
  (print #`",|progname| [-c conf-file]"))

(define (read-config cfile)
  (let* ((sx (and cfile (call-with-input-file cfile (cut read <>))))
         (url (and sx (assoc-ref sx 'url)))
         (login (and sx (assoc-ref sx 'login)))
         (npath (and sx (assoc-ref sx 'npath)))
         (ipath (and sx (assoc-ref sx 'ipath)))
         (conf (*chaton-config*)))
    (when url (set! (url-of conf) url))
    (when login (set! (login-of conf) login))
    (when npath (set! (npath-of conf) npath))
    (when ipath (set! (ipath-of conf) ipath))
    (*chaton-config* conf)))

(define (main args)
  (let-args (cdr args)
      ((cfile "c|conf=s" => (cut read-config <>))
       (help  "h|help" => (cut show-help <>)))
    (and-let* ((sx (POST (url-of (*chaton-config*))
                         (login-of (*chaton-config*))
                         (list (cons "who" (client-of (*chaton-config*))))))
               (post-uri #?=(assoc-ref sx 'post-uri))
               (comet-uri #?=(assoc-ref sx 'comet-uri))
               (cid (assoc-ref sx 'cid))
               (pos (assoc-ref sx 'pos)))
      (fetch comet-uri pos cid))))

ex. chaton-chaton.conf

((url . "http://practical-scheme.net/chaton/chaton")
 (login . "http://practical-scheme.net/chaton/chaton/apilogin"))

Gauche:LLRing2006

LL Ring 2006へのネタ出し

あれこれ

Gauche:NSIS
Gauche:遺伝的アルゴリズム
Gauche:EPIA VIA EPIA PD6000E/Debian serge/kernel-image-2.6.8-1-386でのGaucheコンパイル
DBI/DBD RDBMSへのAPIを抽象化するライブラリ
Gauche:define-struct PLTやBiglooのdefine-structを実現するマクロ(from shiroさん)
Gauche:opt-lambda PLTのopt-lambdaを実現するマクロ(from shiroさん)
Gauche-devel-jp: SchemeQLをGaucheで使ってみました

セミナーやります。

セミナー終了後に有志で懇親会を開催します。詳しくは party@kahua.org にお問い合わせください。

アプリケーションサーバフレームワーク Kahua セミナー

Kahuaプロジェクトでは、IPAの「オープンソフトウエア活用基盤整備事業」の支援を受けて、アプリケーションサーバフレームワークKahuaを開発しています。

当セミナーでは、kahuaの基盤となるオープンソースのScheme処理系Gaucheと Kahuaについて、Kahuaの基本コンセプトである「継続ベースの Web アプリケーション」を中心に据えて、デモと解説をご覧いただきます。

日時・場所

2004年2月13日(金) 13:30〜16:30 (受付開始 13:00)

東京都文京区本駒込文京グリーンコート 16階 IPA 第三第四会議室 (地図)

最寄駅

都営三田線「千石駅」（A1又はA3出口）徒歩4 分
JR山手線「駒込駅」徒歩10分
JR山手線「巣鴨駅」徒歩12分

定員

50名

参加費

無料

講師

川合史朗 http://www.shiro.dreamhost.com/scheme/
やましたのぶお http://www.sampou.org/

プログラム

13:00 受付開始
13:30〜14:20 GaucheによるSchemeプログラミング入門(川合)
14:20〜14:30 休憩
14:30〜15:20 継続ベースのWebアプリケーションの原理(川合)
15:20〜15:30 休憩
15:30〜16:20 アプリケーションサーバフレームワークKahuaの紹介(やました)
16:20〜16:30 質疑応答

申し込み期間

2004年2月12日(木)まで (ただし、定員になり次第締め切ります)

参加申し込み

下記の内容を必ずご記入のうえ、セミナー告知ページの申込フォームで送信するか、 seminar@kahua.orgまでお送りください。

お名前
メールアドレス
参加人数
Schemeでプログラムを書いたことがありますか？

セミナー告知ページ

http://www.kahua.org/cgi-bin/kahua.cgi/kahua-web/show/news/Seminar

お問い合わせ

Kahuaプロジェクト info@kahua.org

Last modified : 2009/05/17 17:38:54 PDT