LISPUSER

LISPMEMOLisp is like a ball of mud - you can throw anything you want into it, and it's still Lisp. -- Anonymous

(top)  (memo)  (rss)

taskpad.jp みたいなのを AllegroServe + Webactions + AllegroCache でつくってみる [パクリ]

私が最初に見かけた Catalyst のサンプルが taskpad.jp みたいなのを Catalyst で作ってみる でした.Catalyst の感じがつかめて非常に参考になりました.

そこで,最近入手した AllegroCL で似たような事をやってみようと思います. まぁ,偉そうな事いいながらマニュアル片手に調べながらちまちま書いてるわ けですが.

データベースの設計

まず,データを保持するクラスを定義します.

(defclass user ()
  ((uid      :initarg :uid      :reader uid)
   (password :initarg :password :reader password)))

(defclass memo ()
  ((tid      :initarg :tid      :reader tid)
   (uid      :initarg :uid      :reader uid)
   (body     :initarg :body     :reader body)
   (isdone   :initarg :isdone   :reader isdone)
   (added    :initarg :added    :reader added)
   (deadline :initarg :deadline :reader deadline)
   (finished :initarg :finished :reader finished)))

で,これだとただのクラスなのでデータベースに保持できません.幸いには AllegroCL 8.0 から AllegroCache というオブジェクトデータベースが附属し ていますので簡単に DB に永続化できます.

(defclass user ()
  ((uid      :initarg :uid      :reader uid)
   (password :initarg :password :reader password))
  (:metaclass persistent-class))

(defclass memo ()
  ((tid      :initarg :tid      :reader tid)
   (uid      :initarg :uid      :reader uid)
   (body     :initarg :body     :reader body)
   (isdone   :initarg :isdone   :reader isdone)
   (added    :initarg :added    :reader added)
   (deadline :initarg :deadline :reader deadline)
   (finished :initarg :finished :reader finished))
  (:metaclass persistent-class))

できました.これでインスタンスを作るだけで DB に永続化されます.また値 の読み書きも DB に反映されますし, (with-transaction-restart ...)(commit) (rollback) でトランザクションもつかえます.

まぁ,ユーザー情報は uid で取り出したいですし,メモも tid で取 り出したいのでインデックスをつけておきましょう.

(defclass user ()
  ((uid      :initarg :uid      :reader uid :index :any-unique)
   (password :initarg :password :reader password))
  (:metaclass persistent-class))

(defclass memo ()
  ((tid      :initarg :tid      :reader tid :index :any-unique)
   (uid      :initarg :uid      :reader uid)
   (body     :initarg :body     :reader body)
   (isdone   :initarg :isdone   :reader isdone)
   (added    :initarg :added    :reader added)
   (deadline :initarg :deadline :reader deadline)
   (finished :initarg :finished :reader finished))
  (:metaclass persistent-class))

カンタン!! でも AUTOINCREMENT みたいな機能がなーい.将来に期待しましょ う.クラス属性に id を保持するという手やメソッドコンビネーションで make-instance のたびにカウンタを増加という手も考えましたが今回は オブジェクトを数えて次の uid を計算 というもっともアホな手でいきます.

本当は uid じゃなくてリンクにしてもいいんですがこっちのほうが DB っぽい ので元記事の SQL 風味のデータにしてあります.

初期設定

初期設定をします. clp フォルダに Webactions のテンプレートを用意し ておきます.また,favicon も用意したいのですが今コンソールしかないので franz 社の favicon をダンロードしてつかいます. AllegroServe には HTTP Client 機能がついてきますのでありがたく利用します.これは Perl でいうと LWP みたいなもんですね.

;; 手抜きのため Franz の favicon を借ります :-p
(let ((path (merge-pathnames "./clp/favicon.ico" *load-pathname*)))
  (unless (fad:file-exists-p path)
    (with-open-file (s path :direction :output :external-format :octets)
      (write-sequence (net.aserve.client:do-http-request "http://www.franz.com/favicon.ico" :external-format :octets) s))))

