git.fiddlerwoaroof.com
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

fiddlerwoaroof authored on 27/09/2015 05:12:10
Showing 6 changed files
... ...
@@ -17,9 +17,11 @@
17 17
                 :lquery
18 18
                 :plump
19 19
                 :cl-who
20
-                :postmodern)
20
+                :postmodern
21
+                :iterate)
21 22
   :serial t
22
-  :components ((:file "package")
23
+  :components ((:file "utils")
24
+               (:file "package")
23 25
                (:file "cl-oid-connect")))
24 26
 
25 27
 
... ...
@@ -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