Browse code
Various reorganizations
Moving a bunch of macros and utilities out of rss.lisp to utils.lisp
to make them more reusable.
cl-oid-connect now depends on utils.
General clearnup
Showing 6 changed files
... | ... |
@@ -35,6 +35,17 @@ |
35 | 35 |
|
36 | 36 |
(in-package :cl-oid-connect) |
37 | 37 |
; Should this be here? |
38 |
+ |
|
39 |
+(eval-when (:compile-toplevel :execute) |
|
40 |
+ (defun vars-to-symbol-macrolets (vars obj) |
|
41 |
+ (iterate:iterate (iterate:for var in vars) |
|
42 |
+ (iterate:collect `(,var (gethash ,(alexandria:make-keyword var) ,obj)))))) |
|
43 |
+ |
|
44 |
+(defmacro with-session-values (vars session &body body) |
|
45 |
+ (alexandria:once-only (session) |
|
46 |
+ `(symbol-macrolet ,(vars-to-symbol-macrolets vars session) |
|
47 |
+ ,@body))) |
|
48 |
+ |
|
38 | 49 |
(defparameter *oid* (make-instance 'ningle:<app>)) |
39 | 50 |
(setf drakma:*text-content-types* (cons '("application" . "json") drakma:*text-content-types*)) |
40 | 51 |
|
... | ... |
@@ -57,14 +68,11 @@ |
57 | 68 |
(defparameter *fbook-info* (sheeple:clone =service-info=)) |
58 | 69 |
(defparameter *goog-info* (sheeple:clone =service-info=)) |
59 | 70 |
(defparameter *endpoint-schema* nil) |
60 |
-; goog is well behaved |
|
61 | 71 |
(defparameter *goog-endpoint-schema* (defobject (=endpoint-schema= *goog-info*))) |
62 | 72 |
|
63 |
-(defun get-base-url (request) (format nil "~a//~a/oidc_callback" |
|
64 |
- (lack.request:request-query-parameters) |
|
65 |
- )) |
|
73 |
+(defun get-base-url (request) |
|
74 |
+ (format nil "~a//~a/oidc_callback" (lack.request:request-query-parameters))) |
|
66 | 75 |
|
67 |
-; fbook needs personal attention |
|
68 | 76 |
(defproto *fbook-endpoint-schema* (=endpoint-schema= *fbook-info*) |
69 | 77 |
((auth-endpoint "https://www.facebook.com/dialog/oauth") |
70 | 78 |
(token-endpoint "https://graph.facebook.com/v2.3/oauth/access_token") |
... | ... |
@@ -267,15 +275,6 @@ |
267 | 275 |
(iterate:for value in (cdr rest) by #'cddr) |
268 | 276 |
(iterate:collect `(setf (gethash ,(alexandria:make-keyword (key)) ,session) ,value))))) |
269 | 277 |
|
270 |
-(defun vars-to-symbol-macrolets (vars obj) |
|
271 |
- (iterate:iterate (iterate:for var in vars) |
|
272 |
- (iterate:collect `(,var (gethash ,(alexandria:make-keyword var) ,obj))))) |
|
273 |
- |
|
274 |
-(defmacro with-session-values (vars session &body body) |
|
275 |
- (alexandria:once-only (session) |
|
276 |
- `(symbol-macrolet ,(vars-to-symbol-macrolets vars session) |
|
277 |
- ,@body))) |
|
278 |
- |
|
279 | 278 |
(defun facebook-callback (login-callback) |
280 | 279 |
(lambda (params) |
281 | 280 |
(let ((received-state (cdr (string-assoc "state" params))) |
... | ... |
@@ -13,18 +13,15 @@ |
13 | 13 |
(ql:quickload :iterate) |
14 | 14 |
(ql:quickload :jonathan) |
15 | 15 |
|
16 |
-(declaim (optimize (speed 0) (safety 2) (debug 2))) |
|
16 |
+(declaim (optimize (speed 0) (safety 3) (debug 2))) |
|
17 | 17 |
|
18 | 18 |
(push (cons "application" "rdf+xml") drakma:*text-content-types*) |
19 | 19 |
(push (cons "application" "rss+xml") drakma:*text-content-types*) |
20 | 20 |
(push (cons "text" "rss+xml") drakma:*text-content-types*) |
21 | 21 |
|
22 |
-(defpackage whitespace.utils |
|
23 |
- (:use #:cl)) |
|
24 |
-(load "utils.lisp") |
|
25 |
- |
|
26 | 22 |
(load "rss.lisp") |
27 | 23 |
|
24 |
+ |
|
28 | 25 |
(defpackage :whitespace |
29 | 26 |
(:use #:cl #:whitespace.utils #:whitespace.rss #:whitespace.tables)) |
30 | 27 |
|
... | ... |
@@ -15,7 +15,9 @@ |
15 | 15 |
#:lass |
16 | 16 |
#:lquery |
17 | 17 |
#:plump |
18 |
- #:sheeple) |
|
18 |
+ #:sheeple |
|
19 |
+ #:whitespace.utils |
|
20 |
+ ) |
|
19 | 21 |
(:export |
20 | 22 |
#:redirect-if-necessary |
21 | 23 |
#:def-route |
... | ... |
@@ -24,5 +26,6 @@ |
24 | 26 |
#:with-session |
25 | 27 |
#:assoc-cdr |
26 | 28 |
#:session ; private!! |
29 |
+ #:vars-to-symbol-macrolets |
|
27 | 30 |
)) |
28 | 31 |
|
... | ... |
@@ -1,55 +1,27 @@ |
1 | 1 |
(in-package :cl-user) |
2 |
+(declaim (optimize (safety 3) (speed 0) (debug 3))) |
|
2 | 3 |
|
3 | 4 |
(load "tables.lisp") |
4 | 5 |
|
5 | 6 |
(defpackage :whitespace.rss |
6 | 7 |
(:use #:cl #:alexandria #:postmodern #:lquery #:cl-syntax #:cl-annot.syntax #:cl-annot.class |
7 |
- #:whitespace.tables #:iterate) |
|
8 |
+ #:whitespace.tables #:iterate #:whitespace.utils) |
|
8 | 9 |
(:import-from anaphora it)) |
9 | 10 |
|
10 | 11 |
|
11 | 12 |
(in-package :whitespace.rss) |
12 | 13 |
(cl-annot.syntax:enable-annot-syntax) |
13 | 14 |
|
14 |
-(defun ensure-mapping (list) |
|
15 |
- "Make sure that each item of the list is a pair of symbols" |
|
16 |
- (mapcar (lambda (x) (if (symbolp x) (list x x) x)) list)) |
|
17 |
- |
|
18 |
-(defun alist-string-hash-table (alist) |
|
19 |
- (alexandria:alist-hash-table alist :test #'string=)) |
|
20 |
- |
|
21 |
-(defun transform-alist (pair-transform alist) |
|
22 |
- (iterate (for (k . v) in-sequence alist) |
|
23 |
- (collect |
|
24 |
- (funcall pair-transform k v)))) |
|
25 |
- |
|
26 |
-(defun %json-pair-transform (k v) |
|
27 |
- (cons (make-keyword (string-downcase k)) |
|
28 |
- (typecase v |
|
29 |
- (string (coerce v 'simple-string)) |
|
30 |
- (t v)))) |
|
31 |
- |
|
32 |
-(defun %default-pair-transform (k v) |
|
33 |
- (cons (make-keyword (string-upcase k)) v)) |
|
34 |
- |
|
35 |
-(defun make-pairs (symbols) |
|
36 |
- (cons 'list (iterate (for (key value) in symbols) |
|
37 |
- (collect (list 'list* (symbol-name key) value))))) |
|
38 |
- |
|
39 |
-@export |
|
40 |
-(defmacro copy-slots (slots from-v to-v) |
|
41 |
- (with-gensyms (from to) |
|
42 |
- `(let ((,from ,from-v) (,to ,to-v)) |
|
43 |
- ,@(iterate (for (fro-slot to-slot) in (ensure-mapping slots)) |
|
44 |
- (collect `(setf (slot-value ,to ',to-slot) (slot-value ,from ',fro-slot)))) |
|
45 |
- ,to))) |
|
46 |
- |
|
47 |
-@export |
|
48 |
-(defmacro default-when (default test &body body) |
|
49 |
- (once-only (default) |
|
50 |
- `(or (when ,test |
|
51 |
- ,@body) |
|
52 |
- ,default))) |
|
15 |
+(lquery:define-lquery-list-function tag-name (nodes &rest tags) |
|
16 |
+ "Manipulate elements on the basis of their tag-name. |
|
17 |
+ With no arguments, return their names else return |
|
18 |
+ the corresponding tags." |
|
19 |
+ (if (null tags) |
|
20 |
+ (map 'vector #'plump:tag-name nodes) |
|
21 |
+ (apply #'vector |
|
22 |
+ (loop for node across nodes |
|
23 |
+ if (find (plump:tag-name node) tags :test #'string=) |
|
24 |
+ collect node)))) |
|
53 | 25 |
|
54 | 26 |
@export |
55 | 27 |
(defmacro get-elements (feed &optional (filter nil)) |
... | ... |
@@ -67,18 +39,6 @@ |
67 | 39 |
(defmacro extract-text (selector &optional (default "")) |
68 | 40 |
`(or (lquery:$ ,selector (text) (node)) ,default)) |
69 | 41 |
|
70 |
-(defmacro transform-result ((list-transform pair-transform) &body alist) |
|
71 |
- `(funcall ,list-transform |
|
72 |
- (transform-alist ,pair-transform |
|
73 |
- ,@alist))) |
|
74 |
- |
|
75 |
- |
|
76 |
-(defmacro slots-to-pairs (obj (&rest slots)) |
|
77 |
- (alexandria:once-only (obj) |
|
78 |
- (let ((slots (ensure-mapping slots))) |
|
79 |
- `(with-slots ,(mapcar #'cadr slots) ,obj |
|
80 |
- ,(make-pairs slots))))) |
|
81 |
- |
|
82 | 42 |
(defmacro defserializer ((specializes) &body slots) |
83 | 43 |
(with-gensyms (obj o-t p-t) |
84 | 44 |
`(defmethod serialize ((,obj ,specializes) &optional (,o-t #'identity) (,p-t #'%default-pair-transform)) |
... | ... |
@@ -152,7 +112,7 @@ |
152 | 112 |
(collect item)))) |
153 | 113 |
|
154 | 114 |
(defserializer (rss-item) |
155 |
- title link (description description-raw) guid pub-date source) |
|
115 |
+ title link (description description-raw :bind-from description-raw) guid pub-date source) |
|
156 | 116 |
|
157 | 117 |
; this is the interface to be used |
158 | 118 |
(defserializer (rss_feed_store) |
... | ... |
@@ -189,10 +149,12 @@ |
189 | 149 |
(make-instance-from-symbols 'rss_item_store id title link (description description-raw) |
190 | 150 |
guid pub-date source feed (fetch-defaults t)))))) |
191 | 151 |
|
152 |
+(define-condition blarg () ((text :initarg text))) |
|
192 | 153 |
@export |
193 | 154 |
(defun get-feed-from-dao (rss-feed) |
194 | 155 |
(let ((feed-dao (get-dao-for rss-feed))) |
195 | 156 |
(list feed-dao |
157 |
+ (error 'blarg :text (format t "~a~%" rss-feed)) |
|
196 | 158 |
(with-slots (items) rss-feed |
197 | 159 |
(iterate (for item in items) |
198 | 160 |
(collect (get-dao-for item (slot-value feed-dao 'id)))))))) |
... | ... |
@@ -1,13 +1,69 @@ |
1 |
+(defpackage whitespace.utils |
|
2 |
+ (:use #:cl #:alexandria #:iterate)) |
|
3 |
+ |
|
1 | 4 |
(in-package whitespace.utils) |
2 |
-(lquery:define-lquery-list-function tag-name (nodes &rest tags) |
|
3 |
- "Manipulate elements on the basis of there tag-name. |
|
4 |
- With no arguments, return their names else return |
|
5 |
- the corresponding tags." |
|
6 |
- (if (null tags) |
|
7 |
- (map 'vector #'plump:tag-name nodes) |
|
8 |
- (apply #'vector |
|
9 |
- (loop for node across nodes |
|
10 |
- if (find (plump:tag-name node) tags :test #'string=) |
|
11 |
- collect node)))) |
|
5 |
+ |
|
6 |
+(defun ensure-mapping (list) |
|
7 |
+ "Make sure that each item of the list is a pair of symbols" |
|
8 |
+ (mapcar (lambda (x) (if (symbolp x) (list x x) x)) list)) |
|
9 |
+(export 'ensure-mapping) |
|
10 |
+ |
|
11 |
+(defun alist-string-hash-table (alist) |
|
12 |
+ (alexandria:alist-hash-table alist :test #'string=)) |
|
13 |
+(export 'alist-string-hash-table) |
|
14 |
+ |
|
15 |
+(defun make-pairs (symbols) |
|
16 |
+ (cons 'list (iterate (for (key value) in symbols) |
|
17 |
+ (collect (list 'list* (symbol-name key) value))))) |
|
18 |
+(export 'make-pairs) |
|
19 |
+ |
|
20 |
+(defmacro copy-slots (slots from-v to-v) |
|
21 |
+ (with-gensyms (from to) |
|
22 |
+ `(let ((,from ,from-v) (,to ,to-v)) |
|
23 |
+ ,@(iterate (for (fro-slot to-slot) in (ensure-mapping slots)) |
|
24 |
+ (collect `(setf (slot-value ,to ',to-slot) (slot-value ,from ',fro-slot)))) |
|
25 |
+ ,to))) |
|
26 |
+(export 'copy-slots) |
|
27 |
+ |
|
28 |
+ |
|
29 |
+(defun transform-alist (pair-transform alist) |
|
30 |
+ (iterate (for (k . v) in-sequence alist) |
|
31 |
+ (collect |
|
32 |
+ (funcall pair-transform k v)))) |
|
33 |
+(export 'transform-alist) |
|
34 |
+ |
|
35 |
+(defun %json-pair-transform (k v) |
|
36 |
+ (cons (make-keyword (string-downcase k)) |
|
37 |
+ (typecase v |
|
38 |
+ (string (coerce v 'simple-string)) |
|
39 |
+ (t v)))) |
|
40 |
+(export '%json-pair-transform) |
|
41 |
+ |
|
42 |
+(defun %default-pair-transform (k v) |
|
43 |
+ (cons (make-keyword (string-upcase k)) v)) |
|
44 |
+(export '%default-pair-transform) |
|
45 |
+ |
|
46 |
+(defmacro default-when (default test &body body) |
|
47 |
+ (once-only (default) |
|
48 |
+ `(or (when ,test |
|
49 |
+ ,@body) |
|
50 |
+ ,default))) |
|
51 |
+(export 'default-when) |
|
52 |
+ |
|
53 |
+(defmacro transform-result ((list-transform pair-transform) &body alist) |
|
54 |
+ `(funcall ,list-transform |
|
55 |
+ (transform-alist ,pair-transform |
|
56 |
+ ,@alist))) |
|
57 |
+(export 'transform-result) |
|
58 |
+ |
|
59 |
+ |
|
60 |
+(defmacro slots-to-pairs (obj (&rest slots)) |
|
61 |
+ (once-only (obj) |
|
62 |
+ (let* ((slots (ensure-mapping slots)) |
|
63 |
+ (bindings (iterate (for (slot v &key bind-from) in slots) |
|
64 |
+ (collect (or bind-from slot))))) |
|
65 |
+ `(with-slots ,bindings ,obj |
|
66 |
+ ,(make-pairs slots))))) |
|
67 |
+(export 'slots-to-pairs) |
|
12 | 68 |
|
13 | 69 |
|