forked from nixeagle/cl-github
-
Notifications
You must be signed in to change notification settings - Fork 0
/
github.lisp
169 lines (140 loc) · 6.3 KB
/
github.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
(in-package :cl-github)
(defparameter +github-api-url+ "http://github.com/api/v2/json"
;; Use only the json interface, we do not want to implement the xml or
;; yaml interfaces.
"Github api location.
This is the same for every call.")
(defparameter +github-ssl-api-url+ "https://github.com/api/v2/json"
;; Use only the json interface, we do not want to implement the xml or
;; yaml interfaces.
"Github api location.
This is the same for every call.")
(defvar *default-login* ""
"Default user to log in as when possible.")
(defvar *default-token* ""
"Default token to use when possible.")
(defmacro with-github-content-types (&body body)
"Evaluate BODY treating application/json as text."
`(let ((drakma:*text-content-types* '(("application" . "json")
("text" . nil))))
,@body))
(defun github-request->alist (&rest parameters)
"Ask github about PARAMETERS and return them as an alist."
(let ((result (apply #'github-simple-request parameters)))
(prog1 (with-decoder-simple-list-semantics
(let ((json:*json-symbols-package* :nisp.github))
(decode-json result)))
(close result))))
(defun github-request (&rest args
&key login token auth base-url
parameters method want-string &allow-other-keys)
(let ((login (or login (and (member auth '(:default :force)) *default-login*)))
(token (or token (and (member auth '(:default :force)) *default-token*)))
(base-url (or base-url (if (and login token)
+github-ssl-api-url+
+github-api-url+))))
(when (eq :force auth)
(check-type login string)
(check-type token string))
(with-github-content-types
(drakma:http-request (apply #'build-github-api-url
base-url parameters)
:method (or method (if (and login token) :post :get))
:REDIRECT t
:want-stream (if want-string nil t)
:parameters
(apply #'build-parameters :login login :token token
args)))))
(defun request (login token uri-parameters &rest args &key
&allow-other-keys)
(apply #'github-request :login login :token token :auth :default
:parameters uri-parameters args))
(defun authed-request (login token uri-parameters &rest args &key
&allow-other-keys)
(apply #'github-request :login login :token token :auth :force
:parameters uri-parameters args))
(defun github-simple-request (&rest parameters)
"Ask github about PARAMETERS."
(github-request :parameters parameters))
(defun dash-to-underscore (string)
"Change all instances of - to _ in STRING."
(iter (for s :in-string string)
(if (char= #\- s)
(collect #\_ :result-type string)
(collect s :result-type string))))
(defun build-parameters (&rest args &key parameters &allow-other-keys)
"Convert ARGS to an alist of parameters."
(declare (ignore parameters))
(iter (generate arg in args)
(let ((key (next arg))
(value (next arg)))
(when (and value (not (eq :parameters key))
(not (eq :auth key))
(not (eq :method key))
(not (eq :want-string key)))
(collect (cons (dash-to-underscore
(string-downcase (symbol-name key))) value))))))
;;; Class related generics.
;;; JSON classes
(defclass status ()
(status)
(:documentation "Result status from github api"))
(defclass blob ()
(name size sha data mode mime-type)
(:documentation "Git blob that we get from github."))
(defclass treeish ()
(name sha mode type)
(:documentation "Treeish git object that we get from github."))
;;; utils
(defun build-github-api-url (&rest parameters)
"Build a request url using PARAMETERS."
(reduce (lambda (prior new)
(if new
(concatenate 'string prior "/" (url-encode new))
prior))
parameters))
(defmethod make-object :before (bindings
(class (eql nil))
&optional superclasses)
"Debug helper to print the keys of BINDINGS."
(declare (ignore superclasses))
(write (mapcar #'car bindings)
:case :downcase))
(defmacro not-done (&rest ignores)
"Throw an error saying not done."
`(progn (proclaim (list 'ignore ,@ignores))
(error "Not done!")))
;;; API calls
;;; Object API
(defgeneric show-tree (username repository tree &key login token)
(:documentation "List treeish objects for USERNAME's REPOSITORY at TREE."))
(defgeneric show-blob (username repository path tree &key login token)
(:documentation "Show contents of the file at PATH in USERNAME's REPOSITORY."))
(defgeneric show-raw-blob (username repository sha &key login token)
(:documentation "Show raw contents of SHA in USERNAME's REPOSITORY."))
(defmethod show-tree ((username string) (repository string)
(tree string) &key login token)
(to-json (request login token `("tree" "show" ,username ,repository ,tree))))
(defmethod show-blob ((username string) (repository string)
(path string) (tree string) &key login token)
(to-json (request login token `("blob" "show" ,username ,repository ,tree ,path))))
(defmethod show-raw-blob ((username string) (repository string)
(sha string) &key login token)
(github-request :login login :token token :auth :default
:parameters `("blob" "show" ,username ,repository ,sha)
:want-string t))
(defun follow-user (username &key token login)
"Follow USERNAME returning the followed username as a string."
(declare (string username))
(find username (follow username :token token :login login) :test #'equal))
(defpackage #:cl-github-extra
(:use :cl :iterate :cl-github)
(:export #:show-followers-not-followed))
(in-package :cl-github-extra)
;;; Extra
(defun show-followers-not-followed (username)
"Show followers that USERNAME is not following."
;; Thanks to scott olson for the idea.
(set-difference (show-followers username) (show-following username)
:test #'equal))
;;; End file