├── README.org ├── README.txt ├── cl-github.asd ├── github-side-api-notes.org ├── github.lisp ├── issues.lisp ├── json.lisp ├── network.lisp ├── package.lisp ├── repositories.lisp ├── url-utils.lisp └── users.lisp /README.org: -------------------------------------------------------------------------------- 1 | #+TITLE: cl-github 2 | 3 | Important! This library is not API stable! In general functions and 4 | objects exported from [[file:package.lisp]] will not have their interfaces 5 | changed without a major version increment. Anything else is subject to 6 | my whim and fancy. Of course the idea is all functions end up exported 7 | ;). 8 | 9 | As of this writing [2010-02-01 Mon], all current v2 github APIs are 10 | implemented if not release ready or vetted for an interface I'm 11 | comfortable with maintaining. 12 | 13 | * Dependencies 14 | - [[http://common-lisp.net/project/cl-json/][CL-JSON]] - Translate github's api messages to CLOS or simple lists. 15 | - [[http://weitz.de/drakma/][DRAKMA]] - HTTP support to talk to github. 16 | - [[http://common-lisp.net/project/iterate/][Iterate]] - A better loop. 17 | 18 | *** Some thanks 19 | This is not a direct dependency, however I made use of some encoding 20 | functions in [[http://weitz.de/hunchentoot][hunchentoot]] and its only right that I mention 21 | Dr. Edmund Weitz's work which I selected 3 functions from and placed 22 | in [[file:url-utils.lisp]] along with his copyright statement and 23 | release under a BSD like license. 24 | 25 | * Overview 26 | The whole public api can be used as of this release, however not all 27 | of the function names or return results are finalized. Please see 28 | [[file:package.lisp]] for functions that are currently exported and won't 29 | change in terms of input or output without a depreciation cycle. 30 | 31 | The major principle we follow is functions either return a *single* 32 | object or they return a list of objects. In some extremely simple 33 | cases, we return lists of strings or lists of other non CLOS objects. 34 | 35 | *** Quick start 36 | Set the default login info in the repl. Doing this means you won't 37 | have to pass a token and login to each function call. 38 | : (setq cl-github:*default-login* "name" 39 | : cl-github:*default-token* "apikey") 40 | 41 | Then try a simple call like: 42 | : (cl-github:show-followers "your login") 43 | 44 | See the documentation strings for information on all of the 45 | functions. 46 | 47 | * Testing 48 | This is known to work on sbcl 1.0.34, however this library is not 49 | using any sbcl specific features. Anything that can run drakma, 50 | cl-json, and iterate ought to run this library without any issues. 51 | 52 | * Bugs 53 | Please report all bugs to github's tracker, found at 54 | http://github.com/nixeagle/cl-github/issues. 55 | 56 | -------------------------------------------------------------------------------- /README.txt: -------------------------------------------------------------------------------- 1 | cl-github 2 | ========= 3 | 4 | 5 | 6 | Important! This library is not API stable! In general functions and 7 | objects exported from [file:package.lisp] will not have their interfaces 8 | changed without a major version increment. Anything else is subject to 9 | my whim and fancy. Of course the idea is all functions end up exported 10 | ;). 11 | 12 | As of this writing [2010-02-01 Mon], all current v2 github APIs are 13 | implemented if not release ready or vetted for an interface I'm 14 | comfortable with maintaining. 15 | 16 | Table of Contents 17 | ================= 18 | 1 Dependencies 19 | 1.1 Some thanks 20 | 2 Overview 21 | 3 Testing 22 | 4 Bugs 23 | 24 | 25 | 1 Dependencies 26 | ~~~~~~~~~~~~~~~ 27 | - [CL-JSON] - Translate github's api messages to CLOS or simple lists. 28 | - [DRAKMA] - HTTP support to talk to github. 29 | - [Iterate] - A better loop. 30 | 31 | 32 | [CL-JSON]: http://common-lisp.net/project/cl-json/ 33 | [DRAKMA]: http://weitz.de/drakma/ 34 | [Iterate]: http://common-lisp.net/project/iterate/ 35 | 36 | 1.1 Some thanks 37 | ================ 38 | This is not a direct dependency, however I made use of some encoding 39 | functions in [hunchentoot] and its only right that I mention 40 | Dr. Edmund Weitz's work which I selected 3 functions from and placed 41 | in [file:url-utils.lisp] along with his copyright statement and 42 | release under a BSD like license. 43 | 44 | 45 | [hunchentoot]: http://weitz.de/hunchentoot 46 | 47 | 2 Overview 48 | ~~~~~~~~~~~ 49 | The whole public api can be used as of this release, however not all 50 | of the function names or return results are finalized. Please see 51 | [file:package.lisp] for functions that are currently exported and won't 52 | change in terms of input or output without a depreciation cycle. 53 | 54 | The major principle we follow is functions either return a *single* 55 | object or they return a list of objects. In some extremely simple 56 | cases, we return lists of strings or lists of other non CLOS objects. 57 | 58 | 3 Testing 59 | ~~~~~~~~~~ 60 | This is known to work on sbcl 1.0.34, however this library is not 61 | using any sbcl specific features. Anything that can run drakma, 62 | cl-json, and iterate ought to run this library without any issues. 63 | 64 | 4 Bugs 65 | ~~~~~~~ 66 | Please report all bugs to github's tracker, found at 67 | [http://github.com/nixeagle/cl-github/issues]. 68 | 69 | -------------------------------------------------------------------------------- /cl-github.asd: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | (defpackage #:cl-github-system 3 | (:use :cl :asdf) 4 | (:nicknames :nisp.github-system)) 5 | (in-package :cl-github-system) 6 | 7 | 8 | (defsystem :cl-github 9 | :version "0.2.0" 10 | :license "BSD" 11 | :depends-on (:iterate :drakma :cl-json :eos) 12 | :serial t 13 | :components 14 | ((:file "package") 15 | (:file "url-utils") 16 | (:file "users") 17 | (:file "repositories") 18 | (:file "issues") 19 | (:file "json") 20 | (:file "github") 21 | (:file "network"))) ;Needs COMMITS and USERS. 22 | 23 | ;;; end 24 | -------------------------------------------------------------------------------- /github-side-api-notes.org: -------------------------------------------------------------------------------- 1 | #+TITLE: Github api oddities 2 | 3 | This is just a list of strangeness that the github api has. These may or 4 | may not be actual bugs. 5 | 6 | * Unfollow does not actually unfollow 7 | You can follow a user with the api, but you can't unfollow them. 8 | 9 | * Disabling bug tracker does not disable issues api. 10 | If you untick the bug tracker checkbox, the issues api still works and 11 | allows you to add issues as if the tracker was still visible on the 12 | github site. 13 | 14 | 15 | * Cannot view labels on a project I am a collaborator on 16 | You can view them on your project, you can see labels on their project 17 | you are a collaborator on in the web interface, but you can't view 18 | those same labels in the api interface. 19 | -------------------------------------------------------------------------------- /github.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-github) 2 | 3 | (defparameter +github-api-url+ "http://github.com/api/v2/json" 4 | ;; Use only the json interface, we do not want to implement the xml or 5 | ;; yaml interfaces. 6 | "Github api location. 7 | This is the same for every call.") 8 | 9 | (defparameter +github-ssl-api-url+ "https://github.com/api/v2/json" 10 | ;; Use only the json interface, we do not want to implement the xml or 11 | ;; yaml interfaces. 12 | "Github api location. 13 | This is the same for every call.") 14 | 15 | (defvar *default-login* "" 16 | "Default user to log in as when possible.") 17 | (defvar *default-token* "" 18 | "Default token to use when possible.") 19 | 20 | 21 | (defmacro with-github-content-types (&body body) 22 | "Evaluate BODY treating application/json as text." 23 | `(let ((drakma:*text-content-types* '(("application" . "json") 24 | ("text" . nil)))) 25 | ,@body)) 26 | 27 | (defun github-request->alist (&rest parameters) 28 | "Ask github about PARAMETERS and return them as an alist." 29 | (let ((result (apply #'github-simple-request parameters))) 30 | (prog1 (with-decoder-simple-list-semantics 31 | (let ((json:*json-symbols-package* :nisp.github)) 32 | (decode-json result))) 33 | (close result)))) 34 | 35 | (defun github-request (&rest args 36 | &key login token auth base-url 37 | parameters method want-string &allow-other-keys) 38 | (let ((login (or login (and (member auth '(:default :force)) *default-login*))) 39 | (token (or token (and (member auth '(:default :force)) *default-token*))) 40 | (base-url (or base-url (if (and login token) 41 | +github-ssl-api-url+ 42 | +github-api-url+)))) 43 | (when (eq :force auth) 44 | (check-type login string) 45 | (check-type token string)) 46 | (with-github-content-types 47 | (drakma:http-request (apply #'build-github-api-url 48 | base-url parameters) 49 | :method (or method (if (and login token) :post :get)) 50 | :REDIRECT t 51 | :want-stream (if want-string nil t) 52 | :parameters 53 | (apply #'build-parameters :login login :token token 54 | args))))) 55 | 56 | (defun request (login token uri-parameters &rest args &key 57 | &allow-other-keys) 58 | (apply #'github-request :login login :token token :auth :default 59 | :parameters uri-parameters args)) 60 | 61 | (defun authed-request (login token uri-parameters &rest args &key 62 | &allow-other-keys) 63 | (apply #'github-request :login login :token token :auth :force 64 | :parameters uri-parameters args)) 65 | 66 | (defun github-simple-request (&rest parameters) 67 | "Ask github about PARAMETERS." 68 | (github-request :parameters parameters)) 69 | 70 | (defun dash-to-underscore (string) 71 | "Change all instances of - to _ in STRING." 72 | (iter (for s :in-string string) 73 | (if (char= #\- s) 74 | (collect #\_ :result-type string) 75 | (collect s :result-type string)))) 76 | 77 | (defun build-parameters (&rest args &key parameters &allow-other-keys) 78 | "Convert ARGS to an alist of parameters." 79 | (declare (ignore parameters)) 80 | (iter (generate arg in args) 81 | (let ((key (next arg)) 82 | (value (next arg))) 83 | (when (and value (not (eq :parameters key)) 84 | (not (eq :auth key)) 85 | (not (eq :method key)) 86 | (not (eq :want-string key))) 87 | (collect (cons (dash-to-underscore 88 | (string-downcase (symbol-name key))) value)))))) 89 | 90 | ;;; Class related generics. 91 | 92 | ;;; JSON classes 93 | 94 | 95 | (defclass status () 96 | (status) 97 | (:documentation "Result status from github api")) 98 | 99 | (defclass blob () 100 | (name size sha data mode mime-type) 101 | (:documentation "Git blob that we get from github.")) 102 | 103 | (defclass treeish () 104 | (name sha mode type) 105 | (:documentation "Treeish git object that we get from github.")) 106 | 107 | 108 | ;;; utils 109 | (defun build-github-api-url (&rest parameters) 110 | "Build a request url using PARAMETERS." 111 | (reduce (lambda (prior new) 112 | (if new 113 | (concatenate 'string prior "/" (url-encode new)) 114 | prior)) 115 | parameters)) 116 | 117 | (defmethod make-object :before (bindings 118 | (class (eql nil)) 119 | &optional superclasses) 120 | "Debug helper to print the keys of BINDINGS." 121 | (declare (ignore superclasses)) 122 | (write (mapcar #'car bindings) 123 | :case :downcase)) 124 | 125 | (defmacro not-done (&rest ignores) 126 | "Throw an error saying not done." 127 | `(progn (proclaim (list 'ignore ,@ignores)) 128 | (error "Not done!"))) 129 | 130 | ;;; API calls 131 | 132 | ;;; Object API 133 | (defgeneric show-tree (username repository tree &key login token) 134 | (:documentation "List treeish objects for USERNAME's REPOSITORY at TREE.")) 135 | (defgeneric show-blob (username repository path tree &key login token) 136 | (:documentation "Show contents of the file at PATH in USERNAME's REPOSITORY.")) 137 | (defgeneric show-raw-blob (username repository sha &key login token) 138 | (:documentation "Show raw contents of SHA in USERNAME's REPOSITORY.")) 139 | 140 | (defmethod show-tree ((username string) (repository string) 141 | (tree string) &key login token) 142 | (to-json (request login token `("tree" "show" ,username ,repository ,tree)))) 143 | 144 | (defmethod show-blob ((username string) (repository string) 145 | (path string) (tree string) &key login token) 146 | (to-json (request login token `("blob" "show" ,username ,repository ,tree ,path)))) 147 | (defmethod show-raw-blob ((username string) (repository string) 148 | (sha string) &key login token) 149 | (github-request :login login :token token :auth :default 150 | :parameters `("blob" "show" ,username ,repository ,sha) 151 | :want-string t)) 152 | 153 | (defun follow-user (username &key token login) 154 | "Follow USERNAME returning the followed username as a string." 155 | (declare (string username)) 156 | (find username (follow username :token token :login login) :test #'equal)) 157 | 158 | (defpackage #:cl-github-extra 159 | (:use :cl :iterate :cl-github) 160 | (:export #:show-followers-not-followed)) 161 | (in-package :cl-github-extra) 162 | ;;; Extra 163 | (defun show-followers-not-followed (username) 164 | "Show followers that USERNAME is not following." 165 | ;; Thanks to scott olson for the idea. 166 | (set-difference (show-followers username) (show-following username) 167 | :test #'equal)) 168 | 169 | ;;; End file 170 | -------------------------------------------------------------------------------- /issues.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-github) 2 | 3 | ;;; Issues API 4 | (defgeneric search-issues (username repository state term &key login token) 5 | (:documentation "Search for TERM with STATE on USERNAME's REPOSITORY.")) 6 | (defgeneric show-issues (username repository state &key login token) 7 | (:documentation "Show all issues with STATE on USERNAME's REPOSITORY.")) 8 | (defgeneric show-issue (username repository issue &key login token) 9 | (:documentation "Show ISSUE on USERNAME's REPOSITORY.")) 10 | (defgeneric show-issue-comments (username repository issue &key login token)) 11 | (defgeneric open-issue (username repository title body &key login token) 12 | (:documentation "Open issue about TITLE with BODY on USERNAME's REPOSITORY.")) 13 | (defgeneric close-issue (username repository issue &key login token) 14 | (:documentation "Close ISSUE on USERNAME's REPOSITORY.")) 15 | (defgeneric reopen-issue (username repository issue &key login token) 16 | (:documentation "Reopen ISSUE on USERNAME's REPOSITORY.")) 17 | (defgeneric edit-issue (username repository issue title body &key login token) 18 | (:documentation "Edit ISSUE setting TITLE and BODY on USERNAME's REPOSITORY. 19 | 20 | Editing an issue causes your TITLE and BODY to completely replace the 21 | original TITLE and BODY.")) 22 | (defgeneric show-labels (username repository &key login token) 23 | (:documentation "Show issue labels for USERNAME's REPOSITORY.")) 24 | (defgeneric add-label (username repository issue label &key login token) 25 | (:documentation "Add LABEL to ISSUE on USERNAME's REPOSITORY.")) 26 | (defgeneric remove-label (username repository issue label &key login token) 27 | (:documentation "Remove LABEL from ISSUE on USERNAME's REPOSITORY.")) 28 | (defgeneric add-comment (username repository issue comment &key login token) 29 | (:documentation "Add COMMENT to ISSUE on USERNAME's REPOSITORY.")) 30 | 31 | (defclass issue-labels () 32 | (labels) 33 | (:documentation "Github issue tracker labels.")) 34 | 35 | (defclass issue () 36 | (number votes created-at body title updated-at closed-at user labels state) 37 | (:documentation "Github issue information.")) 38 | 39 | (defclass comment () 40 | (comment status) 41 | (:documentation "Comment on a github issue.")) 42 | 43 | (defclass issue-comment () 44 | ((body :reader issue-comment-body) 45 | (created-at :reader issue-comment-created-at) 46 | (id :reader issue-comment-id) 47 | (updated-at :reader issue-comment-updated-at) 48 | (user :reader issue-comment-user))) 49 | 50 | (deftype valid-issue-state () 51 | "Github issues have two valid states." 52 | ;; This is not actually used at this time. 53 | '(member :open :closed)) 54 | 55 | (defmethod search-issues ((username string) (repository string) 56 | (state string) (term string) 57 | &key login token) 58 | (to-json (request login token `("issues" "search" ,username 59 | ,repository ,state ,term)))) 60 | 61 | (defmethod show-issues ((username string) (repository string) 62 | (state string) &key login token) 63 | (to-json (request login token `("issues" "list" ,username ,repository ,state)))) 64 | 65 | (defmethod show-issue ((username string) (repository string) 66 | (issue string) &key login token) 67 | (to-json (request login token `("issues" "show" ,username ,repository ,issue)))) 68 | 69 | (defmethod show-issue ((username string) (repository string) 70 | (issue integer) &key login token) 71 | (show-issue username repository (princ-to-string issue) 72 | :login login :token token)) 73 | 74 | (defmethod show-issue-comments ((username string) (repository string) 75 | (issue string) &key login token) 76 | (to-json (request login token `("issues" "comments" ,username ,repository 77 | ,issue)))) 78 | (defmethod show-issue-comments ((username string) (repository string) 79 | (issue integer) &key login token) 80 | (show-issue-comments username repository (princ-to-string issue) 81 | :login login :token token)) 82 | 83 | (defmethod open-issue ((username string) (repository string) 84 | (title string) (body string) 85 | &key login token) 86 | (to-json (authed-request login token `("issues" "open" ,username ,repository) 87 | :title title :body body))) 88 | 89 | (defmethod close-issue ((username string) (repository string) 90 | (issue string) 91 | &key login token) 92 | (to-json (authed-request login token `("issues" "close" ,username 93 | ,repository ,issue)))) 94 | 95 | (defmethod close-issue ((username string) (repository string) 96 | (issue integer) 97 | &key login token) 98 | (close-issue username repository (princ-to-string issue) 99 | :login login :token token)) 100 | 101 | (defmethod reopen-issue ((username string) (repository string) 102 | (issue string) 103 | &key login token) 104 | (to-json (authed-request login token `("issues" "reopen" ,username 105 | ,repository ,issue)))) 106 | 107 | (defmethod reopen-issue ((username string) (repository string) 108 | (issue integer) 109 | &key login token) 110 | (reopen-issue username repository (princ-to-string issue) 111 | :login login :token token)) 112 | 113 | (defmethod edit-issue ((username string) (repository string) 114 | (issue string) (title string) (body string) 115 | &key login token) 116 | (to-json (authed-request login token `("issues" "edit" ,username 117 | ,repository ,issue) 118 | :title title :body body))) 119 | 120 | (defmethod edit-issue ((username string) (repository string) 121 | (issue integer) (title string) (body string) 122 | &key login token) 123 | (edit-issue username repository (princ-to-string issue) title body 124 | :login login :token token)) 125 | 126 | (defmethod show-labels ((username string) (repository string) 127 | &key login token) 128 | (json->list (request login token 129 | `("issues" "labels" ,username ,repository)))) 130 | 131 | (defmethod add-label ((username string) (repository string) 132 | (issue string) (label string) 133 | &key login token) 134 | (json->list (authed-request login token 135 | `("issues" "label" "add" 136 | ,username ,repository 137 | ,label ,issue)))) 138 | 139 | (defmethod add-label ((username string) (repository string) 140 | (issue integer) (label string) 141 | &key login token) 142 | (add-label username repository (princ-to-string issue) label 143 | :login login :token token)) 144 | 145 | (defmethod remove-label ((username string) (repository string) 146 | (issue string) (label string) 147 | &key login token) 148 | (json->list (authed-request login token 149 | `("issues" "label" "remove" 150 | ,username ,repository 151 | ,label ,issue)))) 152 | 153 | (defmethod remove-label ((username string) (repository string) 154 | (issue integer) (label string) 155 | &key login token) 156 | (remove-label username repository (princ-to-string issue) label 157 | :login login :token token)) 158 | 159 | (defmethod add-comment ((username string) (repository string) 160 | (issue string) (comment string) 161 | &key login token) 162 | (to-json (authed-request login token `("issues" "comment" ,username 163 | ,repository ,issue) 164 | :comment comment))) 165 | 166 | (defmethod add-comment ((username string) (repository string) 167 | (issue integer) (comment string) 168 | &key login token) 169 | (add-comment username repository (princ-to-string issue) comment 170 | :login login :token token)) -------------------------------------------------------------------------------- /json.lisp: -------------------------------------------------------------------------------- 1 | ;;; This file modifies the basic behavior of CL-JSON. All of the 2 | ;;; functions that directly modify and manipulate how cl-json reads 3 | ;;; input are derived from the way CL-JSON does the default handling. 4 | ;;; 5 | ;;; My modifications are pretty extensive, but for completeness: 6 | ;;; 7 | ;;; Specifically 8 | ;;; - beginning-of-object 9 | ;;; - key-add-or-set 10 | ;;; - value-add-or-set 11 | ;;; - accumulator-get-object 12 | ;;; - accumulator-add-preserved-key 13 | ;;; Are especially derived from CL-JSON. 14 | ;;; 15 | ;;; CL-JSON's license is included here for completeness. 16 | ;;; 17 | ;;; (This is the MIT / X Consortium license as taken from 18 | ;;; http://www.opensource.org/licenses/mit-license.html) 19 | ;;; 20 | ;;; Copyright (c) 2006-2008 Henrik Hjelte 21 | ;;; Copyright (c) 2008 Hans Hübner (code from the program YASON) 22 | ;;; 23 | ;;; Permission is hereby granted, free of charge, to any person obtaining 24 | ;;; a copy of this software and associated documentation files (the 25 | ;;; "Software"), to deal in the Software without restriction, including 26 | ;;; without limitation the rights to use, copy, modify, merge, publish, 27 | ;;; distribute, sublicense, and/or sell copies of the Software, and to 28 | ;;; permit persons to whom the Software is furnished to do so, subject to 29 | ;;; the following conditions: 30 | ;;; 31 | ;;; The above copyright notice and this permission notice shall be 32 | ;;; included in all copies or substantial portions of the Software. 33 | ;;; 34 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 35 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 36 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 37 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 38 | ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 39 | ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 40 | ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 41 | 42 | (in-package :cl-github) 43 | 44 | ;;; From Alexandria 45 | (defun alist-hash-table (alist &rest hash-table-initargs) 46 | "Returns a hash table containing the keys and values of the association list 47 | ALIST. Hash table is initialized using the HASH-TABLE-INITARGS." 48 | (let ((table (apply #'make-hash-table hash-table-initargs))) 49 | (dolist (cons alist) 50 | (setf (gethash (car cons) table) (cdr cons))) 51 | table)) 52 | 53 | (defparameter +github-class-map+ 54 | (alist-hash-table '(("USER" . "USER") ("PLAN" . "PLAN") ("AUTHOR" . "SIMPLE-USER") 55 | ("PARENTS" . "PARENT") ("COMMIT" . "COMMIT") 56 | ("MODIFIED" . "FILE-DIFF") ("COMMITTER" . "SIMPLE-USER") 57 | ("DELETE-TOKEN" . "DELETE-TOKEN") ("TREE" . "TREEISH") 58 | ("BLOB" . "BLOB") ("BLOCKS" . "COMMIT-RANGE") 59 | ("HEADS" . "HEAD") ("COMMITS" . "COMMITS") 60 | ("REPOSITORY" . "REPOSITORY") 61 | ("PUBLIC-KEYS" . "PUBLIC-KEY") 62 | ("REPOSITORIES" . "REPOSITORIES") 63 | ("NETWORK" . "NETWORK") ("USERS" . "USERS") 64 | ("ISSUES" . "ISSUE") ("ISSUE" . "ISSUE") 65 | ("COMMENT" . "COMMENT")) 66 | :test #'equal) 67 | "mapping of class strings to real classes.") 68 | 69 | 70 | (defvar *current-prototype* nil 71 | "Stores the key of an object until its stored in `*PREVIOUS-PROTOTYPE*'.") 72 | (defvar *previous-prototype* nil 73 | "Stores the prototype of the json class above the current one. 74 | 75 | For example: {\"user\":{\"plan\":{\"name\":....}}} 76 | When parsing the plan json object, this will be set to \"USER\".") 77 | 78 | (defun beginning-of-object () 79 | "Do more at prototype init" 80 | (setq *previous-prototype* *current-prototype*) 81 | (setq *current-prototype* nil) 82 | (json::init-accumulator-and-prototype)) 83 | 84 | (defun camel-case-to-lisp (string) 85 | (declare (type string string)) 86 | (string-upcase (iter (for char :in-string string) 87 | (if (char= #\_ char) 88 | (collect #\- :result-type string) 89 | (collect char :result-type string))))) 90 | 91 | (defgeneric key-add-or-set (key) 92 | (:documentation "Mark KEY a prototype if it is, and add it to the accumulator.")) 93 | (defmethod key-add-or-set (key) 94 | (let ((key (funcall #'camel-case-to-lisp key))) 95 | (let ((class-key (gethash key +github-class-map+ nil))) 96 | (if (and (not *current-prototype*) 97 | class-key) 98 | (progn (setq json::*accumulator-last* 99 | (setf (cdr json::*accumulator-last*) (cons (cons key nil) nil))) 100 | (setq *current-prototype* class-key) 101 | #+ () (pushnew (cons "PROTOTYPE" key) (cddr json::*accumulator*)) 102 | (setq json::*prototype* class-key)) 103 | (setq json::*accumulator-last* 104 | (setf (cdr json::*accumulator-last*) (cons (cons key nil) nil))))) 105 | json::*accumulator*)) 106 | 107 | (defgeneric value-add-or-set (value) 108 | (:documentation "If VALUE (in a JSON Object being decoded) 109 | corresponds to a key which matches *PROTOTYPE-NAME*, 110 | set VALUE to be the prototype of the Object. 111 | Otherwise, do the same as ACCUMULATOR-ADD-VALUE.")) 112 | (defmethod value-add-or-set (value) 113 | (if (eql json::*prototype* t) 114 | (progn 115 | (check-type value (or json::prototype string) 116 | (format nil "Invalid prototype: ~S." value)) 117 | (setq json::*prototype* *current-prototype*) 118 | json::*accumulator*) 119 | (json::accumulator-add-value value))) 120 | 121 | (defmethod value-add-or-set :after (value) 122 | (setq *current-prototype* nil)) 123 | 124 | (defgeneric as-symbol (object) 125 | (:method ((object string)) 126 | "Change OBJECT to a symbol by interning it." 127 | (intern object)) 128 | (:method ((object symbol)) 129 | "Return OBJECT as is." 130 | object) 131 | (:documentation "Get the symbolic representation of object.")) 132 | 133 | (defgeneric accumulator-get-object () 134 | (:documentation 135 | "Return a CLOS object, using keys and values accumulated so far in 136 | the list accumulator as slot names and values, respectively. If the 137 | JSON Object had a prototype field infer the class of the object and 138 | the package wherein to intern slot names from the prototype. 139 | Otherwise, create a FLUID-OBJECT with slots interned in 140 | *JSON-SYMBOLS-PACKAGE*.")) 141 | 142 | ;;; Modified from cl-json 143 | (defmethod accumulator-get-object () 144 | (flet ((intern-keys (bindings) 145 | (loop for (key . value) in bindings 146 | collect (cons (json:json-intern key) value)))) 147 | (if (typep *previous-prototype* 'json::prototype) 148 | (with-slots (lisp-class lisp-superclasses lisp-package) 149 | *previous-prototype* 150 | (let* ((package-name (as-symbol lisp-package)) 151 | (json:*json-symbols-package* 152 | (if package-name 153 | (or (find-package package-name) 154 | (error 'package-error :package package-name)) 155 | json::*json-symbols-package*)) 156 | (class (as-symbol lisp-class)) 157 | (superclasses (mapcar #'as-symbol lisp-superclasses))) 158 | (json::maybe-add-prototype 159 | (json:make-object (intern-keys (cdr json::*accumulator*)) 160 | class superclasses) 161 | *previous-prototype*))) 162 | (let ((bindings (intern-keys (cdr json::*accumulator*))) 163 | (class (if (stringp *previous-prototype*) (as-symbol *previous-prototype*)))) 164 | (when (and *previous-prototype* (not class)) 165 | (push (cons json::*prototype-name* *previous-prototype*) bindings)) 166 | (if (and (not class) (listp bindings) (not (consp (cdr bindings)))) 167 | (cdar bindings) 168 | (json:make-object bindings class)))))) 169 | 170 | (defmacro with-github-decoder (&body body) 171 | "Execute BODY with decoder bindings appropriate for github's api." 172 | `(json:bind-custom-vars 173 | (:beginning-of-object #'beginning-of-object 174 | :object-key #'key-add-or-set 175 | :object-value #'value-add-or-set 176 | :end-of-object #'accumulator-get-object 177 | :object-scope '(json:*INTERNAL-DECODER* 178 | *current-prototype* 179 | *previous-prototype*)) 180 | ,@body)) 181 | 182 | (defgeneric accumulator-add-preserved-keyword-key (key)) 183 | (defmethod accumulator-add-preserved-keyword-key (key) 184 | (let ((*package* (find-package :keyword)) 185 | (*read-eval* nil) 186 | (*readtable* (copy-readtable nil))) 187 | (setf (readtable-case *readtable*) :preserve) 188 | (setq json::*accumulator-last* 189 | (setf (cdr json::*accumulator-last*) 190 | (cons (cons (read-from-string key nil nil :preserve-whitespace t) 191 | nil) nil))))) 192 | 193 | (defgeneric accumulator-add-preserved-key (key)) 194 | (defmethod accumulator-add-preserved-key (key) 195 | (setq json::*accumulator-last* 196 | (setf (cdr json::*accumulator-last*) (cons (cons key nil) nil)))) 197 | 198 | (defmacro with-simple-alist-decoder (&body body) 199 | "Execute body with decoder bindings set to return preserved alists." 200 | `(json:bind-custom-vars 201 | (:object-key #'accumulator-add-preserved-key) 202 | ,@body)) 203 | 204 | (defgeneric to-json (object) 205 | (:method :around (obj) 206 | (let ((json:*json-symbols-package* :cl-github) 207 | (*package* (find-package :cl-github))) 208 | (with-local-class-registry (:inherit nil) 209 | (call-next-method))))) 210 | (defmethod to-json ((obj string)) 211 | (with-github-decoder 212 | (json:decode-json-from-string obj))) 213 | (defmethod to-json ((obj stream)) 214 | "Read directly from a stream and close the stream when done." 215 | (prog1 (with-github-decoder 216 | (json:decode-json obj)) 217 | (close obj))) 218 | 219 | (defgeneric json->alist (object)) 220 | (defmethod json->alist ((object stream)) 221 | (with-decoder-simple-list-semantics 222 | (decode-json object))) 223 | (defmethod json->alist :after ((object stream)) 224 | (close object)) 225 | 226 | (defun ensure-list (object) 227 | "Ensure OBJECT is a list." 228 | (the list (if (listp object) 229 | object 230 | (list object)))) 231 | (defgeneric json->list (object)) 232 | (defmethod json->list ((object stream)) 233 | (ensure-list (cdar (with-simple-alist-decoder 234 | (decode-json object))))) 235 | (defmethod json->list :after ((object stream)) 236 | (close object)) 237 | 238 | (defgeneric json->element (object) 239 | (:documentation "Return first element of OBJECT's json conversion result.")) 240 | (defmethod json->element ((object stream)) 241 | (car (json->list object))) 242 | 243 | (defgeneric json->class (object class) 244 | (:documentation "Store json in OBJECT to CLASS")) 245 | 246 | (defmethod json->class ((object stream) 247 | (class symbol)) 248 | "Store json from STREAM in an instance of CLASS." 249 | (make-object (with-decoder-simple-list-semantics 250 | (decode-json object)) 251 | class)) 252 | 253 | (defmethod json->class :around (object class) 254 | "Set package to cl-github and use local class registry." 255 | (let ((json:*json-symbols-package* :cl-github)) 256 | (with-local-class-registry (:inherit nil) 257 | (call-next-method)))) 258 | 259 | (defmethod json->class :after ((object stream) class) 260 | "Close STREAM after we are done with it." 261 | (close object)) 262 | -------------------------------------------------------------------------------- /network.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-github) 2 | 3 | ;;; Network API 4 | (defgeneric show-network-meta (username repository &key login token) 5 | (:documentation "Network meta information for USERNAME's REPOSITORY.")) 6 | (defgeneric show-network-data (username repository 7 | &key network-meta login token 8 | start end) 9 | (:documentation "Data on last 100 commits.")) 10 | 11 | (defclass commit-range () 12 | (name count start) 13 | (:documentation "Blocks of something that github gives when querying 14 | the network api.")) 15 | 16 | (defclass head () 17 | (name id) 18 | (:documentation "Heads of branches returned from github's Network API.")) 19 | 20 | (defclass github-network-meta () 21 | (blocks 22 | (nethash :reader nethash) 23 | focus dates users) 24 | (:documentation "Toplevel result from github's Network API.")) 25 | 26 | (defmethod show-network-meta ((username string) (repository string) 27 | &key login token) 28 | (let ((*current-prototype* "GITHUB-NETWORK-META")) 29 | (to-json (github-request :login login :token token :auth :default 30 | :parameters `(,username ,repository "network_meta") 31 | :base-url "http://github.com")))) 32 | 33 | (defmethod show-network-data ((username string) (repository string) 34 | &key network-meta login token start end) 35 | (let ((network-meta (or network-meta 36 | (nethash (show-network-meta username 37 | repository 38 | :token token 39 | :login login))))) 40 | (to-json (github-request :login login :token token :auth :default 41 | :parameters `(,username ,repository 42 | "network_data_chunk") 43 | :base-url "http://github.com" 44 | :nethash network-meta 45 | :start start 46 | :end end)))) -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-github-system) 2 | 3 | (defpackage #:cl-github 4 | (:use :cl :json :iterate) 5 | (:nicknames :nisp.github :github) 6 | (:export 7 | 8 | :*default-login* 9 | :*default-token* 10 | ;; Helper/utils 11 | #:github-repository-notation 12 | #:parse-github-repository-notation 13 | 14 | ;; Following people related. 15 | #:show-followers 16 | #:show-following 17 | #:follow 18 | #:unfollow ;currently not working github side. 19 | 20 | ;; Project collaborators 21 | #:show-collaborators 22 | #:add-collaborator 23 | #:remove-collaborator 24 | 25 | ;; User Emails 26 | #:user-emails 27 | #:add-user-email 28 | #:remove-user-email 29 | 30 | ;; User keys 31 | #:user-keys 32 | #:add-user-key 33 | #:remove-user-key 34 | 35 | ;; Repository keys 36 | #:deploy-keys 37 | #:add-deploy-key 38 | #:remove-deploy-key 39 | 40 | 41 | ;; Show commit info 42 | #:show-commit 43 | 44 | #:show-languages 45 | #:show-tags 46 | #:show-branches 47 | 48 | ;; Github issues tracker. 49 | #:search-issues 50 | #:show-issues 51 | #:show-issue 52 | #:open-issue 53 | #:close-issue 54 | #:reopen-issue 55 | #:add-label 56 | #:remove-label 57 | #:show-labels 58 | #:add-comment 59 | 60 | ;; repositories 61 | #:repository-name 62 | #:repository-owner 63 | #:repository-description 64 | #:repository-url 65 | #:repository-open-issues-count 66 | #:repository-fork-p 67 | #:repository-forks-count 68 | #:repository-private-p 69 | #:repository-watchers-count 70 | 71 | #:follow-user)) 72 | 73 | (in-package :cl-github) -------------------------------------------------------------------------------- /repositories.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-github) 2 | 3 | (defgeneric repository-name (repository) 4 | (:documentation "string representation of REPOSITORY.")) 5 | (defgeneric repository-owner (repository) 6 | (:documentation "string representation of REPOSITORY's owner.")) 7 | (defgeneric repository-description (repository)) 8 | (defgeneric repository-open-issues-count (repository)) 9 | (defgeneric repository-open-issues (repository)) 10 | (defgeneric repository-fork-p (repository)) 11 | (defgeneric repository-forks (repository)) 12 | (defgeneric repository-forks-count (repository)) 13 | (defgeneric repository-private-p (repository)) 14 | (defgeneric repository-watchers-count (repository)) 15 | (defgeneric repository-watchers (repository)) 16 | (defgeneric github-repository-notation (repository)) 17 | (defgeneric parse-github-repository-notation (string) 18 | (:documentation "Return a list pair with (\"owner\" \"repository\")") 19 | (:method ((string string)) 20 | ;; Assume only one /, and no garbage input (like trailing spaces). 21 | (list (subseq string 0 (position #\/ string)) 22 | (subseq string (1+ (position #\/ string)))))) 23 | (defgeneric github-url (object) 24 | (:documentation "string representation of OBJECT's resource location.")) 25 | (defgeneric github-git-url (object) 26 | (:documentation "string representation of OBJECT's git location.")) 27 | (defclass repository () 28 | ((description :reader repository-description) 29 | (forks :reader repository-forks-count) 30 | (url :reader repository-url) 31 | (homepage) 32 | (watchers :reader repository-watchers-count) 33 | (fork :reader repository-fork-p) 34 | (open-issues :reader repository-open-issues-count) 35 | (private :reader repository-private-p) 36 | (name :reader repository-name) 37 | (owner :reader repository-owner))) 38 | 39 | (defclass watched-repository (repository) 40 | () 41 | ;; currently used only for WATCHED-REPOSITORIES. 42 | (:documentation "Repository information.")) 43 | (defmethod repository-name ((repo repository)) 44 | (slot-value repo 'name)) 45 | (defmethod github-url ((repo repository)) 46 | (slot-value repo 'url)) 47 | (defmethod github-git-url ((repo repository)) 48 | (concatenate 'string "git" (subseq (github-url repo) 4) ".git")) 49 | (defmethod repository-owner ((repo repository)) 50 | (slot-value repo 'owner)) 51 | (defmethod github-repository-notation ((repo repository)) 52 | (concatenate 'string (repository-owner repo) "/" (repository-name repo))) 53 | (defclass searched-repository () 54 | (name size followers username language fork id type pushed 55 | forks description score created) 56 | (:documentation "Search repository result information.")) 57 | (defmethod repository-name ((repo searched-repository)) 58 | (slot-value repo 'name)) 59 | (defclass repositories (watched-repository searched-repository) () 60 | (:documentation "Workaround for cl-json. 61 | 62 | Basically objects with a key named REPOSITORIES have different values 63 | depending on what action is being done with github. For now we use an 64 | abstract class that inherits all the conflicting classes so that at all 65 | times the result object at least makes sense and has no missing 66 | slots.")) 67 | 68 | (defclass languages () 69 | ((languages :reader languages)) 70 | (:documentation "List of languages.")) 71 | 72 | (defclass collaborators () 73 | (collaborators) 74 | (:documentation "List of collaborators.")) 75 | 76 | (defclass network (repositories) 77 | () 78 | (:documentation "A network is just another name for repositories.")) 79 | 80 | 81 | (defclass network-data-commit () 82 | (message time parents date author id space gravatar login) 83 | (:documentation "We get commit data like this from the Network API.")) 84 | 85 | (defclass commits (network-data-commit) 86 | (author authored-date committed-date committer 87 | id message parents tree url) 88 | (:documentation "A commit object.")) 89 | 90 | (defclass commit () 91 | (added modified removed parents author url id committed-date 92 | authored-date message tree committer) 93 | (:documentation "Detailed information on a commit.")) 94 | 95 | (defclass parent () 96 | (id) 97 | ;; Yes this is a little strange... but this is how github does it, it 98 | ;; can be cleaned up later. 99 | (:documentation "The id for the parent commit.")) 100 | 101 | 102 | (defclass file-diff () 103 | (diff filename) 104 | (:documentation "Modification information for a commit.")) 105 | 106 | (defclass public-key () 107 | (title id key) 108 | (:documentation "Information on a public key.")) 109 | 110 | (defclass delete-token () 111 | ((delete-token :reader delete-token)) 112 | (:documentation "Token github gives us to confirm deletion.")) 113 | 114 | ;;; Repository meta information stuff 115 | (defgeneric search-repositories (search-string) 116 | (:documentation "Search github repositories for SEARCH-STRING.")) 117 | (defgeneric show-repository (username reponame &key login token) 118 | (:documentation "Show information on USERNAME's REPONAME.")) 119 | (defgeneric show-user-repositories (username) 120 | (:documentation "List USERNAME's repositories.")) 121 | 122 | 123 | (defmethod search-repositories ((search-string string)) 124 | (to-json (github-simple-request "repos" "search" search-string))) 125 | (defmethod show-repository ((username string) (repository string) &key login token) 126 | (if (equalp username login) 127 | (to-json (authed-request login to-json (list "repos" "show" username repository))) 128 | (to-json (github-simple-request "repos" "show" username repository)))) 129 | (defmethod show-user-repositories ((username string)) 130 | (to-json (github-simple-request "repos" "show" username))) 131 | 132 | ;;; Watch/unwatch 133 | (defgeneric watch (username repository &key login token) 134 | (:documentation "Watch REPOSITORY owned by USERNAME.")) 135 | (defgeneric unwatch (username repository &key login token) 136 | (:documentation "Stop watching REPOSITORY owned by USERNAME.")) 137 | (defgeneric watched-repositories (username) 138 | (:documentation "List repositories USERNAME watches.")) 139 | 140 | (defmethod watch ((username string) (repository string) &key login token) 141 | (to-json (request login token `("repos" "watch" ,username ,repository)))) 142 | (defmethod unwatch ((username string) (repository string) &key login token) 143 | (to-json (authed-request login token `("repos" "unwatch" ,username ,repository)))) 144 | (defmethod watched-repositories ((username string)) 145 | (to-json (github-simple-request "repos" "watched" username))) 146 | 147 | ;;; Create/delete/fork 148 | (defgeneric fork (username repository &key login token) 149 | (:documentation "Fork REPOSITORY owned by USERNAME.")) 150 | (defgeneric create-repository (repository &key login token description 151 | homepage public) 152 | (:documentation "Create new REPOSITORY on github.")) 153 | (defgeneric delete-repository (repository &key login token) 154 | (:documentation "Delete REPOSITORY on github.")) 155 | 156 | 157 | (defmethod fork ((username string) (repository string) &key login token) 158 | (to-json (authed-request login token `("repos" "fork" ,username ,repository)))) 159 | 160 | (defmethod create-repository ((repository string) &key login token 161 | description homepage public) 162 | (to-json (authed-request login token '("repos" "create") 163 | :name repository 164 | :description description 165 | :homepage homepage 166 | :public public))) 167 | (defmethod delete-repository ((repository string) &key login token) 168 | (flet ((del-repo (&optional delete-token) 169 | (json->element 170 | (authed-request login token 171 | `("repos" "delete" ,repository) 172 | :delete-token delete-token)))) 173 | (del-repo (del-repo)))) 174 | 175 | 176 | ;;; Public/private 177 | (defgeneric set-repository-private (repository &key login token) 178 | (:documentation "Mark REPOSITORY as private on github.")) 179 | (defgeneric set-repository-public (repository &key login token) 180 | (:documentation "Mark REPOSITORY as public on github.")) 181 | 182 | 183 | 184 | (defmethod set-repository-private ((repository string) &key login token) 185 | (to-json (authed-request login token `("repos" "set" "private" ,repository)))) 186 | 187 | (defmethod set-repository-public ((repository string) &key login token) 188 | (to-json (authed-request login token `("repos" "set" "public" ,repository)))) 189 | 190 | 191 | ;;; Repository keys 192 | (defgeneric deply-keys (repository &key login token) 193 | (:documentation "List REPOSITORY's deploy keys. 194 | 195 | These are basically read only ssh keys.")) 196 | (defgeneric add-deploy-key (repository title key &key login token) 197 | (:documentation "Add KEY named TITLE as a deploy key for REPOSITORY.")) 198 | (defgeneric remove-deploy-key (repository id &key login token) 199 | (:documentation "Remove key identified by ID as a deploy key for REPOSITORY.")) 200 | 201 | 202 | (defmethod deploy-keys ((repository string) &key login token) 203 | (to-json (authed-request login token `("repos" "keys" ,repository)))) 204 | (defmethod add-deploy-key ((repository string) (title string) 205 | (key string) &key login token) 206 | (to-json (authed-request login token `("repos" "key" ,repository "add") 207 | :title title :key key))) 208 | (defmethod remove-deploy-key ((repository string) (id string) &key login token) 209 | (to-json (authed-request login token `("repos" "key" ,repository "remove") 210 | :id id))) 211 | (defmethod remove-deploy-key ((repository string) (id integer) &key login token) 212 | (remove-deploy-key repository (princ-to-string id) :login login :token token)) 213 | 214 | 215 | ;;; Collaborators 216 | (defgeneric show-collaborators (username repository &key login token) 217 | (:documentation "List collaborators on REPOSITORY owned by USERNAME.")) 218 | (defgeneric remove-collaborator (username repository &key login token) 219 | (:documentation "Remove USERNAME from the collaborators list of REPOSITORY.")) 220 | (defgeneric add-collaborator (username repository &key login token) 221 | (:documentation "Add USERNAME to the collaborators list of REPOSITORY.")) 222 | 223 | (defmethod show-collaborators ((username string) (repository string) 224 | &key login token) 225 | (json->list (request login token `("repos" "show" ,username 226 | ,repository "collaborators")))) 227 | (defmethod add-collaborator ((username string) (repository string) &key login token) 228 | (json->list 229 | (authed-request login token `("repos" "collaborators" ,repository 230 | "add" ,username)))) 231 | (defmethod remove-collaborator ((username string) (repository string) &key login token) 232 | (json->list 233 | (authed-request login token `("repos" "collaborators" ,repository 234 | "remove" ,username)))) 235 | 236 | 237 | ;;; Repository refs stuff 238 | (defgeneric show-tags (username repository &key login token) 239 | (:documentation "List REPOSITORY's tags.")) 240 | (defgeneric show-languages (username repository &key login token) 241 | (:documentation "List REPOSITORY's languages.")) 242 | (defgeneric show-branches (username repository &key login token) 243 | (:documentation "List REPOSITORY's remote branches.")) 244 | 245 | 246 | (defmethod show-languages ((username string) (repository string) &key login token) 247 | (json->list (request login token `("repos" "show" 248 | ,username ,repository "languages")))) 249 | 250 | (defmethod show-tags ((username string) (repository string) &key login token) 251 | (json->list (request login token `("repos" "show" ,username 252 | ,repository "tags")))) 253 | 254 | (defmethod show-branches ((username string) (repository string) &key login token) 255 | (json->list 256 | (request login token `("repos" "show" ,username ,repository "branches")))) 257 | 258 | 259 | 260 | (defgeneric show-commits (username repository &key branch file login token) 261 | (:documentation "List commits in USERNAME's REPOSITORY on BRANCH optionally for FILE.")) 262 | 263 | (defgeneric repository-network (username repository) 264 | (:documentation "Look at network of USERNAME's REPOSITORY.")) 265 | (defgeneric show-commit (username repository sha &key login token) 266 | (:documentation "Show data for commit identified by SHA on USERNAME's REPOSITORY.")) 267 | 268 | (defgeneric show-network (username repository &key login token) 269 | (:documentation "Show at network of USERNAME's REPOSITORY.")) 270 | 271 | 272 | ;;; Repositories 273 | 274 | (defmethod show-network ((username string) (repository string) &key login token) 275 | (to-json (authed-request login token `("repos" "show" ,username 276 | ,repository "network")))) 277 | 278 | 279 | (defmethod show-commits ((username string) (repository string) 280 | &key branch file login token) 281 | (to-json (request login token `("commits" "list" ,username 282 | ,repository ,(or branch "master") ,file)))) 283 | 284 | 285 | 286 | (defmethod show-commit ((username string) (repository string) (sha string) 287 | &key login token) 288 | (to-json (request login token `("commits" "show" ,username ,repository ,sha)))) 289 | -------------------------------------------------------------------------------- /url-utils.lisp: -------------------------------------------------------------------------------- 1 | ;;; This File is from hunchentoot from http://weitz.de/hunchentoot 2 | ;;; in the file hunchentoot/util.lisp 3 | ;;; Please see below the license for details on modifications I have made. 4 | 5 | ;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved. 6 | 7 | ;;; Redistribution and use in source and binary forms, with or without 8 | ;;; modification, are permitted provided that the following conditions 9 | ;;; are met: 10 | 11 | ;;; * Redistributions of source code must retain the above copyright 12 | ;;; notice, this list of conditions and the following disclaimer. 13 | 14 | ;;; * Redistributions in binary form must reproduce the above 15 | ;;; copyright notice, this list of conditions and the following 16 | ;;; disclaimer in the documentation and/or other materials 17 | ;;; provided with the distribution. 18 | 19 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED 20 | ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 21 | ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 22 | ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY 23 | ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE 25 | ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 26 | ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 27 | ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 28 | ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 29 | ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | 31 | ;;; Some modifications have been made by Nixeagle Copyright (c) 2010. 32 | ;;; Permission is granted to use under the original license (see above). 33 | 34 | (in-package :cl-github) 35 | 36 | (defmacro upgrade-vector (vector new-type &key converter) 37 | "Returns a vector with the same length and the same elements as 38 | VECTOR \(a variable holding a vector) but having element type 39 | NEW-TYPE. If CONVERTER is not NIL, it should designate a function 40 | which will be applied to each element of VECTOR before the result is 41 | stored in the new vector. The resulting vector will have a fill 42 | pointer set to its end. 43 | 44 | The macro also uses SETQ to store the new vector in VECTOR." 45 | `(setq ,vector 46 | (loop with length = (length ,vector) 47 | with new-vector = (make-array length 48 | :element-type ,new-type 49 | :fill-pointer length) 50 | for i below length 51 | do (setf (aref new-vector i) ,(if converter 52 | `(funcall ,converter (aref ,vector i)) 53 | `(aref ,vector i))) 54 | finally (return new-vector)))) 55 | 56 | (defun url-decode (string &optional 57 | (external-format :UTF-8)) 58 | "Decodes a URL-encoded STRING which is assumed to be encoded using 59 | the external format EXTERNAL-FORMAT." 60 | (when (zerop (length string)) 61 | (return-from url-decode "")) 62 | (let ((vector (make-array (length string) :element-type 'flexi-streams:octet :fill-pointer 0)) 63 | (i 0) 64 | unicodep) 65 | (loop 66 | (unless (< i (length string)) 67 | (return)) 68 | (let ((char (aref string i))) 69 | (labels ((decode-hex (length) 70 | (prog1 71 | (parse-integer string :start i :end (+ i length) :radix 16) 72 | (incf i length))) 73 | (push-integer (integer) 74 | (vector-push integer vector)) 75 | (peek () 76 | (aref string i)) 77 | (advance () 78 | (setq char (peek)) 79 | (incf i))) 80 | (cond 81 | ((char= #\% char) 82 | (advance) 83 | (cond 84 | ((char= #\u (peek)) 85 | (unless unicodep 86 | (setq unicodep t) 87 | (upgrade-vector vector '(integer 0 65535))) 88 | (advance) 89 | (push-integer (decode-hex 4))) 90 | (t 91 | (push-integer (decode-hex 2))))) 92 | (t 93 | (push-integer (char-code (case char 94 | ((#\+) #\Space) 95 | (otherwise char)))) 96 | (advance)))))) 97 | (cond (unicodep 98 | (upgrade-vector vector 'character :converter #'code-char)) 99 | (t (flexi-streams:octets-to-string vector :external-format external-format))))) 100 | 101 | 102 | (defun url-encode (string &optional (external-format :UTF-8)) 103 | "URL-encodes a string using the external format EXTERNAL-FORMAT." 104 | (with-output-to-string (s) 105 | (loop for c across string 106 | for index from 0 107 | do (cond ((or (char<= #\0 c #\9) 108 | (char<= #\a c #\z) 109 | (char<= #\A c #\Z) 110 | ;; note that there's no comma in there - because of cookies 111 | (find c "$-_.!*'()" :test #'char=)) 112 | (write-char c s)) 113 | (t (loop for octet 114 | across (flexi-streams:string-to-octets string 115 | :start index 116 | :end (1+ index) 117 | :external-format external-format) 118 | do (format s "%~2,'0x" octet))))))) -------------------------------------------------------------------------------- /users.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-github) 2 | 3 | 4 | (defclass contact-data () 5 | (email login name) 6 | (:documentation "Person information.")) 7 | 8 | (defclass simple-user (contact-data) () 9 | (:documentation "About the simplest user information github will send.")) 10 | 11 | (defclass user () 12 | (plan gravatar-id name company location created-at 13 | collaborators disk-usage 14 | public-gist-count public-repo-count 15 | blog following-count id private-gist-count 16 | owned-private-repo-count total-private-repo-count 17 | followers-count login email)) 18 | 19 | (defclass plan () 20 | (name collaborators space private-repos)) 21 | 22 | (defclass network-meta-user () 23 | (name repo heads) 24 | (:documentation "User object returned from github's Network API.")) 25 | 26 | (defclass users (network-meta-user) 27 | (name location followers username language fullname 28 | repos id type pushed score created) 29 | (:documentation "Describes a github user search result.")) 30 | 31 | ;;; Direct user stuff 32 | 33 | (defgeneric search-users (username) 34 | (:documentation "Search github for USERNAME.")) 35 | (defgeneric show-user (user &key login token name blog email company location) 36 | (:documentation "NIL")) 37 | 38 | (defmethod search-users ((username string)) 39 | (to-json (github-simple-request "user" "search" username))) 40 | (defmethod show-user ((user string) 41 | &key login token name blog email company location) 42 | ;; Not going to export this right now, I want to make this more lisp 43 | ;; like by using setf. 44 | (to-json (github-request :parameters `("user" "show" ,user) 45 | :auth (when (string= user *default-login*) 46 | :force) 47 | :login login 48 | :token token 49 | :values\[blog\] blog 50 | :values\[name\] name 51 | :values\[email\] email 52 | :values\[company\] company 53 | :values\[location\] location))) 54 | 55 | ;;; Following 56 | (defgeneric show-followers (username) 57 | (:documentation "List all followers of USERNAME.")) 58 | (defgeneric show-following (username) 59 | (:documentation "List all users that USERNAME follows.")) 60 | (defgeneric follow (username &key login token) 61 | (:documentation "Follow USERNAME using USER-LOGIN.")) 62 | (defgeneric unfollow (username &key login token) 63 | (:documentation "Unfollow USERNAME using LOGIN.")) 64 | 65 | (defmethod show-followers ((username string)) 66 | (json->list (github-simple-request "user" "show" username "followers"))) 67 | (defmethod show-following ((username string)) 68 | (json->list (github-simple-request "user" "show" username "following"))) 69 | (defmethod follow ((username string) &key login token) 70 | (json->list (authed-request login token `("user" "follow" ,username)))) 71 | (defmethod unfollow ((username string) &key login token) 72 | ;; Github seems to ignore this request. 73 | (json->list (authed-request login token `("user" "unfollow" ,username)))) 74 | 75 | ;;; User public key management. 76 | (defgeneric user-keys (&key login token) 77 | (:documentation "List all public keys LOGIN uses.")) 78 | (defgeneric add-user-key (name key &key login token) 79 | (:documentation "Add KEY to LOGIN's key list.")) 80 | (defgeneric remove-user-key (id &key login token) 81 | (:documentation "REMOVE KEY by ID from LOGIN's key list. 82 | 83 | ID can be either a string or a positive number.")) 84 | 85 | (defmethod user-keys (&key login token) 86 | (to-json (authed-request login token '("user" "keys")))) 87 | 88 | (defmethod add-user-key ((name string) (key string) &key login token) 89 | (to-json (authed-request login token '("user" "key" "add") 90 | :name name :key key))) 91 | 92 | (defmethod remove-user-key ((id string) &key login token) 93 | (to-json (authed-request login token '("user" "key" "remove") 94 | :id (princ-to-string id)))) 95 | 96 | 97 | ;;; User email management. 98 | (defgeneric user-emails (&key login token) 99 | (:documentation "List all emails LOGIN uses.")) 100 | (defgeneric add-user-email (email &key login token) 101 | (:documentation "Add EMAIL to LOGIN's email list.")) 102 | (defgeneric remove-user-email (email &key login token) 103 | (:documentation "Remove EMAIL from LOGIN's email list.")) 104 | 105 | 106 | (defmethod user-emails (&key login token) 107 | (json->list (authed-request login token '("user" "emails")))) 108 | (defmethod add-user-email ((email string) &key login token) 109 | (json->list (authed-request login token '("user" "email" "add") 110 | :email email))) 111 | (defmethod remove-user-email ((email string) &key login token) 112 | (json->list (authed-request login token '("user" "email" "remove") 113 | :email email))) 114 | 115 | (defgeneric show-pushable (&key login token)) 116 | 117 | (defmethod show-pushable (&key login token) 118 | (json->list (authed-request login token '("repos" "pushable")))) 119 | 120 | ;;; END --------------------------------------------------------------------------------