69 lines
2.6 KiB
Common Lisp
69 lines
2.6 KiB
Common Lisp
;;;; cl-scopes/web/client - web client functionality
|
|
|
|
(defpackage :scopes/web/client
|
|
(:use :common-lisp)
|
|
(:local-nicknames (:config :scopes/config)
|
|
(:core :scopes/core)
|
|
(:message :scopes/core/message)
|
|
(:shape :scopes/shape)
|
|
(:util :scopes/util)
|
|
(:alx :alexandria)
|
|
(:jzon :com.inuoe.jzon))
|
|
(:export #:config #:base-url #:api-path #:doc-path
|
|
#:get-page #:send-message
|
|
#:urlencoded #:json))
|
|
|
|
(in-package :scopes/web/client)
|
|
|
|
(defvar *cookie-jar* (cl-cookie:make-cookie-jar))
|
|
|
|
(defclass config (config:base)
|
|
((config:setup :initform (core:make-setup :class 'core:context))
|
|
(base-url :reader base-url :initarg :base-url :initform "http://localhost:8135")
|
|
(doc-path :reader doc-path :initarg :doc-path :initform "/")
|
|
(credentials :reader credentials :initarg :credentials :initform nil)
|
|
(api-path :reader api-path :initarg :api-path :initform "/api/")
|
|
(accept :reader accept :initarg :accept :initform "text/html")
|
|
(data-renderer :reader data-renderer :initarg :data-renderer :initform #'urlencoded)
|
|
))
|
|
|
|
;;;; client context (= service)
|
|
|
|
(defun get-page (ctx msg)
|
|
(let* ((cfg (core:config ctx))
|
|
(path (getf (shape:data msg) :path))
|
|
(url (str:concat (base-url cfg) (doc-path cfg) path)))
|
|
(dex:get url :headers '(("Accept". "text/html")) :cookie-jar *cookie-jar*)))
|
|
|
|
(defun send-message (ctx msg)
|
|
(let* ((cfg (core:config ctx))
|
|
(url (str:concat (base-url cfg) (api-path cfg) (msgpath msg)))
|
|
(cred (credentials cfg))
|
|
(params `(:headers (("Accept" . ,(accept cfg)))
|
|
:cookie-jar ,*cookie-jar*)))
|
|
(setf params (funcall (data-renderer cfg) ctx msg params))
|
|
(when cred
|
|
(util:plist-add params :basic-auth (cons (car cred) (cadr cred))))
|
|
(apply #'dex:post url params)
|
|
))
|
|
|
|
(defun msgpath (msg)
|
|
(str:join "/" (loop for p in (shape:head msg)
|
|
when p collect (string-downcase p))))
|
|
|
|
(defun urlencoded (ctx msg params)
|
|
(util:plist-add params :content (data-as-alist (shape:data msg)))
|
|
(push '(:content-type . "application/x-www-form-urlencoded") (getf params :headers))
|
|
params)
|
|
|
|
(defun json (ctx msg params)
|
|
(let ((ht (alx:plist-hash-table (shape:data msg))))
|
|
(util:plist-add params :content (jzon:stringify ht)))
|
|
(push '(:content-type . "application/json") (getf params :headers))
|
|
params)
|
|
|
|
(defun data-as-alist (data)
|
|
(if (symbolp (car data)) ; seems to be a property list
|
|
(let ((al (alx:plist-alist data)))
|
|
(mapcar #'(lambda (p) (cons (string (car p)) (cdr p))) al))
|
|
data))
|