1 files changed, 138 insertions, 0 deletions
diff --git a/src/client/parenscript.lisp b/src/client/parenscript.lisp
index 75afbd7..bb9cc3a 100644
--- a/src/client/parenscript.lisp
+++ b/src/client/parenscript.lisp
@@ -1,3 +1,141 @@
 (defpackage #:lazybones/client.parenscript
   (:use #:cl)
+  (:local-nicknames (#:lzb #:lazybones)
+                    (#:a #:alexandria))
   (:export #:generate))
+
+(in-package :lazybones/client.parenscript)
+
+(defun lispify (str)
+  #+testiere
+  (:tests
+   (equalp (lispify "a.b") "a-b")
+   (equalp (lispify "a/b") "a-b"))
+  (with-output-to-string (out)
+    (loop :for c :across str :do
+      (write-char
+       (if (find c "./") #\- c)
+       out))))
+
+(defun client-function-name (method pattern)
+  "Return a symbol; the name of the parenscript function that will make
+an HTTP request of type METHOD at the path implied by PATTERN. PATTERN
+is the value of the endpoint's DISPATCH-PATTERN slot."
+  #+testiere
+  (:tests
+   (string-equal
+    (client-function-name
+     :get '("" "session" ("doesn't" :matter) "notifications"))
+    'get-session-notifications)
+   (string-equal
+    (client-function-name
+     :post '("" "foo.bar" "moo"))
+    'post-foo-bar-moo))
+
+  (intern
+   (lispify
+    (string-upcase
+     (format nil "~a-~{~a~^-~}"
+             method
+             (remove-if-not (a:conjoin #'stringp (complement #'a:emptyp))
+                            pattern))))))
+
+(defun client-function-lambda-list (variables body?)
+  #+testiere
+  (:tests
+   (equalp
+    (client-function-lambda-list '("*SESSION*") nil)
+    '(*session*))
+
+   (equalp
+    (butlast (client-function-lambda-list '("a.x" "b/y" "c") t))
+    '(a-x b-y c &optional)))
+
+  (nconc (mapcar (a:compose #'intern #'string-upcase #'lispify) variables)
+         (when body? (list '&optional (gensym "BODY")))))
+
+(defun client-function-endpoint-path (prefix pattern)
+  #+testiere
+  (:tests
+   (equalp
+    (client-function-endpoint-path
+     "/api" '("" "session" ("id" :blahblah) "notifications"))
+    '(+ "/api" "/" "session" "/"  id "/" "notifications")))
+  (list* '+ prefix
+         (loop :for x :in pattern
+               :unless (zerop (length x))
+                 :collect "/"
+                 :and :collect (if (consp x)
+                                   (intern (string-upcase (first x)))
+                                   x))))
+
+(defun method-accepts-body? (m)
+  (member m '(:post :put :patch)))
+
+(defun generate-endpoint-form (app ep)
+  (let* ((method
+           (lzb:endpoint-method ep))
+
+         (method-name
+           (symbol-name method))
+
+         (content-type
+           (or (lzb:endpoint-content-type ep)
+               (lzb::default-content-type app)))
+
+         (pattern
+           (lzb:endpoint-dispatch-pattern ep))
+
+         (variables
+           (lzb:endpoint-route-variables ep))
+
+         (function-name
+           (client-function-name method pattern))
+
+         (body?
+            (method-accepts-body? method))
+
+         (lambda-list
+           (client-function-lambda-list variables body?))
+
+         (body
+           (when body?
+             (first (last lambda-list))))
+         
+         (fetch-path
+           (client-function-endpoint-path (lzb::app-prefix app) pattern)))
+    
+    `(defun ,function-name ,lambda-list
+       ,(if body
+            `(fetch ,fetch-path
+                    (ps:create
+                     method ,method-name
+                     headers  (ps:create "Content-Type" ,content-type)
+                     redirect "follow"
+                     body ,body))
+            `(fetch ,fetch-path)))))
+
+(defun generate (app)
+  (let* ((module
+           (gensym "MODULE"))
+
+         (module-name
+           (intern (lispify (symbol-name (lzb::app-name app)))))
+
+         (defuns
+           (loop :for ep :in (lzb:app-endpoints app)
+                 :collect (generate-endpoint-form app ep)))
+
+         (exports
+           (loop :for defun :in defuns
+                 :for name := (second defun)
+                 :collect `(ps:@ ,module ,name)
+                 :collect name)))
+    
+    `(defvar ,module-name
+       ((lambda (,module)
+          ,@defuns
+          (setf ,@exports)
+          ,module)
+        (ps:create)))))
+