tamuraです。
昔のRedditのコードが公開されていたのでSBCLでコンパイルして動かしてみました。
コンパイルを通すまで
2018.04.02に補足したようです。
ちろっと修正してみたけどうまくコンパイルできませんでした。ちゃんと中身を見てみよう。https://t.co/hYeSI3QL9T
— tamura shingo (@tamura_shingo) 2018年4月2日
とりあえずコンパイルを通すことを目標にしました。
change library
tbnlっていうライブラリがありませんでした。
tbnlをググると TBNL - A toolkit for dynamic Lisp websites というページが見つかりました。
たぶんHunchentootで行けるだろうと見込み、hunchentootに変更しました。
1 file changed, 1 insertion(+), 1 deletion(-)
reddit.asd | 2 +-
modified reddit.asd
@@ -8,7 +8,7 @@
(in-package #:reddit-system)
(defsystem reddit
- :depends-on (:tbnl
+ :depends-on (:hunchentoot
:cl-ppcre
:trivial-http
:cl-who
fix component
mailが2回定義されているので片方を削除しました。
1 file changed, 1 insertion(+), 2 deletions(-)
reddit.asd | 3 +--
modified reddit.asd
@@ -22,10 +22,9 @@
(:file "frame" :depends-on ("packages" "web"))
(:file "autocompute" :depends-on ("packages"))
(:file "user-info" :depends-on ("data" "packages"))
- (:file "web" :depends-on ("packages" "mail" "recommend" "data" "util" "mail" "rss" "memcached" "sites" "view-defs" "user-info" "cookiehash"))
+ (:file "web" :depends-on ("packages" "recommend" "data" "util" "mail" "rss" "memcached" "sites" "view-defs" "user-info" "cookiehash"))
(:file "data" :depends-on ("packages" "view-defs" "util"))
(:file "view-defs" :depends-on ("packages"))
- (:file "mail" :depends-on ("packages"))
(:file "util" :depends-on ("packages"))
(:file "search" :depends-on ("packages"))
;;(:file "options" :depends-on ("packages" "data"))
move source to src directory
reddit.asdとかと同じディレクトリにソースがどばーっとある状態だったので、
最近のソースの構成(?)に変更しました。
26 files changed, 12 insertions(+), 11 deletions(-)
reddit.asd | 23 ++++++++++++-----------
autocompute.lisp => src/autocompute.lisp | 0
classify.lisp => src/classify.lisp | 0
conditions.lisp => src/conditions.lisp | 0
cookiehash.lisp => src/cookiehash.lisp | 0
crc.lisp => src/crc.lisp | 0
data.lisp => src/data.lisp | 0
frame.lisp => src/frame.lisp | 0
mail.lisp => src/mail.lisp | 0
memcached.lisp => src/memcached.lisp | 0
old.lisp => src/old.lisp | 0
options.lisp => src/options.lisp | 0
packages.lisp => src/packages.lisp | 0
recommend.lisp => src/recommend.lisp | 0
rss.lisp => src/rss.lisp | 0
scraper.lisp => src/scraper.lisp | 0
search.lisp => src/search.lisp | 0
sites.lisp => src/sites.lisp | 0
tok-file.lisp => src/tok-file.lisp | 0
tokenizer.lisp => src/tokenizer.lisp | 0
updatedata.lisp => src/updatedata.lisp | 0
user-info.lisp => src/user-info.lisp | 0
user-panel.lisp => src/user-panel.lisp | 0
util.lisp => src/util.lisp | 0
view-defs.lisp => src/view-defs.lisp | 0
web.lisp => src/web.lisp | 0
modified reddit.asd
@@ -8,15 +8,17 @@
(in-package #:reddit-system)
(defsystem reddit
- :depends-on (:hunchentoot
- :cl-ppcre
- :trivial-http
- :cl-who
- :clsql
- :clsql-postgresql
- :cl-smtp
- :ironclad)
- :components ((:file "packages")
+ :depends-on (:hunchentoot
+ :cl-ppcre
+ :trivial-http
+ :cl-who
+ :clsql
+ :clsql-postgresql
+ :cl-smtp
+ :ironclad)
+ :components ((:module "src"
+ :components
+ ((:file "packages")
(:file "cookiehash" :depends-on ("packages" "data"))
(:file "recommend" :depends-on ("packages" "user-info"))
(:file "frame" :depends-on ("packages" "web"))
@@ -33,5 +35,4 @@
(:file "rss" :depends-on ("memcached" "packages" "sites"))
(:file "sites" :depends-on ("packages" "data" "util" "search" "autocompute" "user-info"))
(:file "mail" :depends-on ("packages" "data"))
- (:file "user-panel" :depends-on ("data" "packages" "web" "sites"))))
-
+ (:file "user-panel" :depends-on ("data" "packages" "web" "sites"))))))
renamed autocompute.lisp -> src/autocompute.lisp
renamed classify.lisp -> src/classify.lisp
renamed conditions.lisp -> src/conditions.lisp
renamed cookiehash.lisp -> src/cookiehash.lisp
renamed crc.lisp -> src/crc.lisp
renamed data.lisp -> src/data.lisp
renamed frame.lisp -> src/frame.lisp
renamed mail.lisp -> src/mail.lisp
renamed memcached.lisp -> src/memcached.lisp
renamed old.lisp -> src/old.lisp
renamed options.lisp -> src/options.lisp
renamed packages.lisp -> src/packages.lisp
renamed recommend.lisp -> src/recommend.lisp
renamed rss.lisp -> src/rss.lisp
renamed scraper.lisp -> src/scraper.lisp
renamed search.lisp -> src/search.lisp
renamed sites.lisp -> src/sites.lisp
renamed tok-file.lisp -> src/tok-file.lisp
renamed tokenizer.lisp -> src/tokenizer.lisp
renamed updatedata.lisp -> src/updatedata.lisp
renamed user-info.lisp -> src/user-info.lisp
renamed user-panel.lisp -> src/user-panel.lisp
renamed util.lisp -> src/util.lisp
renamed view-defs.lisp -> src/view-defs.lisp
renamed web.lisp -> src/web.lisp
パッケージ化
Javaを長年やってきたので、こういう一つのパッケージ(namespace)にいろんな役割のコードがあるのは、 コードを理解が進みません。 ある程度のパッケージ化をしていきました。
あと、useを多様するとどのパッケージのどの関数を使っているのか調べにくいので、
なるべく :import-from で読み込むようにしました。
create new package :reddit.util
1 file changed, 47 insertions(+), 1 deletion(-)
src/util.lisp | 48 +++++++++++++++++++++++++++++++++++++++++++++++-
modified src/util.lisp
@@ -18,7 +18,53 @@
;;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;;; SOFTWARE.
-(in-package #:reddit)
+(in-package :cl-user)
+(defpackage :reddit.util
+ (:use :cl)
+ (:import-from :cl-ppcre
+ :create-scanner
+ :register-groups-bind
+ :scan
+ :split)
+ (:import-from :cl-who
+ :conc
+ :escape-string)
+ (:import-from :clsql
+ :decode-time)
+ (:import-from :hunchentoot
+ :cookie-in
+ :log-message*
+ :set-cookie)
+ (:import-from :trivial-http
+ :http-get)
+ (:export :website-stream
+ :website-string
+ :website-title
+ :tl-domain
+ :replace-alist
+ :create-url
+ :days
+ :age-str
+ :sanitize
+ :add-rlist
+ :decode-user-url
+ :2weeks
+ :-2weeks
+ :good-nytimes-p
+ :nytimes-link-p
+ :nytimes-genlink-website
+ :good-nytimes
+ :nytimes-safe-url
+ :base-url
+ :add-http
+ :makestr
+ :key-str
+ :esc-quote
+ :shorten-str
+ :when-bind
+ :when-bind*))
+(in-package :reddit.util)
+
(defparameter *title* (create-scanner "(?s)(?i)<title>(.+?)</title>"))
(defparameter *toplevel* (create-scanner "https?://(?:www.)?([^/]*)"))
create new package :reddit.view-defs
RailsでいうところのMODELのようなものです。
1 file changed, 67 insertions(+), 1 deletion(-)
src/view-defs.lisp | 68 +++++++++++++++++++++++++++++++++++++++++++++++++++++-
modified src/view-defs.lisp
@@ -18,7 +18,73 @@
;;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;;; SOFTWARE.
-(in-package :reddit)
+(in-package :cl-user)
+(defpackage :reddit.view-defs
+ (:use :cl)
+ (:import-from :clsql
+ :def-view-class
+ :get-time)
+ (:export :user
+ :user-id
+ :user-name
+ :user-email
+ :user-karma
+ :user-date
+ :user-ip
+ :article
+ :article-id
+ :article-url
+ :article-title
+ :article-date
+ :article-submitterid
+ :article-submitter
+ :article-pop
+ :article-with-sn
+ :article-sn
+ :wtf
+ :wtf-userid
+ :wtf-user
+ :wtf-articleid
+ :wtf-reason
+ :wtf-date
+ :click
+ :click-userid
+ :click-articleid
+ :click-date
+ :click-ip
+ :like
+ :like-userid
+ :like-articleid
+ :like-date
+ :like-like
+ :moduser
+ :moduser-userid
+ :moduser-articleid
+ :moduser-targetid
+ :moduser-date
+ :moduser-ip
+ :moduser-amount
+ :modarticle
+ :modarticle-userid
+ :modarticle-articleid
+ :modarticle-date
+ :modarticle-ip
+ :modarticle-amount
+ :neuter
+ :neuter-userid
+ :neuter-ip
+ :options
+ :options-userid
+ :options-nnumsittes
+ :options-promoted
+ :options-demoted
+ :options-visible
+ :options-frame
+ :alias
+ :alias-userid
+ :alias-name
+ :alias-val))
+(in-package :reddit.view-defs)
;;user
(def-view-class user ()
create new package :reddit.data
データベースの処理全般をreddit.dataにまとめました。
2 files changed, 55 insertions(+), 12 deletions(-)
src/data.lisp | 56 +++++++++++++++++++++++++++++++++++++++++++++++++++++++-
src/sites.lisp | 11 -----------
modified src/data.lisp
@@ -18,7 +18,49 @@
;;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;;; SOFTWARE.
-(in-package #:reddit)
+(in-package :cl-user)
+(defpackage :reddit.data
+ (:use :cl)
+ (:import-from :clsql
+ :*default-caching*
+ :connect
+ :delete-records
+ :delete-instance-records
+ :get-time
+ :insert-records
+ :locally-enable-sql-reader-syntax
+ :make-duration
+ :select
+ :sequence-next
+ :sql-expression
+ :time-
+ :time<
+ :update-records
+ :update-records-from-instance)
+ (:import-from :hunchentoot
+ :log-message*)
+ (:import-from :reddit.view-defs
+ :alias-name
+ :alias-val
+ :article-id
+ :article-date
+ :article-submitterid
+ :like-date
+ :like-like
+ :modarticle-amount
+ :modarticle-date
+ :modarticle-ip
+ :moduser-amount
+ :moduser-date
+ :moduser-ip
+ :options-visible
+ :user-karma)
+ (:import-from :reddit.util
+ :add-http
+ :base-url
+ :when-bind))
+(in-package :reddit.data)
+
(defparameter *max-emails* 100)
(defparameter *mod-window* (make-duration :day 2))
@@ -129,6 +171,18 @@
(integer (car (select 'article :where [= id-or-url [id]] :flatp t)))
(string (car (select 'article :where [= id-or-url [url]] :flatp t))))))
+;;similar urls
+(defun similar-urls (url)
+ (select [id] [url] :from [articles] :where [like [url] (format nil "%~a%" url)] ))
+
+(defun article-id-from-url (url)
+ (when (> (length url) 0)
+ (let ((url (base-url url)))
+ (some #'(lambda (site)
+ (when (string= (base-url (second site)) url)
+ (first site)))
+ (similar-urls url)))))
+
(defun insert-article (title url submitter ip &optional fuser)
"Insert an article into the datebase and give user credit for
it. If the artciles already exists, boost the orig submitter's
modified src/sites.lisp
@@ -122,17 +122,6 @@
(when newurl
(update-site-url articleid newurl)))))
-;;similar urls
-(defun similar-urls (url)
- (select [id] [url] :from [articles] :where [like [url] (format nil "%~a%" url)] ))
-
-(defun article-id-from-url (url)
- (when (> (length url) 0)
- (let ((url (base-url url)))
- (some #'(lambda (site)
- (when (string= (base-url (second site)) url)
- (first site)))
- (similar-urls url)))))
;;saved sites
(defun save-site (userid articleid)
create new package :reddit.cookihash
1 file changed, 19 insertions(+), 1 deletion(-)
src/cookiehash.lisp | 20 +++++++++++++++++++-
modified src/cookiehash.lisp
@@ -18,7 +18,25 @@
;;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;;; SOFTWARE.
-(in-package :reddit)
+(in-package :cl-user)
+(defpackage :reddit.cookiehash
+ (:use :cl)
+ (:import-from :clsql
+ :format-time
+ :get-time)
+ (:import-from :ironclad
+ :ascii-string-to-byte-array
+ :byte-array-to-hex-string
+ :digest-sequence)
+ (:import-from :reddit.data
+ :get-user
+ :user-pass)
+ (:import-from :reddit.view-defs
+ :user-id)
+ (:import-from :reddit.util
+ :makestr
+ :when-bind*))
+(in-package :reddit.cookiehash)
(defparameter *secret* "blargo")
create new package :reddit.user-info
1 file changed, 13 insertions(+), 1 deletion(-)
src/user-info.lisp | 14 +++++++++++++-
modified src/user-info.lisp
@@ -18,7 +18,19 @@
;;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;;; SOFTWARE.
-(in-package :reddit)
+(in-package :cl-user)
+(defpackage reddit.user-info
+ (:use :cl)
+ (:import-from :clsql
+ :select)
+ (:import-from :hunchentoot
+ :log-message*)
+ (:import-from :reddit.data
+ :get-user
+ :get-user-options)
+ (:import-from :reddit.util
+ :when-bind))
+(in-package :reddit.user-info)
(defmacro userinfo (info sym &optional article)
(case sym
create new package :reddit.recommend
1 file changed, 11 insertions(+), 1 deletion(-)
src/recommend.lisp | 12 +++++++++++-
modified src/recommend.lisp
@@ -18,7 +18,17 @@
;;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;;; SOFTWARE.
-(in-package :reddit)
+(in-package :cl-user)
+(defpackage reddit.recommend
+ (:use :cl)
+ (:import-from :cl-ppcre
+ :create-scanner
+ :scan-to-strings
+ :split)
+ (:import-from :reddit.user-info
+ :user-alias))
+(in-package :reddit.recommend)
+
(defparameter *email-scanner* (create-scanner "^\\w*[+-._\\w]*\\w@\\w[-._\\w]*\\w\\.\\w{2,3}$"))
(defparameter *token-scanner* (create-scanner "[,;\\s]+"))
create new package :reddit.autocompute
(mp:process-name x)のようにMPパッケージを参照しています。
メソッド名を見るとスレッドのようなので、Bordeaux Threadsを代わりに使うようにしました。
2 files changed, 19 insertions(+), 15 deletions(-)
reddit.asd | 1 +
src/autocompute.lisp | 33 ++++++++++++++++++---------------
modified reddit.asd
@@ -9,6 +9,7 @@
(defsystem reddit
:depends-on (:hunchentoot
+ :bordeaux-threads
:cl-ppcre
:trivial-http
:cl-who
modified src/autocompute.lisp
@@ -18,15 +18,18 @@
;;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;;; SOFTWARE.
-(in-package :reddit)
+(in-package :cl-user)
+(defpackage reddit.autocompute
+ (:use :cl))
+(in-package :reddit.autocompute)
(defun get-processes (name)
- (remove-if-not #'(lambda (x) (string= name (mp:process-name x)))
- (mp:all-processes)))
+ (remove-if-not #'(lambda (x) (string= name (bt:thread-name x)))
+ (bt:all-threads)))
(defun destroy-processes (name)
(dolist (p (get-processes name))
- (mp:destroy-process p)))
+ (bt:destroy-thread p)))
(defclass ac ()
((name
@@ -47,23 +50,23 @@
:initform (error "must specify a function")
:accessor ac-fn)
(lock
- :initform (mp:make-lock)
+ :initform (bt:make-lock)
:accessor ac-lock)))
(defmethod initialize-instance :after ((auto ac) &key)
(destroy-processes (ac-name auto))
- (setf (slot-value auto 'process)
- (mp:make-process
- #'(lambda ()
- (loop
- (mp:with-lock-held ((ac-lock auto))
- (setf (slot-value auto 'val)
- (funcall (ac-fn auto))))
- (sleep (ac-period auto))))
- :name (ac-name auto))))
+ (setf (slot-value auto 'process)
+ (bt:make-thread
+ #'(lambda ()
+ (loop
+ (bt:with-lock-held ((ac-lock auto))
+ (setf (slot-value auto 'val)
+ (funcall (ac-fn auto))))
+ (sleep (ac-period auto))))
+ :name (ac-name auto))))
(defmethod ac-update ((auto ac))
- (mp:with-lock-held ((ac-lock auto))
+ (bt:with-lock-held ((ac-lock auto))
(setf (slot-value auto 'val)
(funcall (ac-fn auto)))))
create new package :reddit.search
1 file changed, 10 insertions(+), 1 deletion(-)
src/search.lisp | 11 ++++++++++-
modified src/search.lisp
@@ -18,7 +18,16 @@
;;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;;; SOFTWARE.
-(in-package :reddit)
+(in-package :cl-user)
+(defpackage reddit.search
+ (:use :cl)
+ (:import-from :cl-ppcre
+ :regex-replace-all)
+ (:import-from :clsql
+ :select
+ :sql
+ :sql-expression))
+(in-package :reddit.search)
(defun search-char (c)
"T if c is an a letter, number, or '"
create new package :reddit.memcached
自前でmemcachedを操作する関数を作ったみたいなのですが、ライブラリを使うように変更しました。
2 files changed, 21 insertions(+), 83 deletions(-)
reddit.asd | 3 +-
src/memcached.lisp | 101 ++++++++++-------------------------------------------
modified reddit.asd
@@ -16,7 +16,8 @@
:clsql
:clsql-postgresql
:cl-smtp
- :ironclad)
+ :ironclad
+ :cl-memcached)
:components ((:module "src"
:components
((:file "packages")
modified src/memcached.lisp
@@ -18,7 +18,11 @@
;;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;;; SOFTWARE.
-(in-package :reddit)
+(in-package :cl-user)
+(defpackage reddit.memcached
+ (:use :cl)
+ (:export :cached))
+(in-package :reddit.memcached)
(defparameter *STORED* "STORED")
(defparameter *NOTSTORED* "NOT_STORED")
@@ -31,7 +35,6 @@
(defparameter *SERVERERROR* "SERVER_ERROR")
(defparameter *VALUE* "VALUE")
-(defparameter *cache* (make-hash-table :test 'equal))
(defmacro cached ((key &optional (exp 0)) &body body)
(let ((k (gensym)))
@@ -41,89 +44,23 @@
(mc-set ,k val ,exp)
val)))))
-;;TODO more servers
-(defun get-stream ()
- (ignore-errors
- (sys:make-fd-stream (ext:connect-to-inet-socket "127.0.0.1" 11211)
- :input t :output t
- :buffering :none
- :auto-close t)))
+(defvar *memcached* (cl-memcached:make-memcache :ip "127.0.0.1" :port 11211 :name "reddit memcached"))
-(defun mc-write-str (str stream)
- (write-string str stream)
- (write-char #\Return stream)
- (write-char #\Newline stream))
-
-(defun mc-read-str (stream &optional len)
- ;(force-output stream)
- (if len
- ;;read len bytes in as few reads as possible
- (let ((val (read stream)))
- (read-char stream) (read-char stream)
- val)
- ;;everything else is read as one line
- (let ((str (read-line stream)))
- (subseq str 0 (1- (length str))))))
-
-;;TODO locking!
-(defun mc-store (cmd key val &optional (exp 0))
- (with-open-stream (s (get-stream))
- (when s
- (let ((cmd-str (case cmd
- (:add "add")
- (:replace "replace")
- (t "set")))
- (val-str (with-output-to-string (s) (prin1 val s))))
- (mc-write-str (format nil "~a ~a ~a ~a ~a" cmd-str key 0 exp (length val-str)) s)
- (mc-write-str val-str s)
- (let ((response (mc-read-str s)))
- (cond
- ((string= *STORED* response) :STORED)
- ((string= *NOTSTORED* response) :NOTSTORED)
- (t response)))))))
+(defun mc-get (key)
+ (cl-memcached:mc-get-value key :memcache *memcached*))
(defun mc-set (key val &optional (exp 0))
- (mc-store :set key val exp))
-
-(defun mc-add (key val &optional (exp 0))
- (mc-store :add key val exp))
-
-(defun mc-replace (key val &optional (exp 0))
- (mc-store :replace key val exp))
-
-(defun parse-value (value-str)
- (let* ((s1 (position #\space value-str :start 6))
- (s2 (position #\space value-str :start (1+ s1)))
- (key (subseq value-str 6 s1))
- (flags (parse-integer (subseq value-str (1+ s1) s2)))
- (len (parse-integer (subseq value-str (1+ s2)))))
- (list key flags len)))
-
-(defun mc-read-val (stream)
- (let ((response (mc-read-str stream)))
- (when (string= response "VALUE" :end1 (min (length response) 5))
- (destructuring-bind (key flags len) (parse-value response)
- (values
- (mc-read-str stream len)
- key flags)))))
+ (let* ((val-str (with-output-to-string (s) (prin1 val s)))
+ (response (cl-memcached:mc-set key val-str :memcache *memcached*)))
+ (cond ((string= *STORED* response) :STORED)
+ ((string= *NOTSTORED* response) :NOTSTORED)
+ (t response))))
-(defun mc-get (key)
- (with-open-stream (stream (get-stream))
- (when stream
- (mc-write-str (format nil "get ~a" key) stream)
- (let ((val (mc-read-val stream)))
- (when val
- ;;read END
- (mc-read-str stream)
- val)))))
(defun mc-delete (key &optional (time 0))
- (with-open-stream (stream (get-stream))
- (when stream
- (mc-write-str (format nil "delete ~a ~a" key time) stream)
- (let ((response (mc-read-str stream)))
- (cond
- ((string= response *DELETED*) :DELETED)
- ((string= response *NOTFOUND*) :NOTFOUND)
- (t response))))))
-
+ (let ((response (cl-memcached:mc-del key :memcache *memcached*)))
+ (cond
+ ((string= response *DELETED*) :DELETED)
+ ((string= response *NOTFOUND*) :NOTFOUND)
+ (t response))))
+
create new package :reddit.mail
メール送信もスレッドを使うので修正しています。
2 files changed, 21 insertions(+), 10 deletions(-)
src/mail.lisp | 25 +++++++++++++++++++++----
src/sites.lisp | 6 ------
modified src/mail.lisp
@@ -18,7 +18,17 @@
;;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;;; SOFTWARE.
-(in-package :reddit)
+(in-package :cl-user)
+(defpackage reddit.mail
+ (:use :cl)
+ (:import-from :cl-smtp
+ :send-email)
+ (:import-from :clsql
+ :select)
+ (:import-from :reddit.data
+ :email-sent
+ :valid-email))
+(in-package :reddit.mail)
(defparameter *mail-prog* "/usr/bin/mail")
@@ -27,10 +37,10 @@
(defparameter *mail-server* "216.55.162.13")
(defun send-reddit-email (to from subject message)
- (mp:make-process
+ (bt:make-thread
#'(lambda ()
- (ignore-errors
- (send-email *mail-server* from to subject message :username *user* :password *pass*)))))
+ (ignore-errors
+ (send-email *mail-server* from to subject message :authentication '(*user* *pass*))))))
(defun info-email-body (user password)
(with-output-to-string (s)
@@ -54,6 +64,13 @@
(format s "Check out http://reddit.com to see what's new online today!~%~%")
(format s "If you have any questions regarding this email direct them to feedback@reddit.com")))
+(defun site-tl (articleid)
+ "Returns the title and link for a particlular site."
+ (car (select [title] [url] :from [articles]
+ :where [= [id] articleid]
+ :flatp t
+ )))
+
(defun send-recommendation (userid articleid ip addresses from personal)
(let* ((tl (site-tl articleid))
(title (first tl))
modified src/sites.lisp
@@ -83,12 +83,6 @@
:limit limit
:flatp t))
-(defun site-tl (articleid)
- "Returns the title and link for a particlular site."
- (car (select [title] [url] :from [articles]
- :where [= [id] articleid]
- :flatp t
- )))
;;close sites
(defun unclose-site-sql (userid articleid)
create new package :reddit.sites
with-databaseは内部マクロに見えなくもないので、あえてclsql:with-databaseのようにしました。
2 files changed, 36 insertions(+), 2 deletions(-)
src/data.lisp | 2 +-
src/sites.lisp | 36 +++++++++++++++++++++++++++++++++++-
modified src/data.lisp
@@ -76,7 +76,7 @@
(defparameter *conn-spec* `(,*database-server* ,*database-name* ,*database-user* ,*database-password*))
(defmacro with-web-db (&body body)
- `(with-database (*default-database* *conn-spec* :pool t :database-type *database-type*)
+ `(clsql:with-database (clsql:*default-database* *conn-spec* :pool t :database-type *database-type*)
,@body))
(connect *conn-spec* :database-type *database-type* :if-exists :old)
modified src/sites.lisp
@@ -18,7 +18,41 @@
;;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;;; SOFTWARE.
-(in-package #:reddit)
+(in-package :cl-user)
+(defpackage reddit.sites
+ (:use :cl)
+ (:import-from :clsql
+ :delete-records
+ :insert-records
+ :select
+ :sql-operation
+ :update-records)
+ (:import-from :reddit.autocompute
+ :ac
+ :ac-val
+ :destroy-processes)
+ (:import-from :reddit.data
+ :article-id-from-url
+ :get-article-sn
+ :with-web-db)
+ (:import-from :reddit.search
+ :search-sites)
+ (:import-from :reddit.user-info
+ :get-info
+ :user-closed
+ :user-liked
+ :user-options)
+ (:import-from :reddit.util
+ :add-http
+ :good-nytimes
+ :good-nytimes-p
+ :nytimes-link-p
+ :website-title)
+ (:import-from :reddit.view-defs
+ :article-id
+ :article-title
+ :article-with-sn))
+(in-package :reddit.sites)
(defparameter *min-front-page-pop* 2)
(defparameter *prob-threshold* .7)
create new package :reddit.frame
3 files changed, 57 insertions(+), 2 deletions(-)
src/frame.lisp | 32 +++++++++++++++++++++++++++++++-
src/user-info.lisp | 17 +++++++++++++++++
src/util.lisp | 10 +++++++++-
modified src/frame.lisp
@@ -18,10 +18,40 @@
;;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;;; SOFTWARE.
-(in-package :reddit)
+(in-package :cl-user)
+(defpackage reddit.frame
+ (:use :cl)
+ (:import-from :cl-who
+ :conc
+ :esc
+ :htm
+ :str
+ :with-html-output-to-string)
+ (:import-from :reddit.data
+ :get-article)
+ (:import-from :reddit.user-info
+ :get-info
+ :user-liked
+ :userobj)
+ (:import-from :reddit.util
+ :logged-in-p
+ :makestr
+ :sanitize
+ :uid
+ :with-parameters)
+ (:import-from :reddit.view-defs
+ :article-id
+ :article-title
+ :article-url
+ :user-karma
+ :user-name))
+(in-package :reddit.frame)
(defparameter *frame-height* "30px")
+(defmacro idstr (name)
+ `(format nil ,(conc name "~a") id))
+
(defun reddit-frame (article)
(with-html-output-to-string (*standard-output* nil :prologue "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Frameset//EN\" \"http://www.w3.org/TR/html4/frameset.dtd\">" :indent t)
(:html
modified src/user-info.lisp
@@ -24,6 +24,8 @@
(:import-from :clsql
:select)
(:import-from :hunchentoot
+ :*session*
+ :session-value
:log-message*)
(:import-from :reddit.data
:get-user
@@ -116,3 +118,18 @@
(defun remove-info (id)
(remhash id *user-info*))
+
+
+(defun uid ()
+ (and (ignore-errors *session*)
+ (session-value :user-id)))
+
+(defun logged-in-p ()
+ (uid))
+
+(defun info ()
+ (get-info (uid)))
+
+(defun userobj ()
+ (when-bind (info (info))
+ (user-obj info)))
modified src/util.lisp
@@ -62,7 +62,8 @@
:esc-quote
:shorten-str
:when-bind
- :when-bind*))
+ :when-bind*
+ :with-parameters)
(in-package :reddit.util)
@@ -247,3 +248,10 @@
`(let (,(car binds))
(if ,(caar binds)
(when-bind* ,(cdr binds) ,@body)))))
+
+;;TODO fix multiple eval of params
+(defmacro with-parameters (params &body body)
+ `(let (,@(mapcar (lambda (x) `(,(first x) (or (hunchentoot:post-parameter ,(second x))
+ (hunchentoot:get-parameter ,(second x))))) params))
+ ,@body))
+
create new package :reddit.web
1 file changed, 150 insertions(+), 30 deletions(-)
src/web.lisp | 180 +++++++++++++++++++++++++++++++++++++++++++++++++----------
modified src/web.lisp
@@ -18,7 +18,133 @@
;;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;;; SOFTWARE.
-(in-package #:reddit)
+(in-package :cl-user)
+(defpackage reddit.web
+ (:use :cl)
+ (:import-from :cl-who
+ :conc
+ :esc
+ :escape-string-minimal
+ :fmt
+ :htm
+ :str
+ :with-html-output
+ :with-html-output-to-string)
+ (:import-from :clsql
+ :update-instance-from-records
+ :update-records-from-instance)
+ (:import-from :hunchentoot
+ :+HTTP-MOVED-PERMANENTLY+
+ :*dispatch-table*
+ :*reply*
+ :*session*
+ :cookie-in
+ :create-prefix-dispatcher
+ :create-regex-dispatcher
+ :create-static-file-dispatcher-and-handler
+ :get-parameter
+ :header-out
+ :log-message*
+ :post-parameter
+ :redirect
+ :return-code
+ :script-name*
+ :session-remote-addr
+ :session-value
+ :set-cookie
+ :start-session)
+ (:import-from :reddit.autocompute
+ :ac-update)
+ (:import-from :reddit.cookiehash
+ :cookie-str
+ :valid-cookie)
+ (:import-from :reddit.data
+ :add-user
+ :article-id-from-url
+ :change-password
+ :fake-user-p
+ :get-article
+ :get-article-sn
+ :insert-article
+ :like-and-mod
+ :login-from-email
+ :remove-alias
+ :remove-article
+ :set-alias
+ :top-submitters
+ :unlike-and-mod
+ :user-from-email
+ :valid-login-p
+ :valid-user-p
+ :view-link
+ :with-web-db)
+ (:import-from :reddit.frame
+ :reddit-frame)
+ (:import-from :reddit.mail
+ :send-login-info
+ :send-recommendation)
+ (:import-from :reddit.memcached
+ :cached)
+ (:import-from :reddit.recommend
+ :decode-aliases)
+ (:import-from :reddit.sites
+ :*cached-new*
+ :check-url
+ :close-site-sql
+ :get-articles
+ :get-search-sites
+ :get-sites-profile
+ :get-sites-user
+ :save-site
+ :unclose-site-sql
+ :unsave-site)
+ (:import-from :reddit.user-info
+ :get-info
+ :info
+ :logged-in-p
+ :remove-info
+ :user-alias
+ :user-clicked
+ :user-closed
+ :user-info-alias
+ :user-liked
+ :user-obj
+ :user-options
+ :user-saved
+ :userobj)
+ (:import-from :reddit.util
+ :2weeks
+ :age-str
+ :create-url
+ :esc-quote
+ :key-str
+ :makestr
+ :sanitize
+ :shorten-str
+ :tl-domain
+ :uid
+ :when-bind
+ :when-bind*
+ :with-parameters)
+ (:import-from :reddit.view-defs
+ :article-id
+ :article-date
+ :article-pop
+ :article-sn
+ :article-submitterid
+ :article-title
+ :article-url
+ :options
+ :options-demoted
+ :options-frame
+ :options-numsites
+ :options-promoted
+ :options-userid
+ :options-visible
+ :user-emai
+ :user-karma
+ :user-name))
+(in-package :reddit.web)
(defparameter *num-submitters* 8)
(defparameter *SESSION-MAX-TIME* 86400)
@@ -37,11 +163,6 @@
`(with-html-output-to-string (*standard-output* nil :prologue t :indent nil)
,@body))
-;;TODO fix multiple eval of params
-(defmacro with-parameters (params &body body)
- `(let (,@(mapcar (lambda (x) `(,(first x) (or (post-parameter ,(second x))
- (get-parameter ,(second x))))) params))
- ,@body))
(defparameter *callbacks* (make-hash-table :test 'equal))
@@ -112,25 +233,11 @@
(update-instance-from-records userobj)
(update-instance-from-records options)))))
-(defun uid ()
- (and (ignore-errors *session*)
- (session-value :user-id)))
-
-(defun info ()
- (get-info (uid)))
-
-(defun logged-in-p ()
- (uid))
-
(defun options ()
(or (when-bind (info (info))
(user-options info))
*default-options*))
-(defun userobj ()
- (when-bind (info (info))
- (user-obj info)))
-
(defmacro with-main ((&key (menu "empty") (right-panel) (rss-url)) &body body)
`(with-html
(:html
@@ -172,8 +279,6 @@
(cached (,ck ,exp) (with-main (:menu ,menu :right-panel ,right-panel :rss-url ,rss-url) ,@body))
(with-main (:menu ,menu :right-panel ,right-panel :rss-url ,rss-url) ,@body)))))))
-(defmacro idstr (name)
- `(format nil ,(conc name "~a") id))
(defun redirect-url (url)
(setf (header-out "Location")
@@ -286,7 +391,7 @@
(defun options-panel ()
(let ((options (session-value :display-opts)))
(pbox "display"
- (:form :method "get" :action (script-name) :class "nomargin"
+ (:form :method "get" :action (script-name*) :class "nomargin"
(:input :type "hidden" :name "action" :value "options")
(:table :style "border-collapse: collapse: cell-padding-top: 3px;" :width "100%"
(when (logged-in-p)
@@ -400,6 +505,9 @@
(remhash name (user-info-alias info))
(remove-alias (uid) name))))))
+(defmacro idstr (name)
+ `(format nil ,(conc name "~a") id))
+
(defun site-link (id title url &optional clicked)
(with-html-output (*standard-output*)
(:a :id (idstr "title") :class (if clicked "title click" "title norm")
@@ -491,7 +599,7 @@
("q" . ,(get-parameter "q")))
`(("offset" . ,nextoff)))))
(htm
- (:tr (:td :colspan "4" (:a :href (create-url (script-name) params)
+ (:tr (:td :colspan "4" (:a :href (create-url (script-name*) params)
"View More"))))))))
(htm (:span :class "error" "There are no sites that match your request")))))
@@ -621,7 +729,7 @@
(htm
(:script :src "/static/contacts.js" :language "javascript" :type "text/javascript" "")
(:form
- :onsubmit "return chksub()" :action (script-name) :method "post" :class "meat"
+ :onsubmit "return chksub()" :action (script-name*) :method "post" :class "meat"
(:input :type "hidden" :name "action" :value "submit")
(:input :type "hidden" :name "id" :value id)
(let ((article (get-article-sn id)))
@@ -707,7 +815,7 @@
(load-link (lucky)))
(defun wrap-static-file (path)
- (reddit-page (:cache-key (unless (logged-in-p) (key-str (script-name)))
+ (reddit-page (:cache-key (unless (logged-in-p) (key-str (script-name*)))
:exp 60
:menu (top-menu (browse-menu))
:right-panel (unless (logged-in-p) (login-panel))
@@ -718,8 +826,8 @@
(format t "~a~%" line)))))
(defun default-handler ()
- (let ((path (and (> (length (script-name)) 1)
- (conc "/home/reddit/reddit/web/" (subseq (script-name) 1)))))
+ (let ((path (and (> (length (script-name*)) 1)
+ (conc "/home/reddit/reddit/web/" (subseq (script-name*) 1)))))
(if (and path (probe-file path))
(wrap-static-file path)
(page-default))))
@@ -741,6 +849,17 @@
(page-main page-pop :pop "http://reddit.com/rss/pop")
(page-main page-new :new "http://reddit.com/rss/new"))
+(defun profile-site-table (profid display)
+ (with-parameters ((offset "offset"))
+ (setf offset (or (sanitize offset 'int) 0))
+ (multiple-value-bind (articles nextoff)
+ (get-sites-profile (uid) profid (options-numsites (options)) offset display)
+ (site-table articles (options-numsites (options)) offset
+ nextoff (and (eql display :saved)
+ (logged-in-p)
+ (= (uid) profid))
+ (eql display :hidden)))))
+
(defun page-default ()
(page-front))
@@ -821,5 +940,6 @@
'(("/blog/.+" default-handler)
("/blog/?" page-blog)
("/help/.+" default-handler)
- ("/help/?" page-help)))
- (list #'default-dispatcher)))
+ ("/help/?" page-help)))))
+
+
create new package :reddit.user-panel
1 file changed, 49 insertions(+), 13 deletions(-)
src/user-panel.lisp | 62 ++++++++++++++++++++++++++++++++++++++++++-----------
modified src/user-panel.lisp
@@ -18,7 +18,54 @@
;;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;;; SOFTWARE.
-(in-package :reddit)
+(in-package :cl-user)
+(defpackage reddit.user-panel
+ (:use :cl)
+ (:import-from :cl-ppcre
+ :split)
+ (:import-from :cl-who
+ :conc
+ :esc
+ :fmt
+ :htm
+ :with-html-output)
+ (:import-from :clsql
+ :month-name)
+ (:import-from :hunchentoot
+ :script-name*)
+ (:import-from :reddit.data
+ :basic-info
+ :profile-visible
+ :user-email
+ :user-stats
+ :valid-user-p)
+ (:import-from :reddit.sites
+ :saved-sites)
+ (:import-from :reddit.user-info
+ :logged-in-p
+ :userobj)
+ (:import-from :reddit.util
+ :decode-user-url
+ :sanitize)
+ (:import-from :reddit.view-defs
+ :options-demoted
+ :options-frame
+ :options-numsites
+ :options-promoted
+ :options-visible
+ :user-name)
+ (:import-from :reddit.web
+ :browse-menu
+ :hbar
+ :login-panel
+ :options
+ :pbox
+ :profile-site-table
+ :reddit-page
+ :site-link
+ :top-menu))
+(in-package :reddit.user-panel)
+
(defun saved-panel (name)
(let ((sites (saved-sites (valid-user-p name))))
@@ -124,17 +171,6 @@
(with-html-output (*standard-output*)
(unless (logged-in-p) (login-panel))))
-(defun profile-site-table (profid display)
- (with-parameters ((offset "offset"))
- (setf offset (or (sanitize offset 'int) 0))
- (multiple-value-bind (articles nextoff)
- (get-sites-profile (uid) profid (options-numsites (options)) offset display)
- (site-table articles (options-numsites (options)) offset
- nextoff (and (eql display :saved)
- (logged-in-p)
- (= (uid) profid))
- (eql display :hidden)))))
-
(defun profile-page (name display)
(with-html-output (*standard-output*)
@@ -155,7 +191,7 @@
(t (base-info-panel user))))
(defun page-user ()
- (multiple-value-bind (user page) (decode-user-url (script-name))
+ (multiple-value-bind (user page) (decode-user-url (script-name*))
(let ((user (valid-user-p user :return-sn t)))
(if user
(let ((page (sanitize page 'sym '(:basic :saved :promoted :submitted :hidden :demoted))))
パッケージ情報の修正
remove unused modules
パッケージを変更したり入れ替えたりもともと不要だったりというのが残っていたので、 モジュールを修正して綺麗にしました。
1 file changed, 5 insertions(+), 5 deletions(-)
reddit.asd | 10 +++++-----
modified reddit.asd
@@ -23,18 +23,18 @@
((:file "packages")
(:file "cookiehash" :depends-on ("packages" "data"))
(:file "recommend" :depends-on ("packages" "user-info"))
- (:file "frame" :depends-on ("packages" "web"))
+ (:file "frame" :depends-on ("packages" "util"))
(:file "autocompute" :depends-on ("packages"))
(:file "user-info" :depends-on ("data" "packages"))
- (:file "web" :depends-on ("packages" "recommend" "data" "util" "mail" "rss" "memcached" "sites" "view-defs" "user-info" "cookiehash"))
+ (:file "web" :depends-on ("packages" "frame" "recommend" "data" "util" "mail" "memcached" "sites" "view-defs" "user-info" "cookiehash"))
(:file "data" :depends-on ("packages" "view-defs" "util"))
(:file "view-defs" :depends-on ("packages"))
(:file "util" :depends-on ("packages"))
(:file "search" :depends-on ("packages"))
;;(:file "options" :depends-on ("packages" "data"))
- (:file "memcached" :depends-on ("packages" "crc"))
- (:file "crc" :depends-on ("packages"))
- (:file "rss" :depends-on ("memcached" "packages" "sites"))
+ (:file "memcached" :depends-on ("packages"))
+ ;;(:file "crc" :depends-on ("packages"))
+ ;;(:file "rss" :depends-on ("memcached" "packages" "sites"))
(:file "sites" :depends-on ("packages" "data" "util" "search" "autocompute" "user-info"))
(:file "mail" :depends-on ("packages" "data"))
(:file "user-panel" :depends-on ("data" "packages" "web" "sites"))))))
remove use packages
packages.lisp から use を消したりしました。
1 file changed, 6 insertions(+), 10 deletions(-)
src/packages.lisp | 16 ++++++----------
modified src/packages.lisp
@@ -18,14 +18,10 @@
;;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;;; SOFTWARE.
-(in-package #:cl-user)
+(in-package :cl-user)
-(defpackage #:reddit
- (:use #:cl
- #:tbnl
- #:cl-ppcre
- #:trivial-http
- #:cl-who
- #:clsql-user
- #:cl-smtp
- #:ironclad))
+(defpackage reddit
+ (:use :cl))
+(in-package :reddit)
+
+; blah blah blah
こまごました修正
function ‘seconds’ not found, so comment out it
PostgreSQLでそんな関数無いエラーが出るので、秒数の指定を無視するように変更。
あと、CLSQLのreaderが使えるように#.(clsql:file-enable-sql-reader-syntax)を追加。
1 file changed, 5 insertions(+), 1 deletion(-)
src/sites.lisp | 6 +++++-
modified src/sites.lisp
@@ -54,6 +54,8 @@
:article-with-sn))
(in-package :reddit.sites)
+#.(clsql:file-enable-sql-reader-syntax)
+
(defparameter *min-front-page-pop* 2)
(defparameter *prob-threshold* .7)
(defparameter *hot-factor* 2000)
@@ -70,7 +72,9 @@
(:new '(([articles_sn date] desc)))
(t `(;;(,(sql-operation 'function "recent_pop" [id]) desc)
(,[- [pop]
- [/ (sql-operation 'function "seconds" [date]) *hot-factor*]] desc))))
+ ;; XXX: seconds is stored function?
+ ;;[/ (sql-operation 'function "seconds" [date]) *hot-factor*]] desc))))
+ 0] desc))))
:offset offset
:limit limit
:flatp t
fix import symbols
4 files changed, 5 insertions(+), 5 deletions(-)
src/frame.lisp | 4 ++--
src/util.lisp | 2 +-
src/view-defs.lisp | 2 +-
src/web.lisp | 2 +-
modified src/frame.lisp
@@ -31,13 +31,13 @@
:get-article)
(:import-from :reddit.user-info
:get-info
+ :logged-in-p
+ :uid
:user-liked
:userobj)
(:import-from :reddit.util
- :logged-in-p
:makestr
:sanitize
- :uid
:with-parameters)
(:import-from :reddit.view-defs
:article-id
modified src/util.lisp
@@ -63,7 +63,7 @@
:shorten-str
:when-bind
:when-bind*
- :with-parameters)
+ :with-parameters))
(in-package :reddit.util)
modified src/view-defs.lisp
@@ -27,7 +27,7 @@
(:export :user
:user-id
:user-name
- :user-email
+ :user-emai
:user-karma
:user-date
:user-ip
modified src/web.lisp
@@ -103,6 +103,7 @@
:info
:logged-in-p
:remove-info
+ :uid
:user-alias
:user-clicked
:user-closed
@@ -122,7 +123,6 @@
:sanitize
:shorten-str
:tl-domain
- :uid
:when-bind
:when-bind*
:with-parameters)
とりあえず
動くところまできました。
running Reddit1.0 on CommonLisp.
— tamura shingo (@tamura_shingo) 2018年4月8日
IMG and CSS not found……. pic.twitter.com/GP31zu5aZ6
仕上げ
create new package :reddit.rss
漏れたパッケージの対応。
1 file changed, 19 insertions(+), 4 deletions(-)
src/rss.lisp | 23 +++++++++++++++++++----
modified src/rss.lisp
@@ -18,7 +18,22 @@
;;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;;;; SOFTWARE.
-(in-package :reddit)
+(in-package :cl-user)
+(defpackage reddit.rss
+ (:use :cl)
+ (:import-from :cl-who
+ :conc
+ :esc
+ :escape-string
+ :htm
+ :with-html-output-to-string)
+ (:import-from :hunchentoot
+ :content-type*)
+ (:import-from :reddit.memcached
+ :cached)
+ (:import-from :reddit.sites
+ :get-articles-cached))
+(in-package :reddit.rss)
(defun rss-sites (rssurl siteurl name sort)
(let ((sites (get-articles-cached 25 0 sort)))
@@ -46,16 +61,16 @@
(format t "</rdf:RDF>"))))
(defun rss-hot ()
- (setf (content-type) "text/xml")
+ (setf (content-type*) "text/xml")
(cached ("rsshot" 900)
(rss-sites "http://reddit.com/rss/hot" "http://reddit.com/" "hottest" :front)))
(defun rss-new ()
- (setf (content-type) "text/xml")
+ (setf (content-type*) "text/xml")
(cached ("rssnew" 900)
(rss-sites "http://reddit.com/rss/new" "http://reddit.com/new" "newest" :new)))
(defun rss-pop ()
- (setf (content-type) "text/xml")
+ (setf (content-type*) "text/xml")
(cached ("rsspop" 900)
(rss-sites "http://reddit.com/rss/pop" "http://reddit.com/pop" "top all-time" :pop)))
create new package :reddit.main
mainパッケージを作って、アプリケーションの上げ下げをできるようにしました。
5 files changed, 128 insertions(+), 61 deletions(-)
reddit.asd | 33 ++++++++---------
src/cookiehash.lisp | 6 ++--
src/main.lisp | 100 ++++++++++++++++++++++++++++++++++++++++++++++++++++
src/packages.lisp | 10 ++++--
src/web.lisp | 40 ---------------------
modified reddit.asd
@@ -20,21 +20,22 @@
:cl-memcached)
:components ((:module "src"
:components
- ((:file "packages")
- (:file "cookiehash" :depends-on ("packages" "data"))
- (:file "recommend" :depends-on ("packages" "user-info"))
- (:file "frame" :depends-on ("packages" "util"))
- (:file "autocompute" :depends-on ("packages"))
- (:file "user-info" :depends-on ("data" "packages"))
- (:file "web" :depends-on ("packages" "frame" "recommend" "data" "util" "mail" "memcached" "sites" "view-defs" "user-info" "cookiehash"))
- (:file "data" :depends-on ("packages" "view-defs" "util"))
- (:file "view-defs" :depends-on ("packages"))
- (:file "util" :depends-on ("packages"))
- (:file "search" :depends-on ("packages"))
+ ((:file "packages" :depends-on ("main"))
+ (:file "main" :depends-on ("frame" "rss" "user-panel" "web"))
+ (:file "cookiehash" :depends-on ("data" "view-defs" "util"))
+ (:file "recommend" :depends-on ("user-info"))
+ (:file "frame" :depends-on ("data" "user-info" "util" "view-defs"))
+ (:file "autocompute")
+ (:file "user-info" :depends-on ("data" "util"))
+ (:file "web" :depends-on ("autocompute" "cookiehash" "data" "frame" "mail" "memcached" "recommend" "sites" "user-info" "util" "view-defs"))
+ (:file "data" :depends-on ("view-defs" "util"))
+ (:file "view-defs")
+ (:file "util")
+ (:file "search")
;;(:file "options" :depends-on ("packages" "data"))
- (:file "memcached" :depends-on ("packages"))
+ (:file "memcached")
;;(:file "crc" :depends-on ("packages"))
- ;;(:file "rss" :depends-on ("memcached" "packages" "sites"))
- (:file "sites" :depends-on ("packages" "data" "util" "search" "autocompute" "user-info"))
- (:file "mail" :depends-on ("packages" "data"))
- (:file "user-panel" :depends-on ("data" "packages" "web" "sites"))))))
+ (:file "rss" :depends-on ("memcached" "sites"))
+ (:file "sites" :depends-on ("autocompute" "data" "search" "user-info" "util" "view-defs"))
+ (:file "mail" :depends-on ("data"))
+ (:file "user-panel" :depends-on ("data" "sites" "user-info" "util" "view-defs" "web"))))))
modified src/cookiehash.lisp
@@ -31,11 +31,11 @@
(:import-from :reddit.data
:get-user
:user-pass)
- (:import-from :reddit.view-defs
- :user-id)
(:import-from :reddit.util
:makestr
- :when-bind*))
+ :when-bind*)
+ (:import-from :reddit.view-defs
+ :user-id))
(in-package :reddit.cookiehash)
(defparameter *secret* "blargo")
new file src/main.lisp
@@ -0,0 +1,100 @@
+;;;; Copyright 2018 tamura shingo
+;;;;
+;;;; MIT License
+
+(in-package :cl-user)
+(defpackage reddit.main
+ (:use :cl)
+ (:import-from :hunchentoot
+ :*dispatch-table*
+ :create-prefix-dispatcher
+ :create-regex-dispatcher
+ :create-static-file-dispatcher-and-handler
+ :easy-acceptor
+ :start
+ :stop)
+ (:import-from :reddit.frame
+ :reddit-toolbar)
+ (:import-from :reddit.rss
+ :rss-hot
+ :rss-new
+ :rss-pop)
+ (:import-from :reddit.user-panel
+ :page-user)
+ (:import-from :reddit.web
+ :viewlink
+ :page-default
+ :page-submit
+ :page-front
+ :page-pop
+ :page-new
+ :page-saved
+ :page-submitters
+ :page-search
+ :ajax-op
+ :page-test
+ :logout
+ :page-password
+ :page-lucky
+ :default-handler
+ :page-blog
+ :page-help))
+(in-package :reddit.main)
+
+
+(defvar *reddit-acceptor* nil)
+(defvar *not-initialized* T)
+
+(defun initialize ()
+ (when *not-initialized*
+ (initialize-acceptor)
+ (initialize-dispatch-table)
+ (setf *not-initialized* nil)))
+
+(defun start-reddit ()
+ (start *reddit-acceptor*))
+
+(defun stop-reddit ()
+ (stop *reddit-acceptor*))
+
+(defun initialize-acceptor ()
+ (setf *reddit-acceptor* (make-instance 'easy-acceptor :port 8000)))
+
+(defun initialize-dispatch-table ()
+ (setq *dispatch-table*
+ (nconc
+ (list (create-static-file-dispatcher-and-handler
+ "/favicon.ico"
+ (make-pathname :directory "/home/reddit/reddit/web/" :name "favicon" :type "ico" :version nil
+ :defaults (load-time-value *load-pathname*))
+ "image/x-icon"))
+ (mapcar (lambda (args)
+ (apply #'create-prefix-dispatcher args))
+ '(("/rss/new" rss-new)
+ ("/rss/hot" rss-hot)
+ ("/rss/pop" rss-pop)
+ ("/viewlink" viewlink)
+ ("/browse" page-default)
+ ("/submit" page-submit)
+ ("/hot" page-front)
+ ("/pop" page-pop)
+ ("/new" page-new)
+ ("/saved" page-saved)
+ ("/topsub" page-submitters)
+ ("/search" page-search)
+ ("/aop" ajax-op)
+ ("/test" page-test)
+ ("/logout" logout)
+ ("/share" page-submit)
+ ("/password" page-password)
+ ("/lucky" page-lucky)
+ ("/user/" page-user)
+ ("/toolbar" reddit-toolbar)))
+ (list (create-static-file-dispatcher-and-handler
+ "/blog/atom.xml" "/home/reddit/reddit/web/blog/atom.xml" "text/xml"))
+ (mapcar (lambda (args)
+ (apply #'create-regex-dispatcher args))
+ '(("/blog/.+" default-handler)
+ ("/blog/?" page-blog)
+ ("/help/.+" default-handler)
+ ("/help/?" page-help))))))
modified src/packages.lisp
@@ -21,7 +21,13 @@
(in-package :cl-user)
(defpackage reddit
- (:use :cl))
+ (:use :cl)
+ (:import-from :reddit.main
+ :initialize
+ :start-reddit
+ :stop-reddit)
+ (:export :initialize
+ :start-reddit
+ :stop-reddit))
(in-package :reddit)
-; blah blah blah
modified src/web.lisp
@@ -39,9 +39,6 @@
:*reply*
:*session*
:cookie-in
- :create-prefix-dispatcher
- :create-regex-dispatcher
- :create-static-file-dispatcher-and-handler
:get-parameter
:header-out
:log-message*
@@ -904,42 +901,5 @@
(defun page-test ()
t)
-(setq *dispatch-table*
- (nconc
- (list (create-static-file-dispatcher-and-handler
- "/favicon.ico"
- (make-pathname :directory "/home/reddit/reddit/web/" :name "favicon" :type "ico" :version nil
- :defaults (load-time-value *load-pathname*))
- "image/x-icon"))
- (mapcar (lambda (args)
- (apply #'create-prefix-dispatcher args))
- '(("/rss/new" rss-new)
- ("/rss/hot" rss-hot)
- ("/rss/pop" rss-pop)
- ("/viewlink" viewlink)
- ("/browse" page-default)
- ("/submit" page-submit)
- ("/hot" page-front)
- ("/pop" page-pop)
- ("/new" page-new)
- ("/saved" page-saved)
- ("/topsub" page-submitters)
- ("/search" page-search)
- ("/aop" ajax-op)
- ("/test" page-test)
- ("/logout" logout)
- ("/share" page-submit)
- ("/password" page-password)
- ("/lucky" page-lucky)
- ("/user/" page-user)
- ("/toolbar" reddit-toolbar)))
- (list (create-static-file-dispatcher-and-handler
- "/blog/atom.xml" "/home/reddit/reddit/web/blog/atom.xml" "text/xml"))
- (mapcar (lambda (args)
- (apply #'create-regex-dispatcher args))
- '(("/blog/.+" default-handler)
- ("/blog/?" page-blog)
- ("/help/.+" default-handler)
- ("/help/?" page-help)))))
add db migration module
create-tableのタイミングをいい感じにしたかったので、migration用に別ファイルに切り出しました。
3 files changed, 62 insertions(+)
db/migration.lisp | 33 +++++++++++++++++++++++++++++++++
reddit-db.asd | 27 +++++++++++++++++++++++++++
src/view-defs.lisp | 2 ++
new file db/migration.lisp
@@ -0,0 +1,33 @@
+;;;; Copyright 2018 tamura shingo
+;;;;
+;;;; MIT License
+
+(in-package :cl-user)
+(defpackage :reddit.db.migration
+ (:use :cl)
+ (:import-from :reddit.view-defs
+ :user
+ :article
+ :article-with-sn
+ :wtf
+ :click
+ :like
+ :moduser
+ :modarticle
+ :neuter
+ :options
+ :alias))
+(in-package :reddit.db.migration)
+
+(clsql:create-view-from-class 'user)
+(clsql:create-view-from-class 'article)
+(clsql:create-view-from-class 'article-with-sn)
+(clsql:create-view-from-class 'wtf)
+(clsql:create-view-from-class 'click)
+(clsql:create-view-from-class 'like)
+(clsql:create-view-from-class 'moduser)
+(clsql:create-view-from-class 'modarticle)
+(clsql:create-view-from-class 'neuter)
+(clsql:create-view-from-class 'options)
+(clsql:create-view-from-class 'alias)
+
new file reddit-db.asd
@@ -0,0 +1,27 @@
+;;;; Copyright 2018 tamura shingo
+;;;;
+;;;; MIT License
+
+(in-package :cl-user)
+(defpackage reddit-db-asd
+ (:use :cl :asdf))
+(in-package :reddit-db-asd)
+
+(defsystem reddit-db
+ :author "tamura shingo"
+ :license "MIT"
+ :depends-on (:hunchentoot
+ :cl-who
+ :clsql
+ :clsql-postgresql
+ :trivial-http)
+ :components ((:module "src"
+ :components
+ ((:file "view-defs")
+ (:file "data" :depends-on ("view-defs" "util"))
+ (:file "util")))
+ (:module "db"
+ :components
+ ((:file "migration"))))
+ :description "database migration")
+
modified src/view-defs.lisp
@@ -24,6 +24,8 @@
(:import-from :clsql
:def-view-class
:get-time)
+ (:import-from :clsql-sys
+ :wall-time)
(:export :user
:user-id
:user-name
add README.md
READMEを追加。 これでみんなRedditを起動できます！（JSとかCSSとかないので90年代初期のページに見えますが）
1 file changed, 260 insertions(+)
README.md | 260 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
new file README.md
@@ -0,0 +1,260 @@
+# Reddit 1.0
+
+
+## Require
+
+- CommonLisp (tested on SBCL)
+- PostgreSQL
+- memcached
+- smtp server
+
+
+## database
+
+### PostgreSQL
+
+- database-name: `reddit`
+- username: `pgsql`
+- password: `pgcwip42:`
+
+it's defined on src/data.lisp.
+
+
+### Migration
+
+load `reddit-db` like
+
+```lisp
+(ql:quickload :reddit-db)
+```
+
+#### log
+
+on PostgreSQL, there's no tables.
+
+```
+$ psql -U pgsql -W reddit
+Password for user pgsql:
+psql (10.1)
+Type "help" for help.
+
+reddit=> \d
+Did not find any relations.
+```
+
+load `reddit-db` and migrate.
+
+```
+CL-USER> (ql:quickload :reddit-db)
+To load "reddit-db":
+ Load 1 ASDF system:
+ reddit-db
+; Loading "reddit-db"
+..................................................
+[package reddit.view-defs]........................
+[package reddit.util].............................
+[package reddit.data].............................
+[package reddit.db.migration].
+(:REDDIT-DB)
+```
+
+check PostgreSQL.
+
+```
+reddit=> \d
+ List of relations
+ Schema | Name | Type | Owner
+--------+-------------+-------+-------
+ public | alias | table | pgsql
+ public | articles | table | pgsql
+ public | articles_sn | table | pgsql
+ public | clicks | table | pgsql
+ public | like_site | table | pgsql
+ public | mod_article | table | pgsql
+ public | mod_user | table | pgsql
+ public | neuter | table | pgsql
+ public | options | table | pgsql
+ public | users | table | pgsql
+ public | wtf | table | pgsql
+(11 rows)
+
+reddit=> \d alias
+ Table "public.alias"
+ Column | Type | Collation | Nullable | Default
+--------+-------------------+-----------+----------+---------
+ userid | integer | | not null |
+ name | character varying | | not null |
+ val | character varying | | |
+Indexes:
+ "alias_pk" PRIMARY KEY, btree (userid, name)
+
+reddit=> \d articles
+ Table "public.articles"
+ Column | Type | Collation | Nullable | Default
+-----------+-----------------------------+-----------+----------+---------
+ id | integer | | not null |
+ url | character varying | | |
+ title | character varying | | |
+ date | timestamp without time zone | | |
+ submitter | integer | | |
+ pop | integer | | |
+Indexes:
+ "articles_pk" PRIMARY KEY, btree (id)
+
+reddit=> \d articles_sn
+ Table "public.articles_sn"
+ Column | Type | Collation | Nullable | Default
+------------+-----------------------------+-----------+----------+---------
+ screenname | character varying | | |
+ id | integer | | not null |
+ url | character varying | | |
+ title | character varying | | |
+ date | timestamp without time zone | | |
+ submitter | integer | | |
+ pop | integer | | |
+Indexes:
+ "articles_sn_pk" PRIMARY KEY, btree (id)
+
+reddit=> \d clicks
+ Table "public.clicks"
+ Column | Type | Collation | Nullable | Default
+---------+-----------------------------+-----------+----------+---------
+ userid | integer | | |
+ article | integer | | |
+ date | timestamp without time zone | | |
+ ip | character varying | | |
+
+reddit=> \d like_site
+ Table "public.like_site"
+ Column | Type | Collation | Nullable | Default
+---------+-----------------------------+-----------+----------+---------
+ userid | integer | | not null |
+ article | integer | | not null |
+ date | timestamp without time zone | | |
+ liked | boolean | | |
+Indexes:
+ "like_site_pk" PRIMARY KEY, btree (userid, article)
+
+reddit=> \d mod_article
+ Table "public.mod_article"
+ Column | Type | Collation | Nullable | Default
+---------+-----------------------------+-----------+----------+---------
+ userid | integer | | not null |
+ article | integer | | not null |
+ date | timestamp without time zone | | |
+ ip | character varying | | |
+ amount | integer | | |
+Indexes:
+ "mod_article_pk" PRIMARY KEY, btree (userid, article)
+
+reddit=> \d mod_user
+ Table "public.mod_user"
+ Column | Type | Collation | Nullable | Default
+---------+-----------------------------+-----------+----------+---------
+ userid | integer | | not null |
+ article | integer | | not null |
+ target | integer | | not null |
+ date | timestamp without time zone | | |
+ ip | character varying | | |
+ amount | integer | | |
+Indexes:
+ "mod_user_pk" PRIMARY KEY, btree (userid, article, target)
+
+reddit=> \d neuter
+ Table "public.neuter"
+ Column | Type | Collation | Nullable | Default
+--------+------------------------+-----------+----------+---------
+ userid | integer | | |
+ ip | character varying(255) | | |
+
+reddit=> \d options
+ Table "public.options"
+ Column | Type | Collation | Nullable | Default
+----------+---------+-----------+----------+---------
+ userid | integer | | not null |
+ numsites | integer | | |
+ promoted | boolean | | |
+ demoted | boolean | | |
+ visible | boolean | | |
+ frame | boolean | | |
+Indexes:
+ "options_pk" PRIMARY KEY, btree (userid)
+
+reddit=> \d users
+ Table "public.users"
+ Column | Type | Collation | Nullable | Default
+------------+-----------------------------+-----------+----------+---------
+ id | integer | | not null |
+ screenname | character varying | | |
+ email | character varying | | |
+ karma | integer | | |
+ signupdate | timestamp without time zone | | |
+ ip | character varying | | |
+Indexes:
+ "users_pk" PRIMARY KEY, btree (id)
+
+reddit=> \d wtf
+ Table "public.wtf"
+ Column | Type | Collation | Nullable | Default
+---------+-----------------------------+-----------+----------+---------
+ userid | integer | | not null |
+ article | integer | | not null |
+ reason | character(250) | | |
+ date | timestamp without time zone | | |
+Indexes:
+ "wtf_pk" PRIMARY KEY, btree (userid, article)
+```
+
+
+## application server
+
+To start, load, initialize, and start.
+
+### load
+
+```
+CL-USER> (ql:quickload :reddit)
+To load "reddit":
+ Load 1 ASDF system:
+ reddit
+; Loading "reddit"
+..................................................
+[package reddit.user-info]........................
+[package reddit.frame]............................
+[package reddit.sites]............................
+[package reddit.rss]..............................
+[package reddit.cookiehash].......................
+[package reddit.mail].............................
+[package reddit.recommend]........................
+[package reddit.web]..............................
+..................................................
+[package reddit.user-panel].......................
+[package reddit.main].............................
+[package reddit]
+(:REDDIT)
+```
+
+### initialize
+
+```
+CL-USER> (reddit:initialize)
+NIL
+```
+
+### start
+
+```
+CL-USER> (reddit:start-reddit)
+#<HUNCHENTOOT:EASY-ACCEPTOR (host *, port 8000)>
+```
+
+
+### stop
+
+```
+CL-USER> (reddit:stop-reddit)
+#<HUNCHENTOOT:EASY-ACCEPTOR (host *, port 8000)>
+```
+
+---
+Copyright 2018 Reddit, Inc.
公開
ツイッターで動かした報告をしました。 redditにも取り上げられてちょっと嬉しかったのと、 意外と誰もやらないんだなと思いました。
データベース接続のところだけまだ直していないけどとりあえず起動だけはできるようになったのでREADMEを用意してみました。
— tamura shingo (@tamura_shingo) 2018年4月8日
create tableを直で打つ派でしたが、クラス構成に応じたテーブルを作ってくれるのはありがたいです。楽に試せます。https://t.co/I8qP1WL4PI#reddit #CommonLisp #SBCL
現在
テストを追加したり、重要な値をconfigurationファイルに切り出したり、ちょっとずつ変更しています。