aboutsummaryrefslogtreecommitdiff
path: root/src/client/ps/generate.lisp
blob: d6a5aef2b657402032a1f93b27e74e958dbb5408 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
(defpackage #:weekend.client.ps
  (:use #:cl)
  (:import-from #:flatbind #:do>)
  (:local-nicknames
   (#:wknd #:weekend)
   (#:a #:alexandria-2))
  (:export #:generate))

(in-package #:weekend.client.ps)


;; this function largely mirrors the implementation of construct-route-builder
(defun generate (class &optional alt-name)
  (when (symbolp class) (setf class (find-class class)))

  (let*
      ((args
         (mapcar (a:compose #'intern #'string)
                 (wknd:class-initargs class)))
       (parts
         (loop
           :for part :in (wknd:route-builder-parts class)
           :when (or (stringp part) (characterp part))
             :collect part
           :else
             :collect (intern (string part))))
       (method
         (wknd:request-method class))
       
       (body
         (when (wknd:body-expected-p method)
           `(ps:chain -J-S-O-N
                      (stringify
                       (ps:create
                        ,@(loop :for arg :in args
                                :collect arg :collect arg))))))
       (url-param-names
         (unless (wknd:body-expected-p method)
           (set-difference args parts :test 'eq)))
       (url-params
         (when url-param-names
           (cons "?"
                 (loop :for (param . more) :on url-param-names
                       :collect (string param)
                       :collect "="
                       :collect param
                       :when more
                         :collect "&")))))
    `(defun ,(or alt-name (class-name class)) ,args
       (fetch (+ ,@parts ,@url-params)
              (ps:create
               method ,(string method)
               cache "no-cache"
               headers (ps:create "Content-Type" "application/json")
               redirect "follow"
               ,@(when body (list 'body body)))))))