Browse code
More persistent, interface cleaned-up, rewrites
fiddlerwoaroof authored on 24/01/2016 22:13:47
Showing 4 changed files
Showing 4 changed files
... | ... |
@@ -5,17 +5,22 @@ |
5 | 5 |
:author "socraticum" |
6 | 6 |
:license "MIT" |
7 | 7 |
:depends-on (#:alimenta |
8 |
- #:cl-oid-connect |
|
9 |
- #:cl-mustache |
|
10 |
- #:parenscript |
|
11 |
- #:alexandria |
|
12 |
- #:anaphora |
|
13 |
- #:ironclad |
|
14 |
- #:postmodern |
|
15 |
- #:ubiquitous |
|
16 |
- #:ningle) |
|
8 |
+ #:cl-oid-connect |
|
9 |
+ #:cl-mustache |
|
10 |
+ #:parenscript |
|
11 |
+ #:alexandria |
|
12 |
+ #:anaphora |
|
13 |
+ #:ironclad |
|
14 |
+ #:clack-errors |
|
15 |
+ #:postmodern |
|
16 |
+ #:local-time |
|
17 |
+ #:cl-postgres+localtime |
|
18 |
+ #:crane |
|
19 |
+ #:ubiquitous |
|
20 |
+ #:ningle) |
|
17 | 21 |
:serial t |
18 | 22 |
:components ((:file "package") |
23 |
+ (:file "tables") |
|
19 | 24 |
(:file "inangulis"))) |
20 | 25 |
|
21 | 26 |
;; vim: set ft=lisp: |
... | ... |
@@ -1,21 +1,29 @@ |
1 | 1 |
(declaim (optimize (debug 3) (speed 0 ) (safety 3)) ) |
2 |
+ |
|
2 | 3 |
;;;; inangulis.lisp |
3 | 4 |
|
4 |
-(ql:quickload :clack-errors) |
|
5 | 5 |
(in-package #:inangulis) |
6 | 6 |
(defparameter *submissions* nil) |
7 | 7 |
(defparameter *by-distinct* (make-hash-table :test #'equalp)) |
8 | 8 |
(defparameter *users* (make-hash-table :test #'equalp)) |
9 |
+(defparameter *persist* t) |
|
10 |
+ |
|
11 |
+(defmacro cdr-assoc (&whole lis item alist &key key test test-not) |
|
12 |
+ `(cdr (assoc ,@(cdr lis)))) |
|
13 |
+ |
|
14 |
+(defun str-assoc (param params &key (test #'equal) key) |
|
15 |
+ (cdr-assoc param params :test test :key key)) |
|
16 |
+ |
|
17 |
+(defmacro setf1 (&body body) |
|
18 |
+ "Make setf a bit nicer" |
|
19 |
+ (list* 'setf (apply #'append body))) |
|
9 | 20 |
|
10 | 21 |
;;; "inangulis" goes here. Hacks and glory await! |
11 | 22 |
|
12 | 23 |
(defun current-date-string () |
13 | 24 |
"Returns current date as a string." |
14 |
- (multiple-value-bind (sec min hr day mon yr dow dst-p tz) |
|
15 |
- (get-decoded-time) |
|
16 |
- (declare (ignore dow dst-p)) |
|
17 |
- (format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d ~2,'0d" yr mon day hr min sec tz))) |
|
18 |
- |
|
25 |
+ (local-time:format-timestring nil (local-time:now) |
|
26 |
+ :format local-time:+rfc-1123-format+)) |
|
19 | 27 |
|
20 | 28 |
(defclass user () |
21 | 29 |
((uid :initarg :uid) |
... | ... |
@@ -29,25 +37,14 @@ |
29 | 37 |
("email" . ,email) |
30 | 38 |
("moderator" . ,moderator)))) |
31 | 39 |
|
32 |
-(defclass submission () |
|
33 |
- ((headline :initarg :headline :initform "" :accessor s-headline) |
|
34 |
- (url :initarg :url :initform "" :accessor s-url) |
|
35 |
- (date :initarg :date :initform "" :accessor s-date) |
|
36 |
- (approved :initarg :approved :initform "" :accessor s-approved))) |
|
37 |
- |
|
38 | 40 |
(defmethod print-object ((obj user) s) |
39 | 41 |
(print-unreadable-object (obj s :type t :identity t) |
40 | 42 |
(with-slots (uid email name moderator) obj |
41 | 43 |
(format s "U: ~s E: ~s N: ~s M: ~s" uid email name moderator)))) |
42 | 44 |
|
43 |
-(defmethod print-object ((obj submission) s) |
|
44 |
- (print-unreadable-object (obj s :type t :identity t) |
|
45 |
- (with-slots (headline url approved) obj |
|
46 |
- (format s "H: ~s U: ~s A: ~s" headline url approved)))) |
|
47 |
- |
|
48 | 45 |
(defun make-submission (headline url &key (approved "")) |
49 |
- (make-instance 'submission :headline headline :url url :approved approved |
|
50 |
- :date (current-date-string))) |
|
46 |
+ (alet 'inangulis.tables:submission |
|
47 |
+ (make-instance it :headline headline :url url :approved approved :date (current-date-string)))) |
|
51 | 48 |
|
52 | 49 |
(defun submission-alist (submission) |
53 | 50 |
`(("headline". ,(s-headline submission)) |
... | ... |
@@ -55,19 +52,18 @@ |
55 | 52 |
("date" . ,(s-url submission)) |
56 | 53 |
("approved" . ,(s-approved submission)))) |
57 | 54 |
|
58 |
-(defun alist-submission (alist &key nil-if-exists (modify t)) |
|
59 |
- (let* ((result (make-submission (cdr (assoc :headline alist :test #'string-equal)) |
|
60 |
- (cdr (assoc :url alist :test #'string-equal)) |
|
61 |
- :approved (aif (cdr (assoc :approved alist :test #'string-equal)) it ""))) |
|
62 |
- (key (cons (s-headline result) (s-url result)))) |
|
63 |
- (aif (gethash key *by-distinct*) |
|
64 |
- (progn |
|
65 |
- (when modify |
|
66 |
- (setf (s-url it) (s-url result) |
|
67 |
- (s-headline it) (s-headline result))) |
|
68 |
- (if nil-if-exists nil it)) |
|
69 |
- (progn |
|
70 |
- (setf (gethash key *by-distinct*) result) |
|
55 |
+(defun get-by-key (headline url) |
|
56 |
+ (car (postmodern:select-dao 'inangulis.tables::submission (:and (:= 'headline headline) (:= 'url url))))) |
|
57 |
+ |
|
58 |
+ |
|
59 |
+(defun alist-submission (alist &key nil-if-exists) |
|
60 |
+ (let* ((headline (cdr-assoc :headline alist :test #'string-equal)) |
|
61 |
+ (url (cdr-assoc :url alist :test #'string-equal)) |
|
62 |
+ (approved (or (cdr-assoc :approved alist :test #'string-equal) "")) |
|
63 |
+ (result (make-submission headline url :approved approved))) |
|
64 |
+ (with-slots ((headline inangulis.tables:headline) (url inangulis.tables:url)) result |
|
65 |
+ (aif (get-by-key headline url) |
|
66 |
+ (unless nil-if-exists it) |
|
71 | 67 |
result)))) |
72 | 68 |
|
73 | 69 |
|
... | ... |
@@ -76,6 +72,13 @@ |
76 | 72 |
|
77 | 73 |
(defparameter *app* (make-instance 'ningle:<app>)) |
78 | 74 |
|
75 |
+(defmacro i-defun (name (&rest args) &body body) |
|
76 |
+ `(defun ,name (,@args) |
|
77 |
+ (declare (ignorable ,@(loop for x in args |
|
78 |
+ if (not (char= (elt (symbol-name x) 0) #\&)) |
|
79 |
+ collect x))) |
|
80 |
+ ,@body)) |
|
81 |
+ |
|
79 | 82 |
(defmacro i-lambda ((&rest args) &body body) |
80 | 83 |
`(lambda (,@args) |
81 | 84 |
(declare (ignorable ,@args)) |
... | ... |
@@ -87,67 +90,38 @@ |
87 | 90 |
(read-sequence template s) |
88 | 91 |
(mustache:render* template data)))) |
89 | 92 |
|
93 |
+(defmacro with-db (&body b) |
|
94 |
+ `(postmodern:with-connection (ubiquitous:value 'db) |
|
95 |
+ ,@b)) |
|
96 |
+ |
|
97 |
+(defmacro with-submissions (&body b) |
|
98 |
+ `(with-db |
|
99 |
+ (let ((*submissions* (postmodern:select-dao 'inangulis.tables::submission t "date desc"))) |
|
100 |
+ ,@b))) |
|
101 |
+ |
|
102 |
+ |
|
90 | 103 |
(setf (ningle:route *app* "/") |
91 |
- (i-lambda (params) |
|
92 |
- (ningle.context:with-context-variables (session) |
|
93 |
- (handler-case |
|
94 |
- (cl-oid-connect.utils:ensure-logged-in |
|
95 |
- (cl-oid-connect.utils:redirect-if-necessary session |
|
96 |
- (render-mustache #p"static/index.mustache.html" |
|
97 |
- `((:links . ,(mapcar #'submission-alist *submissions*)) |
|
98 |
- (:user . ,(user-alist (gethash :app-user session))))))) |
|
99 |
- (cl-oid-connect.utils:user-not-logged-in |
|
100 |
- (c) |
|
101 |
- (render-mustache #p"static/index.mustache.html" |
|
102 |
- `((:links . ,(mapcar #'submission-alist (get-moderated *submissions*)))))))))) |
|
104 |
+ (flet ((render-index (&optional user) |
|
105 |
+ (render-mustache #p"static/index.mustache.html" |
|
106 |
+ (cons |
|
107 |
+ `(:links . ,(mapcar #'submission-alist *submissions*)) |
|
108 |
+ (when user |
|
109 |
+ (list |
|
110 |
+ `(:user . ,(user-alist user)))))))) |
|
111 |
+ (i-lambda (params) |
|
112 |
+ (with-submissions |
|
113 |
+ (ningle.context:with-context-variables (session) |
|
114 |
+ (handler-case |
|
115 |
+ (cl-oid-connect.utils:ensure-logged-in |
|
116 |
+ (cl-oid-connect.utils:redirect-if-necessary session |
|
117 |
+ (render-index (gethash :app-user session)))) |
|
118 |
+ (cl-oid-connect.utils:user-not-logged-in (c) (render-index)))))))) |
|
103 | 119 |
|
104 | 120 |
(defun submit (params) |
105 |
- (awhen (alist-submission params :nil-if-exists t) |
|
106 |
- ;(format t "~s <<<" it) |
|
107 |
- (push it *submissions*))) |
|
108 |
- |
|
109 |
-(defun get-by-key (headline url) |
|
110 |
- (gethash (cons headline url) *by-distinct*)) |
|
111 |
- |
|
112 |
-(setf (ningle:route *app* "/murmuro" :method :POST) |
|
113 |
- (i-lambda (params) |
|
114 |
- (sleep 0.01) |
|
115 |
- (submit params) |
|
116 |
- '(302 (:location "/") ("Done")))) |
|
117 |
- |
|
118 |
-(setf (ningle:route *app* "/curo" :method :POST) |
|
119 |
- (i-lambda (params) |
|
120 |
- (cl-oid-connect.utils:require-login |
|
121 |
- (alet (alist-submission params :modify nil) |
|
122 |
- (let ((approval (string-downcase (cdr (assoc "approved" params :test #'equalp))))) |
|
123 |
- (setf (s-approved it) |
|
124 |
- (if (equal approval "+") "approved" |
|
125 |
- (if (equal approval "-") "rejected")))))) |
|
126 |
- '(302 (:location "/") ("Done")))) |
|
127 |
- |
|
128 |
-(setf (ningle:route *app* "/1" :method :GET) |
|
129 |
- (i-lambda (params) |
|
130 |
- `(200 () |
|
131 |
- (,(format nil "~a" (/ 1 0)))))) |
|
132 |
- |
|
133 |
-(setf (ningle:route *app* "/login" :method :GET) |
|
134 |
- (i-lambda (params) |
|
135 |
- `(200 () |
|
136 |
- (,(cl-who:with-html-output-to-string (s) |
|
137 |
- (:html |
|
138 |
- (:head |
|
139 |
- (:title "Login") |
|
140 |
- (:link :rel "stylesheet" :href "/static/css/login.css")) |
|
141 |
- (:body |
|
142 |
- (:h1 "In Angulis") |
|
143 |
- (:div :class "login-buttons" |
|
144 |
- (:a :class "facebook" :href "/login/facebook" "Login With Facebook"))))))))) |
|
145 |
- |
|
146 |
-(cl-oid-connect:def-route ("/logout" (params) :app *app*) |
|
147 |
- (declare (ignore params)) |
|
148 |
- (ningle:with-context-variables (session) |
|
149 |
- (setf (gethash :userinfo session) nil) |
|
150 |
- '(302 (:location "/")))) |
|
121 |
+ (with-db |
|
122 |
+ (awhen (alist-submission params :nil-if-exists t) |
|
123 |
+ (postmodern:insert-dao it) |
|
124 |
+ (push it *submissions*)))) |
|
151 | 125 |
|
152 | 126 |
(defun get-feed-guid (item) |
153 | 127 |
(with-slots (alimenta:title alimenta:link) item |
... | ... |
@@ -156,31 +130,64 @@ |
156 | 130 |
(ironclad:update-digest hasher (ironclad:ascii-string-to-byte-array alimenta:link)) |
157 | 131 |
(ironclad:byte-array-to-hex-string (ironclad:produce-digest hasher))))) |
158 | 132 |
|
159 |
-(setf (ningle:route *app* "/feed" :method :GET) |
|
160 |
- (i-lambda (params) |
|
161 |
- (let ((feed (alimenta::make-feed :title "In Angulis" :link "http://srv2.elangley.org:9090/feed" |
|
162 |
- :description "Locus in quo sunt illi qui murmurant in angulis"))) |
|
163 |
- (loop for submission in (reverse (get-moderated *submissions*)) |
|
164 |
- do (alimenta::add-item-to-feed feed |
|
165 |
- :title (s-headline submission) |
|
166 |
- :link (s-url submission) |
|
167 |
- :date (current-date-string) |
|
168 |
- :next-id #'get-feed-guid |
|
169 |
- :content "")) |
|
170 |
- `(200 (:content-type "application/rss+xml") (,(plump:serialize (alimenta:generate-xml feed) nil)))))) |
|
171 |
- |
|
172 |
-(setf (ningle:route *app* "/firehose" :method :GET) |
|
173 |
- (i-lambda (params) |
|
174 |
- (let ((feed (alimenta::make-feed :title "In Angulis" :link "http://srv2.elangley.org:9090/feed" |
|
175 |
- :description "Locus in quo sunt illi qui murmurant in angulis"))) |
|
176 |
- (loop for submission in (reverse *submissions*) |
|
177 |
- do (alimenta::add-item-to-feed feed |
|
178 |
- :title (s-headline submission) |
|
179 |
- :link (s-url submission) |
|
180 |
- :date (current-date-string) |
|
181 |
- :next-id #'get-feed-guid |
|
182 |
- :content "")) |
|
183 |
- `(200 (:content-type "application/rss+xml") (,(plump:serialize (alimenta:generate-xml feed) nil)))))) |
|
133 |
+;; View Controllers |
|
134 |
+(i-defun murmur (params) |
|
135 |
+ (sleep 0.01) |
|
136 |
+ (submit params) |
|
137 |
+ '(302 (:location "/") ("Done"))) |
|
138 |
+ |
|
139 |
+(i-defun curate (params) |
|
140 |
+ (with-db |
|
141 |
+ (let ((*submissions* (postmodern:select-dao 'inangulis.tables::submission t "date desc"))) |
|
142 |
+ (cl-oid-connect.utils:require-login |
|
143 |
+ (alet (alist-submission params) |
|
144 |
+ (let ((approval (string-downcase (str-assoc "approved" params :test #'equalp)))) |
|
145 |
+ (setf (s-approved it) |
|
146 |
+ (if (equal approval "+") "approved" |
|
147 |
+ (if (equal approval "-") "rejected"))) |
|
148 |
+ (when *persist* |
|
149 |
+ (postmodern:update-dao it))))))) |
|
150 |
+ '(302 (:location "/") ("Done"))) |
|
151 |
+ |
|
152 |
+(i-defun login-page (params) |
|
153 |
+ `(200 () |
|
154 |
+ (,(cl-who:with-html-output-to-string (s) |
|
155 |
+ (:html |
|
156 |
+ (:head |
|
157 |
+ (:title "Login") |
|
158 |
+ (:link :rel "stylesheet" :href "/static/css/login.css")) |
|
159 |
+ (:body |
|
160 |
+ (:h1 "In Angulis") |
|
161 |
+ (:div :class "login-buttons" |
|
162 |
+ (:a :class "facebook" :href "/login/facebook" "Login With Facebook")))))))) |
|
163 |
+ |
|
164 |
+(i-defun logout (params) |
|
165 |
+ (ningle:with-context-variables (session) |
|
166 |
+ (setf (gethash :userinfo session) nil) |
|
167 |
+ '(302 (:location "/")))) |
|
168 |
+ |
|
169 |
+(i-defun get-feed (params &key moderated) |
|
170 |
+ (let ((feed (alimenta::make-feed :title "In Angulis" :link "http://in-angulis.com/feed" |
|
171 |
+ :description "Locus in quo sunt illi qui murmurant in angulis"))) |
|
172 |
+ (with-db |
|
173 |
+ (pomo:do-select-dao (('inangulis.tables::submission submission) |
|
174 |
+ (:raw (if moderated (pomo:sql (:= 'approved "approved")) "'t'")) |
|
175 |
+ (:desc 'date)) |
|
176 |
+ (alimenta::add-item-to-feed feed |
|
177 |
+ :title (s-headline submission) |
|
178 |
+ :link (s-url submission) |
|
179 |
+ :date (s-date submission) |
|
180 |
+ :next-id #'get-feed-guid |
|
181 |
+ :content ""))) |
|
182 |
+ `(200 (:content-type "application/rss+xml") (,(plump:serialize (alimenta:generate-xml feed) nil))))) |
|
183 |
+ |
|
184 |
+(setf1 ((ningle:route *app* "/feed" :method :GET) (lambda (params) (get-feed params :moderated t))) |
|
185 |
+ ((ningle:route *app* "/firehose" :method :GET) #'get-feed) |
|
186 |
+ ((ningle:route *app* "/login" :method :GET) #'login-page) |
|
187 |
+ ((ningle:route *app* "/curo" :method :POST) #'curate) |
|
188 |
+ ((ningle:route *app* "/murmuro" :method :POST) #'murmur) |
|
189 |
+ ((ningle:route *app* "/logout" :method :POST) #'logout)) |
|
190 |
+ |
|
184 | 191 |
|
185 | 192 |
(cl-oid-connect::setup-oid-connect *app* (userinfo &rest args) |
186 | 193 |
(declare (ignore args)) |
... | ... |
@@ -1,8 +1,9 @@ |
1 | 1 |
;;;; package.lisp |
2 | 2 |
|
3 |
-(defpackage #:inangulis |
|
4 |
- (:use #:cl #:anaphora)) |
|
5 |
- |
|
6 | 3 |
(defpackage #:inangulis.tables |
4 |
+ (:use #:cl #:anaphora #:postmodern) |
|
5 |
+ (:export #:submission #:headline #:url #:date #:approved)) |
|
6 |
+ |
|
7 |
+(defpackage #:inangulis |
|
7 | 8 |
(:use #:cl #:anaphora)) |
8 | 9 |
|
9 | 10 |
new file mode 100644 |
... | ... |
@@ -0,0 +1,27 @@ |
1 |
+(in-package :inangulis.tables) |
|
2 |
+ |
|
3 |
+(eval-when (:compile-toplevel :load-toplevel :execute) |
|
4 |
+ (local-time:set-local-time-cl-postgres-readers)) |
|
5 |
+ |
|
6 |
+(defclass submission () |
|
7 |
+ ((headline :initarg :headline :col-type text :initform "" :accessor inangulis::s-headline) |
|
8 |
+ (url :initarg :url :col-type text :initform "" :accessor inangulis::s-url) |
|
9 |
+ (date :initarg :date :col-type timestamp-with-timezone :initform "") |
|
10 |
+ (approved :initarg :approved :col-type text :initform "" :accessor inangulis::s-approved)) |
|
11 |
+ (:metaclass dao-class) |
|
12 |
+ (:keys headline url)) |
|
13 |
+ |
|
14 |
+(deftable submission |
|
15 |
+ (!dao-def)) |
|
16 |
+ |
|
17 |
+;(with-connection (ubiquitous:value 'db) |
|
18 |
+; (create-table 'submission)) |
|
19 |
+ |
|
20 |
+(defmethod inangulis::s-date ((object submission)) |
|
21 |
+ (with-slots (date) object |
|
22 |
+ (local-time:format-timestring nil date :format local-time:+rfc-1123-format+))) |
|
23 |
+ |
|
24 |
+(defmethod print-object ((obj submission) s) |
|
25 |
+ (print-unreadable-object (obj s :type t :identity t) |
|
26 |
+ (with-slots (headline url approved) obj |
|
27 |
+ (format s "H: ~s U: ~s A: ~s" headline url approved)))) |