(defpackage #:lazybones/client.parenscript
  (:use #:cl)
  (:local-nicknames (#:lzb #:lazybones)
                    (#:a #:alexandria))
  (:export #:generate
           #:generate-js))

(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 &optional body-vars)
  #+testiere
  (:tests
   (equalp
    (client-function-lambda-list '("*SESSION*"))
    '(*session*))

   (equalp
    (client-function-lambda-list '("a.x" "b/y" "c") '(q r))
    '(a-x b-y c &key q r))

   (equalp
    (client-function-lambda-list '("pl" "foo") '(title url))
    '(pl foo &key title url)))

  (nconc (mapcar (a:compose #'intern #'string-upcase #'lispify) variables)
         (when body-vars (cons '&key body-vars))))

(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-vars
           (lzb:endpoint-body-variables ep))

         (lambda-list
           (client-function-lambda-list variables body-vars))

         (body-serializtion-code
           (when body-vars
             (cond ((equal "application/json" content-type)
                    `(ps:chain
                      -j-s-o-n
                      (stringify (ps:create
                                  ,@(loop :for var :in body-vars
                                          :collect var
                                          :collect var)))))

                   ((equal "multipart/form-data" content-type)
                    (let ((fd (gensym "FORMDATA")))
                      `((lambda ()
                          (let ((,fd (new -form-data)))
                            ,@(loop :for v :in body-vars
                                    :for s := (string-downcase (symbol-name v))
                                    :collect `(ps:chain ,fd (append ,s ,v)))
                            ,fd)))))

                   (t (error "Cannot automatically encode bodies for ~s"
                             content-type)))))

         (fetch-path
           (client-function-endpoint-path (lzb::app-prefix app) pattern)))
    
    `(defun ,function-name ,lambda-list
       ,(if body-vars
            `(fetch ,fetch-path
                    (ps:create
                     method ,method-name
                     headers  (ps:create "Content-Type" ,content-type)
                     redirect "follow"
                     body ,body-serializtion-code))
            `(fetch ,fetch-path)))))

(defun generate (app)
  (let* ((module
           (gensym "MODULE"))

         (module-name
           (intern (lispify (concatenate 'string "-" (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)))))

(defun generate-js (app)
  (eval `(ps:ps ,(generate app))))