garaemon.net

to "| /home/username/bin/image-paste.scm | mailbot -t /home/username/misc/reply -A 'From: mail-account@username.net' /usr/sbin/sendmail -t; chmod 644 /home/username/www/images/image-paste/*; rm /home/username/misc/reply "
exit

#!/home/username/bin/gosh
 
(use gauche.regexp)
(use gauche.charconv)
(use rfc.822)
(use rfc.mime)
(use srfi-1)
(use srfi-13)
(use srfi-19)
(use util.list)
(use text.tree)
(use text.html-lite)
(use file.util)
 
(define *reply-fname* "/home/username/misc/reply")
(define *image-dir* "/home/username/www/images/image-paste/")
(define *html-dir* "/home/username/www/images/image-paste/")
(define *url-root* "http://username.net")
(define *www-root* "/home/username/www")
 
(define (make-reply fname html-file)
  (let ((port (open-output-file fname :if-exists :append
                                      :if-does-not-exist :create)))
    (format port "automaticaly created ~A~%" html-file)
    (close-output-port port)
    #t))
 
(define (make-error-reply fname)
  (let ((port (open-output-file fname :if-exists :append
                                      :if-does-not-exist :create)))
    (format port "no image was found~%")
    (close-output-port port)
    #t))
 
(define (message-handle from subject part xport)
  (let ((image-dir *image-dir*)
        (html-dir *html-dir*)
        (reply-fname *reply-fname*))
    (let ((type (slot-ref part 'type)))
      (if (string=? type "image")
          (let ((prefix (x->string (time-second (current-time))))
                (suffix (rxmatch-after
                         (rxmatch #/\./ (cdr (assoc "name" (slot-ref part 'parameters) string=?))))))
            (let ((image-file-name (string-concatenate (list image-dir prefix "." suffix)))
                  (html-file-name (string-concatenate (list html-dir prefix ".html"))))
              ;; jpgファイルを書き出す
              (let ((oport (open-output-file image-file-name)))
                (mime-retrieve-body part xport oport)
                (close-output-port oport)
                )
              ;; 対応するhtmlファイルを作る
              (let ((tree (make-html-tree (regexp-replace-all (string->regexp *www-root*) image-file-name "") from subject)))
                (let ((oport (open-output-file html-file-name)))
                  (write-tree tree oport)
                  (close-output-port oport))
                )
              ;; 返信用の文章をつくる
              (make-reply reply-fname (regexp-replace-all (string->regexp *www-root*) html-file-name *url-root*))
              ))
        (mime-body->string part xport)))))
 
(define (make-html-tree ifname from subject)
  (list
   (html-doctype :type :html-4.01)
   (html:html
    (html:head
     (html:meta :http-equiv "Content-Type" :content "text/html; charset=UTF-8")
     (html:title (string-concatenate (map html-escape-string (list "image paste ::" subject)))))
    (html:body :lang "ja"
               :bgcolor "#ffffff"
               :text "#000000"
               :link "#0000ff"
               :vlink "#800080"
               :alink "#ff0000"
               (html:div
                (html:h3 (string-concatenate (map html-escape-string (list "from::" (regexp-replace-all #/@/ from "__at__")))))
                (html:h3 (string-concatenate (map html-escape-string (list "subject::" subject)))))
               (html:a
                :href ifname
                (html:img :border "0"
                         :src ifname
                         :alt ifname))
               )
    )))
 
(define (main args)
  (let ((port (standard-input-port)))
    (let ((headers (rfc822-read-headers port)))
      (if (mime-parse-version (rfc822-header-ref headers "mime-version"))
 
          (let ((from (rfc822-header-ref headers "from"))
                (subject (rfc822-header-ref headers "subject")))
            (mime-parse-message port headers (cut message-handle from subject <> <>))))
      ;; めんどうなのでreplyがあるかチェックしてなかったらエラー用のものを作る
      (if (not (file-is-readable? *reply-fname*))
          (make-error-reply *reply-fname*))
      (rfc822-write-headers headers)
      )))