Hunchentoot で2chブラウザを作ってみた

この程度でかなり苦労してしまった・・・

Win7 + CCL で動作してます。

参考>> HUNCHENTOOT - The Common Lisp web server formerly known as TBNL
参考>> CL-WHO - Yet another Lisp markup language
参考>> Common Lisp で Web アプリを作るためのブランクプロジェクト
参考>> (Lisperp sakuranbo) => t を目指す日記 会社から投稿テスト


UNIX板が見れます。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :hunchentoot)
  (require :cl-who)
  (require :drakma)
  (require :jp)
  (require :cl-ppcre))

(defpackage :web-sample
  (:use :cl :hunchentoot :cl-who :drakma :jp :cl-ppcre)
  (:shadow :COOKIE-VALUE
    :*HEADER-STREAM*
    :PARAMETER-ERROR
    :COOKIE-NAME
    :COOKIE-DOMAIN
    :COOKIE-PATH
    :COOKIE-EXPIRES)
  (:export #:start-server #:stop-server))

;;  参考
;;  Common Lisp で Web アプリを作るためのブランクプロジェクト
;;  http://read-eval-print.blogspot.com/2011/02/common-lisp-web.html

(in-package :web-sample)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 環境設定
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter *default-directory*
  (pathname (directory-namestring #.(or *compile-file-truename*
                                        *load-truename*)))            "このファイルがあるディレクトリ")

(defparameter *js-path*  (merge-pathnames "js/" *default-directory*)   "JavaScript 用ディレクトリ")
(defparameter *css-path* (merge-pathnames "css/" *default-directory*) "スタイルシート用ディレクトリ")

(setf
 ;; for utf-8
 hunchentoot:*hunchentoot-default-external-format* (flexi-streams:make-external-format :utf-8)
 hunchentoot:*default-content-type* "text/html; charset=utf-8"
 ;; for debug
 hunchentoot:*catch-errors-p* nil)

(setf hunchentoot:*dispatch-table*
      (list
       'hunchentoot:dispatch-easy-handlers
       (hunchentoot:create-folder-dispatcher-and-handler "/css/" *css-path*)
       (hunchentoot:create-folder-dispatcher-and-handler "/js/" *js-path*)))




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 汎用関数
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar *port8080-acceptor* (make-instance 'hunchentoot:acceptor :port 8080))

(defun start-server ()
  "Web サーバ起動"
  (start *port8080-acceptor*))


(defun stop-server ()
  "Web サーバ停止"
  (stop *port8080-acceptor*))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; トップページ(2ch UNIX板のスレッド一覧)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; スレッド一覧を取得する
(defun get-thread-subject (url bkey)
  (jp:decode (http-request (concatenate 'string url bkey "/subject.txt") :force-binary t) :guess))

;; 取得したスレッドをリストに分解する
(defun make-thread-list (text)
  (mapcar #'(lambda (x) (cl-ppcre:split "<>" x))
   (cl-ppcre:split #\LineFeed text)))

;; スレッド一覧を表示するHTMLを構築
(defun make-thread-html (list url bkey)
  (with-html-output-to-string (*standard-output* nil :indent t)
    (:html (:head (:title "スレ一覧")
    (:script))
    (:body
     (loop for (dat title) in list
        do (htm (:a :href (concatenate 'string "thread?"
           "dat=" (url-encode dat)
           "&url=" (url-encode url)
           "&bkey=" (url-encode bkey))
           :target "_blank" (str title)) :br))))))

(defun index-html (url bkey)
  ""
  (make-thread-html (make-thread-list (get-thread-subject url bkey)) url bkey))

(define-easy-handler (index :uri "/index") ()
  (setf (hunchentoot:content-type*) "text/html; charset=utf-8")
  (index-html "http://hibari.2ch.net/" "unix"))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; スレッドビュー
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass res ()
  ((num   :initarg :num)
   (name  :initarg :name)
   (mail  :initarg :mail)
   (date  :initarg :date)
   (text  :initarg :text)))


(defun get-thread-dat (url bkey dat)
  "スレッドDATを取得する。"
  (jp:decode (http-request (concatenate 'string
     (url-decode url)
     (url-decode bkey) "/dat/"
     (url-decode dat)) :force-binary t) :guess))


(defun make-thread-res-list (text)
  "DATを分解して配列に格納する。"
  (let ((i 1)
 (result nil))
    (loop for res in (cl-ppcre:split #\LineFeed text)
       do (let ((temp (cl-ppcre:split "<>" res)))
     (when (= i 1)
       (push (make-instance 'res :num 0 :text (car (last temp))) result)
       (push (make-instance 'res
       :num  i
       :name (first  temp)
       :mail (second temp)
       :date (third  temp)
       :text (fourth temp)) result))
     (when (not (= i 1))
       (push (make-instance 'res
       :num  i
       :name (first  temp)
       :mail (second temp)
       :date (third  temp)
       :text (fourth temp)) result))
     (incf i)))
    (reverse result)))




(defun thread-html (url bkey dat)
  "スレッドを展開してHTML化"
  (let ((res (make-thread-res-list (get-thread-dat url bkey dat))))
    (with-html-output-to-string (*standard-output* nil :indent t)
      (:html (:head (:title "スレッドビュー")
      (:script))
      (:body (loop for i in res
         do (cond
       ((= 0 (slot-value i 'num)) (htm (:font :color "red" (:b (str (slot-value i 'text)))) :br :br))
       (t (progn
     (htm (:dl (:dt
         (htm (str (slot-value i 'num))
       (:b :style "color:forestgreen;" (str (slot-value i 'name)))
       (str (concatenate 'string "[" (slot-value i 'mail) "]"))
       (str (slot-value i 'date)) :br)
         (htm (:dd (str (slot-value i 'text)) :br :br))))))))))))))


(define-easy-handler (thread :uri "/thread") (url bkey dat)
  (setf (hunchentoot:content-type*) "text/html; charset=utf-8")
  (thread-html url bkey dat))