;; プロジェクト定義
(webaction-project "MyTask"
                   :project-prefix "/"
                   :destination (format nil "~A" (make-pathname :directory (append (pathname-directory *load-pathname*) '("clp"))))
                   :index "login"
                   :map '(("login" "login.clp")
                          ("main"  "main.clp")
                          ("auth"  action-auth)
                          ("add"   action-add "main" (:redirect t))
                          ("do"    action-do)
                          ("favicon.ico"  (:contet-type "image/x-icon")))
                   :external-format :utf-8)

プロジェクト定義では :project-prefix で URL のパスを, :destination でテンプレートを置くファイルシステム上のパスを指定しま す. :index はプロジェクトにアクセスした時のデフォルトの飛び先です. そして,一番重要なのが :map です.これは URL とテンプレートや関数と の対応を記述します.

たとえば, /auth という URL にアクセスすると action-auth 関数が 呼ばれますし, /main にアクセスすると main.clp テンプレートが使 われるという具合です.

認証まわり

認証は次のようにしてしました.リクエストからユーザID (uid) とパスワード (pass) を取得し, DB から uid を検索します.その後は,

ユーザ ID が指定されていない → login 画面へ

指定されたユーザ ID のユーザが存在し,かつパスワードが等しい → main 画面へ

指定されたユーザ ID のユーザが存在しない → main 画面へ

それ以外 → login 画面へ

という処理です.ユーザ ID が指定されていなくても検索にいってしまうので 非効率ですが,ネストを深くすると訴求力が低下しそうなので.

;; 認証
(defun action-auth (req ent)
  (declare (ignorable req ent))  
  (let* ((uid  (request-query-value "uid" req))
         (pass (request-query-value "pass" req))
         (pass (if (stringp pass) (md5-string pass) nil))
         (sess (websession-from-req req))
         (user (retrieve-from-index 'user 'uid uid)))
    (cond ((string-equal uid "") "login")
          ((and user (equal (slot-value user 'password) pass))
           (setf (websession-variable sess "user") user)
           "main")
          ((null user)
           (with-transaction-restart ()
             (setf (websession-variable sess "user") (make-instance 'user :uid uid :password pass))
             (commit))
           "main")
          (t
           "login"))))

表示とロジックの分離

Webactions には標準のテンプレートエンジンがついています.これはタグとタ グ用の関数が対応するという珍しい形式です.たとえば,プログラムで計算し たランダムな数値を HTML 中に表示させたい場合には,以下のようになります.

-- sample.clp
<html>
<head>
   ...
</head>
<body>
  <h1>タイトル</h1>
  <p>ランダムな数値: <random_number /></p>
</body>
</html>

-- lisp コード
(def-clp-function random_number (req ent args body)
  (net.html.generater:html
    (:princ (random 100))))

ここで,みなれないタグ がでてきました.これは Webactions によって Lisp の関数呼び出しに対応されます.

<random_number /> := (random_number req ent () nil)

また,パラメータなども使う事ができます.

<random_number range="10" /> := (random_number req ent (("range" . "10")) nil)

<random_number low="-5" high="5" />
    := (random_number req ent (("low" . "-5") ("high" . "5")) nil)

<random_number>10</random_number>
    := (random_number req ent nil "10")
;;; -*- coding: shift_jis-dos -*-
;;;
;;; AllegroCL による Web Application のサンプル
;;;
;;; Masayuki Onjo <onjo@lispuser.net>
;;;

(eval-when (:load-toplevel :compile-toplevel :execute)
  (require :webactions))

(defpackage :MyTask (:use :cl :excl :net.html.generator :net.aserve :db.allegrocache)
  (:export #:mytask-start))
(in-package :MyTask)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; パッケージから公開するインターフェース
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun mytask-start ()
  (setf net.aserve:*default-aserve-external-format* :utf-8)
  (unless db.allegrocache::*allegrocache*
    (open-file-database (merge-pathnames "./data" *load-pathname*)
                                        :if-does-not-exist :create :if-exists :supersede))
  (net.aserve:start :port 8080 :external-format :utf-8))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; AllegroCache 用データモデル定義
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass user ()
  ((uid      :initarg :uid      :reader uid :index :any-unique)
   (password :initarg :password :reader password))
  (:metaclass persistent-class))

(defclass memo ()
  ((tid      :initarg :tid      :reader tid :index :any-unique)
   (uid      :initarg :uid      :reader uid)
   (body     :initarg :body     :reader body)
   (isdone   :initarg :isdone   :reader isdone)
   (added    :initarg :added    :reader added)
   (deadline :initarg :deadline :reader deadline)
   (finished :initarg :finished :reader finished))
  (:metaclass persistent-class))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Webactions 用プロジェクト
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; 手抜きのため Franz の favicon を借ります :-p
(let ((path (merge-pathnames "./clp/favicon.ico" *load-pathname*)))
  (unless (fad:file-exists-p path)
    (with-open-file (s path :direction :output :external-format :octets)
      (write-sequence (net.aserve.client:do-http-request "http://www.franz.com/favicon.ico" :external-format :octets) s))))

;; プロジェクト定義
(webaction-project "MyTask"
                   :project-prefix "/"
                   :destination (format nil "~A" (make-pathname :directory (append (pathname-directory *load-pathname*) '("clp"))))
                   :index "login"
                   :map '(("login" "login.clp")
                          ("main"  "main.clp")
                          ("auth"  action-auth)
                          ("add"   action-add "main" (:redirect t))
                          ("do"    action-do)
                          ("favicon.ico"  (:contet-type "image/x-icon")))
                   :external-format :utf-8)

;; 認証
(defun action-auth (req ent)
  (declare (ignorable req ent))  
  (let* ((uid  (request-query-value "uid" req))
   (pass (request-query-value "pass" req))
    (sess (websession-from-req req)))
    (setf pass (if (stringp pass) (md5-string pass) nil))
    (let ((user (retrieve-from-index 'user 'uid uid)))
      (cond ((string-equal uid "") "login")
            ((and user (equal (slot-value user 'password) pass))
              (setf (websession-variable sess "user") user)
              "main")
            ((null user)
              (with-transaction-restart ()
                (setf (websession-variable sess "user") (make-instance 'user :uid uid :password pass))
                (commit))
              "main")
           (t "login")))))

;; タスク追加
(defun action-add (req ent)
  (declare (ignorable req ent))
  (let* ((sess  (websession-from-req req))
   (time  (request-query-value "time" req))
    (thing (request-query-value "thing" req))
     (user (websession-variable sess "user")))
    (cond ((null user)
            "login")
          ((or (null thing) (string-equal thing ""))
            "main")
          (t
            (with-transaction-restart ()
              (let ((tid 0))
                (doclass (m 'memo)
                  (setf tid (max tid (slot-value m 'tid))))
                  (make-instance 'memo
                                 :tid (1+ tid)
                                 :uid (slot-value user 'uid)
                                 :body thing
                                 :isdone -1
                                 :added (get-universal-time)
                                 :deadline (+ (get-universal-time) (* (or (parse-integer time) 0) 60))
                                 :finished nil))
                  (commit))
            "main"))))

;; タスク完了
(defun action-do (req ent)
  (declare (ignorable req ent))
  (let* ((sess   (websession-from-req req))
   (tid    (or (request-query-value "tid" req) -1))
    (action (or (request-query-value "action" req) ""))
     (user   (websession-variable sess "user"))
      (memo   (retrieve-from-index 'memo 'tid (parse-integer tid)))
       (now    (get-universal-time)))
    (when (and user memo (equal (uid user) (uid memo)) (or (equal action "success") (equal action "fail")))
      (with-transaction-restart ()
        (setf (slot-value memo 'finished) now
              (slot-value memo 'isdone)  (cond ((equal action "success") (if (< now (deadline memo)) 0 1))
                                                                   ((equal action "fail")    2)))))
    "main"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 表示用部品
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def-clp-function mytask_time_select (req ent args body)
  "usage: <mytask_time_select name=\"foo\" />"
  (declare (ignorable req ent args body))
  (html
   ((:select :name (or (cdr (assoc "name" args)) "time"))
    (dolist (m '(3 5 10 15 20 30 60 120 180 240))
      (let ((text (if (< m 60)
                     (format nil "~A 分後" m)
                                  (format nil "~A 時間後" (floor m 60)))))
                           (html ((:option :value m) (:princ text))))))))

(def-clp-function mytask_todo_list (req ent args body)
  "usage: <mytask_todo_list />"
  (declare (ignorable req ent args body))
  (let* ((sess (websession-from-req req))
   (user (websession-variable sess "user"))
    (lst  nil))
    (doclass (m 'memo)
      (when (string= (slot-value m 'uid) (slot-value user 'uid))
      (push m lst)))
    (setf lst (sort lst #'< :key #'deadline))
    (html
     (:table
      (:tr
       ((:th :width "10%") (:princ "状態"))
       ((:th :width "70%") (:princ "内容"))
       ((:th :width "15%") (:princ "期限"))
       (todo-entry lst))))))
      
(defun todo-entry (lst &aux (now  (get-universal-time)))
  (dolist (m lst)
    (with-slots (tid uid body isdone deadline) m
      (html
       (:tr
       (:td (:princ
             (cond ((= isdone 0) "(達成済!!)")
                   ((= isdone 1) "(達成済)")
                   ((= isdone 2) "(未達成)")
                   (t
                     (html
                       ((:a :href (format nil "javascript:location.href='/do?tid=~A&action=success'" tid)) "[達]")
                       ((:a :href (format nil "javascript:location.href='/do?tid=~A&action=fail'" tid)) "[未]"))))))
      (:td (:princ (slot-value m 'body)))
      (:td (:princ (format nil "あと ~D 分" (floor (- (slot-value m 'deadline) now) 60)))))))))

login.clp

<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
<!-- -*- mode: html -*- -->
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />
<title>(マイタスク :login)</title>
</head>
<body style="text-align: center">
  <h1>;;; マイタスク</h1>

  <form action="auth" method="POST">
    <table>
      <tr>
        <th>ユーザー名</th>
        <td><input type="text" name="uid"  /></td>
      </tr>
      <tr>
        <th>パスワード</th>
        <td><input type="password" name="pass"  /></td>
      </tr>
      <tr>
      <tr>
        <td colspan="2"><input type="submit" value="login" /></td>
      </tr>
      <tr>
    </table>
  </form>

</body>
</html>

main.clp

<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
<!-- -*- mode: html -*- -->
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />
<title>(マイタスク :一覧表示)</title>
</head>
<body style="text-align: center">
  <h1>;;; ToDo リスト</h1>

  <form action="add" method="post">
    <table>
      <tr>
        <th>時間</th>
        <th>内容</th>
        <th></th>
      </tr>
      <tr>
        <td>
          <mytask_time_select name="time" />
        </td>
        <td>
          <input type="text" id="thing" name="thing" size="40" />
          <input type="submit" value="開始" style="font-size:12ptx" />
        </td>
        <td>
          <input type="button" value="更新" style="font-size:12ptx" onclick="location.href='/main'" />
        </td>
      </tr>
    </table>
  </form>

  <mytask_todo_list />

</body>
</html>

できました。

posted: 2006/09/10 22:25 | permanent link to this entry | Tags: LISP

(top)  (memo)  (rss)