gauche で json を post

gauche で json を受け取って json を返す cgi な api を書いてる時に、テスト用に書いたスクリプト。あまり楽になってない。

#! /usr/local/bin/gosh

(use rfc.json)
(use rfc.http)
(use rfc.uri :only (uri-encode-string))
(use gauche.parseopt :only (let-args))
(use srfi-1 :only (pair-fold))

(define (main args)
  (print "args : " args)
  (let/cc abort
    (let-args (cdr args)
        ((help "u|usage" => (^ _ (usage abort)))
         (host "h|host=s" "hoge.com")
         (uri "i|uri=s" "/cgi-bin/test/post-json.cgi")
         (alist "a|alist=s" "((\"hoge\" . 1))")
         (param-name "p|param-name=s" "json")
         (method "m|method=s" "POST")
         (not-string? "s|key-is-not-string"))
      (let1 alist (read-from-string alist)
        (cond ((string=? method "POST")
               (let* ((al (if not-string?
                              (alist-key->string alist)
                              alist))
                      (body (post host uri param-name al)))
                 (default-print-body host uri param-name al body)))
              ((string=? method "GET")
               (let* ((param (alist->uri-param alist))
                      (body (get host uri alist)))
                 (default-print-body host uri "" alist body)))
              (else '???)))))
  0)

(define (default-print-body host uri param-name param body)
  (newline)
  (print "host\t\t: " host)
  (print "uri\t\t: " uri)
  (print "param\t\t: " param)
  (print "param name\t: " param-name)
  (print "response body\t: " body)
  (print "body -> alist\t: " (parse-json-string body)))

(define (get host uri alist)
  (receive (status header body)
      (http-get host (string-append uri (alist->uri-param alist)))
    body))

(define (post host uri param-name alist)
  (receive (status header body)
      (http-post host uri
                 (string-append
                  param-name "="
                  (construct-json-string alist)))
    body))

(define (alist-key->string alist)
  (fold-right (^ (e acc)
                 (acons (x->string (car e))
                        (if (list? (cdr e))
                            (alist-key->string (cdr e))
                            (cdr e))
                        acc))
              '() alist))

(define (alist->uri-param alist)
  (let1 ues (^v (uri-encode-string (x->string v)))
    (pair-fold (^ (pr acc)
                  (let1 e (car pr)
                    (string-append
                     acc
                     (ues (car e)) "=" (ues (cdr e))
                     (if (null? (cdr pr))
                         ""
                         "&")
                     )))
               "?" alist)))

(define (usage abort)
  (abort))

使い方はこんな感じ。

$ gosh pjc.scm -h hogehoge.com -s -a "((\"hoge\" . 1))" -m POST -i /cgi-bin/api/insert-hoge.scm

$ gosh pjc.scm -h hogehoge.com -s -a "((\"fuga\" . 11))" -m POST -i /cgi-bin/api/begin-fuga.scm

$ $ gosh pjc.scm -h hogehoge.com -s -m GET -i /cgi-bin/api/get-bar.scm

初めて書いた cgi スクリプト。その言語が scheme って結構レアじゃないか。

追記

これwgetで間に合うんじゃね