├── LICENSE ├── README.md ├── codable.lisp ├── main.lisp ├── request.lisp ├── response.lisp └── webapi.asd /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2017 Eitaro Fukamachi 2 | 3 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 4 | 5 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 6 | 7 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 8 | 9 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # WebAPI 2 | 3 | CLOS-based wrapper builder for Web APIs. 4 | 5 | ## Usage 6 | 7 | ```common-lisp 8 | (ql:quickload '(:webapi :jonathan)) 9 | 10 | ;; Define GitHub API request class. 11 | (defclass github-request () () 12 | (:default-initargs :base-uri "https://api.github.com")) 13 | 14 | (defmethod webapi:parse ((request github-request) response) 15 | (jojo:parse (webapi:response-body response) :as :alist)) 16 | 17 | ;; Request class for /users/:name/repos. 18 | (defclass user-repositories (github-request) 19 | ((user :initarg :user)) 20 | (:metaclass webapi:request-class) 21 | (:http :get)) 22 | 23 | (defmethod webapi:request-path ((request user-repositories)) 24 | (format nil "/users/~A/repos" (slot-value request 'user))) 25 | 26 | ;; Request class for /search/repositories. 27 | (defclass search-repositories (github-request) 28 | ((q :initarg :q)) 29 | (:metaclass webapi:request-class) 30 | (:http :get "/search/repositories")) 31 | 32 | (defmethod webapi:query-parameters ((request search-repositories)) 33 | `(("q" . ,(slot-value request 'q)))) 34 | 35 | ;; 36 | ;; Send a request 37 | 38 | ;; Get repositories of "fukamachi". 39 | (webapi:send (make-instance 'user-repositories :user "fukamachi")) 40 | 41 | ;; Search repositories with related to "Common Lisp". 42 | (webapi:send (make-instance 'search-repositories :q "Common Lisp")) 43 | ``` 44 | 45 | ## Author 46 | 47 | * Eitaro Fukamachi (e.arrows@gmail.com) 48 | 49 | ## Copyright 50 | 51 | Copyright (c) 2017 Eitaro Fukamachi (e.arrows@gmail.com) 52 | 53 | ## License 54 | 55 | Licensed under the BSD 2-Clause License. 56 | -------------------------------------------------------------------------------- /codable.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:webapi/codable 2 | (:use #:cl) 3 | (:import-from #:closer-mop 4 | #:standard-direct-slot-definition 5 | #:direct-slot-definition-class 6 | #:validate-superclass 7 | #:class-direct-slots 8 | #:slot-definition-name 9 | #:slot-definition-initargs 10 | #:slot-definition-type) 11 | (:import-from #:st-json 12 | #:jso 13 | #:jso-alist 14 | #:json-null 15 | #:json-bool 16 | #:from-json-bool 17 | #:as-json-bool 18 | #:read-json 19 | #:write-json-element) 20 | (:import-from #:alexandria 21 | #:alist-hash-table 22 | #:ensure-list) 23 | (:export #:undefined-key 24 | #:codable 25 | #:codable-class 26 | #:decode-object 27 | #:encode-object 28 | #:defcodable)) 29 | (in-package #:webapi/codable) 30 | 31 | (define-condition undefined-key (error) 32 | ((name :initarg :name 33 | :reader undefined-key-name) 34 | (value :initarg :value 35 | :reader undefined-key-value) 36 | (class :initarg :class 37 | :reader undefined-key-class)) 38 | (:report (lambda (c s) 39 | (with-slots (name value class) c 40 | (format s 41 | "Undefined key ~S (= ~S) in ~A" 42 | name 43 | value 44 | (class-name class)))))) 45 | 46 | (defclass codable () ()) 47 | 48 | (defvar *conc-name* nil) 49 | 50 | (defclass codable-slot-class (c2mop:standard-direct-slot-definition) 51 | ((key :type (or string null) 52 | :initarg :key 53 | :initform nil 54 | :accessor %codable-slot-key))) 55 | 56 | (defun codable-slot-key (slot) 57 | (or (%codable-slot-key slot) 58 | (let ((*print-case* :downcase)) 59 | (princ-to-string (c2mop:slot-definition-name slot))))) 60 | 61 | (defmethod initialize-instance :around ((class codable-slot-class) &rest rest-initargs 62 | &key name 63 | &allow-other-keys) 64 | ;; Add the default initarg. 65 | (pushnew (intern (symbol-name name) :keyword) 66 | (getf rest-initargs :initargs)) 67 | 68 | (when *conc-name* 69 | (let ((default-accessor (intern 70 | (format nil "~:@(~A~A~)" *conc-name* name) 71 | *package*))) 72 | (pushnew default-accessor (getf rest-initargs :readers)) 73 | (pushnew `(setf ,default-accessor) (getf rest-initargs :writers)))) 74 | 75 | (apply #'call-next-method class rest-initargs)) 76 | 77 | (defclass codable-class (standard-class) 78 | ((conc-name :initarg :conc-name 79 | :initform nil) 80 | (key-mapper :initform (make-hash-table :test 'equal)))) 81 | 82 | (defmethod c2mop:direct-slot-definition-class ((class codable-class) &key &allow-other-keys) 83 | 'codable-slot-class) 84 | 85 | (defmethod c2mop:validate-superclass ((class codable-class) (super standard-class)) 86 | t) 87 | 88 | (define-condition conversion-failed (error) ()) 89 | 90 | (defun decode-jso-as-type (value type) 91 | (case type 92 | (null 93 | (unless (typep value 'json-null) 94 | (error 'conversion-failed)) 95 | nil) 96 | (boolean (from-json-bool value)) 97 | ((string integer float rational number) 98 | (handler-case (coerce value type) 99 | (error () (error 'conversion-failed)))) 100 | (hash-table 101 | (if (typep value 'st-json:jso) 102 | (alist-hash-table (st-json::jso-alist value)) 103 | (error 'conversion-failed))) 104 | ('t (typecase value 105 | (json-null nil) 106 | (json-bool (from-json-bool value)) 107 | (otherwise value))) 108 | (otherwise 109 | (decode-object value type)))) 110 | 111 | (defun make-slot-decoder (type) 112 | (if (consp type) 113 | (progn 114 | (assert (eq (first type) 'or)) 115 | (lambda (val) 116 | (block nil 117 | (dolist (type (rest type) (error 'conversion-failed)) 118 | (handler-case 119 | (return (decode-jso-as-type val type)) 120 | (conversion-failed ())))))) 121 | (lambda (val) 122 | (decode-jso-as-type val type)))) 123 | 124 | (defun build-slot-mapper (class) 125 | (let ((mapper (slot-value class 'key-mapper))) 126 | (dolist (slot (c2mop:class-direct-slots class)) 127 | (let ((key (codable-slot-key slot))) 128 | (setf (gethash key mapper) 129 | (cons (first (c2mop:slot-definition-initargs slot)) 130 | (make-slot-decoder 131 | (or (c2mop:slot-definition-type slot) t)))))))) 132 | 133 | (defmethod initialize-instance :around ((class codable-class) &rest initargs &key conc-name &allow-other-keys) 134 | (let ((*conc-name* (first conc-name))) 135 | (let ((class (apply #'call-next-method class initargs))) 136 | (build-slot-mapper class) 137 | class))) 138 | 139 | (defmethod reinitialize-instance :around ((class codable-class) &rest initargs &key conc-name &allow-other-keys) 140 | (let ((*conc-name* (first conc-name))) 141 | (let ((class (apply #'call-next-method class initargs))) 142 | (build-slot-mapper class) 143 | class))) 144 | 145 | (defun make-codable-instance (class input) 146 | (let* ((mapper (slot-value class 'key-mapper)) 147 | (initargs (loop for (key . val) in input 148 | for init-key-converter = (gethash key mapper) 149 | if init-key-converter 150 | append (destructuring-bind (init-key . converter) 151 | init-key-converter 152 | (list init-key 153 | (funcall converter val))) 154 | else do (restart-case (error 'undefined-key 155 | :name key 156 | :value val 157 | :class class) 158 | (continue () 159 | :report "Ignore key" 160 | nil))))) 161 | (apply #'make-instance class initargs))) 162 | 163 | (defgeneric decode-object (input class) 164 | (:method (input (class null)) 165 | (if (typep input 'json-null) 166 | nil 167 | (error 'conversion-failed))) 168 | (:method (input (class symbol)) 169 | (decode-object input (find-class class))) 170 | (:method ((input string) class) 171 | (decode-object (st-json:read-json input) class)) 172 | (:method ((input st-json:jso) class) 173 | (decode-object (jso-alist input) class)) 174 | (:method ((input cons) (class codable-class)) 175 | (make-codable-instance class input))) 176 | 177 | (defmethod st-json:write-json-element ((object codable) stream) 178 | (write-char #\{ stream) 179 | (loop with initial = t 180 | for slot in (c2mop:class-direct-slots (class-of object)) 181 | for slot-name = (c2mop:slot-definition-name slot) 182 | for type = (ensure-list (c2mop:slot-definition-type slot)) 183 | if (and (typep slot 'codable-slot-class) 184 | (slot-boundp object slot-name)) 185 | do (if initial 186 | (setf initial nil) 187 | (write-char #\, stream)) 188 | (st-json:write-json-element (codable-slot-key slot) stream) 189 | (write-char #\: stream) 190 | (let ((value (slot-value object slot-name))) 191 | (st-json:write-json-element 192 | (if (member value '(t nil) :test 'eq) 193 | (cond 194 | ((find 'boolean type) 195 | (as-json-bool value)) 196 | ((find 'null type) 197 | :null) 198 | ((and (or (null type) 199 | (find t type)) 200 | (null value)) 201 | :null) 202 | (t value)) 203 | value) 204 | stream))) 205 | (write-char #\} stream) 206 | (values)) 207 | 208 | (defgeneric encode-object (object) 209 | (:method ((object t)) 210 | object) 211 | (:method ((object codable)) 212 | (st-json:write-json-to-string object))) 213 | 214 | (defmacro defcodable (name superclasses slots &rest class-options) 215 | `(defclass ,name (codable ,@superclasses) 216 | ,slots 217 | (:metaclass codable-class) 218 | (:conc-name ,(format nil "~A-" name)) 219 | ,@class-options)) 220 | -------------------------------------------------------------------------------- /main.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package #:webapi 2 | (:nicknames #:webapi/main) 3 | (:use #:cl) 4 | (:use-reexport #:webapi/request 5 | #:webapi/response 6 | #:webapi/codable)) 7 | (in-package #:webapi) 8 | -------------------------------------------------------------------------------- /request.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:webapi/request 2 | (:use #:cl) 3 | (:import-from #:webapi/response 4 | #:response) 5 | (:import-from #:closer-mop) 6 | (:import-from #:dexador) 7 | (:import-from #:quri) 8 | (:import-from #:kebab) 9 | (:export #:*keep-alive* 10 | #:request 11 | #:request-class 12 | #:http-method 13 | #:http-uri 14 | #:request-path 15 | #:request-parameters 16 | #:query-parameters 17 | #:body-parameters 18 | #:request-headers 19 | #:send 20 | #:parse)) 21 | (in-package #:webapi/request) 22 | 23 | (defvar *keep-alive* nil) 24 | 25 | (defun contains-class-or-subclasses (class target-classes) 26 | (let ((class (if (typep class 'class) 27 | class 28 | (find-class class)))) 29 | (find-if (lambda (target-class) 30 | (let ((target-class (if (typep target-class 'class) 31 | target-class 32 | (find-class target-class nil)))) 33 | (and target-class 34 | (or (eq target-class class) 35 | (subtypep target-class class))))) 36 | target-classes))) 37 | 38 | (defclass request () 39 | ((base-uri :initarg :base-uri))) 40 | 41 | (defclass request-class (standard-class) 42 | ((http :initarg :http))) 43 | 44 | (defmethod c2mop:validate-superclass ((class request-class) (super standard-class)) 45 | t) 46 | 47 | (defmethod initialize-instance :around ((class request-class) &rest initargs 48 | &key direct-superclasses &allow-other-keys) 49 | (unless (contains-class-or-subclasses 'request direct-superclasses) 50 | (push (find-class 'request) (getf initargs :direct-superclasses))) 51 | 52 | (apply #'call-next-method class initargs)) 53 | 54 | (defmethod reinitialize-instance :around ((class request-class) &rest initargs 55 | &key direct-superclasses &allow-other-keys) 56 | (unless (contains-class-or-subclasses 'request direct-superclasses) 57 | (push (find-class 'request) (getf initargs :direct-superclasses))) 58 | 59 | (apply #'call-next-method class initargs)) 60 | 61 | (defgeneric http-method (request) 62 | (:method ((request request)) 63 | (first (slot-value (class-of request) 'http)))) 64 | 65 | (defgeneric http-uri (request) 66 | (:method ((request request)) 67 | (format nil "~A~:[~;~:*~A~]~:[~;~:*?~A~]" 68 | (slot-value request 'base-uri) 69 | (request-path request) 70 | (and (eq (http-method request) :get) 71 | (quri:url-encode-params (query-parameters request)))))) 72 | 73 | (defgeneric request-path (request) 74 | (:method ((request request)) 75 | (second (slot-value (class-of request) 'http)))) 76 | 77 | (defgeneric request-parameters (request) 78 | (:method ((request request)) 79 | '())) 80 | 81 | (defgeneric query-parameters (request) 82 | (:method ((request request)) 83 | (when (eq (http-method request) :get) 84 | (request-parameters request)))) 85 | 86 | (defgeneric body-parameters (request) 87 | (:method ((request request)) 88 | (unless (eq (http-method request) :get) 89 | (request-parameters request)))) 90 | 91 | (defgeneric request-headers (request) 92 | (:method ((request request)) 93 | '())) 94 | 95 | (defgeneric send (request &key keep-alive) 96 | (:method ((request request) &key (keep-alive *keep-alive*)) 97 | (multiple-value-bind (body status headers uri) 98 | (dex:request (http-uri request) 99 | :method (http-method request) 100 | :headers (request-headers request) 101 | :content (body-parameters request) 102 | :keep-alive keep-alive) 103 | (let ((response (make-instance 'response 104 | :status status 105 | :headers headers 106 | :body body 107 | :uri uri))) 108 | (parse request response))))) 109 | 110 | (defgeneric parse (request response) 111 | (:method (request response) 112 | (error "~S isn't implemented for ~S" 'parse (class-name (class-of request))))) 113 | -------------------------------------------------------------------------------- /response.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:webapi/response 2 | (:use #:cl) 3 | (:export #:response 4 | #:response-status 5 | #:response-headers 6 | #:response-body 7 | #:response-uri)) 8 | (in-package #:webapi/response) 9 | 10 | (defclass response () 11 | ((status :initarg :status 12 | :reader response-status) 13 | (headers :initarg :headers 14 | :reader response-headers) 15 | (body :initarg :body 16 | :reader response-body) 17 | (uri :initarg :uri 18 | :reader response-uri))) 19 | -------------------------------------------------------------------------------- /webapi.asd: -------------------------------------------------------------------------------- 1 | (defsystem "webapi" 2 | :class :package-inferred-system 3 | :version "0.1.0" 4 | :author "Eitaro Fukamachi" 5 | :license "BSD 2-Clause" 6 | :description "CLOS-based wrapper builder for Web APIs" 7 | :depends-on ("webapi/main")) 8 | --------------------------------------------------------------------------------