Browse code
Various changes
fiddlerwoaroof authored on 19/09/2016 18:43:50Showing 6 changed files
| 1 | 1 |
new file mode 100644 |
| ... | ... |
@@ -0,0 +1,10 @@ |
| 1 |
+(in-package :slacker) |
|
| 2 |
+ |
|
| 3 |
+(defclass event-pump () |
|
| 4 |
+ ((%ws-client :accessor ws-client :initarg :ws-client) |
|
| 5 |
+ (%waiting-pings :accessor waiting-pings :initform 0) |
|
| 6 |
+ (%modules :accessor modules :initform (make-hash-table)) |
|
| 7 |
+ (%latest-id :accessor latest-id :initform 0) |
|
| 8 |
+ (%work-queue :accessor work-queue :initform (make-instance 'chanl:unbounded-channel)) |
|
| 9 |
+ (%result-queue :accessor result-queue :initform (make-instance 'chanl:unbounded-channel)))) |
|
| 10 |
+ |
| 0 | 11 |
new file mode 100644 |
| ... | ... |
@@ -0,0 +1,389 @@ |
| 1 |
+(defpackage :hhgbot-fukaws |
|
| 2 |
+ (:use :cl :alexandria :serapeum)) |
|
| 3 |
+ |
|
| 4 |
+(in-package :hhgbot-fukaws) |
|
| 5 |
+ |
|
| 6 |
+(eval-when (:compile-toplevel :load-toplevel :execute) |
|
| 7 |
+ (ubiquitous:restore 'hhgbot) |
|
| 8 |
+ (require 'sb-concurrency)) |
|
| 9 |
+ |
|
| 10 |
+(defvar *client*) |
|
| 11 |
+(defclass slack-client () |
|
| 12 |
+ ((self :reader self :initarg :self) |
|
| 13 |
+ (url :reader url :initarg :url) |
|
| 14 |
+ (users :accessor users :initarg :users :initform (make-hash-table :test 'equal)) |
|
| 15 |
+ (slack-info :reader slack-info :initarg :slack-info) |
|
| 16 |
+ (work-mailbox :reader work-mailbox :initform (sb-concurrency:make-mailbox :name "work")) |
|
| 17 |
+ (name :reader name) |
|
| 18 |
+ (waiting-pings :accessor waiting-pings :initform 0) |
|
| 19 |
+ (latest-id :accessor latest-id :initform 0) |
|
| 20 |
+ (ws-client :reader ws-client :initarg :ws-client))) |
|
| 21 |
+ |
|
| 22 |
+(defmethod initialize-instance :after ((client slack-client) &rest r) |
|
| 23 |
+ (declare (ignore r)) |
|
| 24 |
+ (let ((self (self client))) |
|
| 25 |
+ (setf (slot-value client 'name) |
|
| 26 |
+ (gethash "name" self)))) |
|
| 27 |
+ |
|
| 28 |
+(defclass user () |
|
| 29 |
+ ((id :reader id :initarg :id) |
|
| 30 |
+ (name :reader name :initarg :name) |
|
| 31 |
+ (presence :accessor presence :initarg :presence) |
|
| 32 |
+ (deleted :reader deleted :initarg :deleted) |
|
| 33 |
+ (color :reader color :initarg :color) |
|
| 34 |
+ (profile :reader profile :initarg :profile) |
|
| 35 |
+ (is_admin :reader is_admin :initarg :is_admin) |
|
| 36 |
+ (is_owner :reader is_owner :initarg :is_owner) |
|
| 37 |
+ (is_primary_owner :reader is_primary_owner :initarg :is_primary_owner) |
|
| 38 |
+ (is_restricted :reader is_restricted :initarg :is_restricted) |
|
| 39 |
+ (is_ultra_restricted :reader is_ultra_restricted :initarg :is_ultra_restricted) |
|
| 40 |
+ (has_2fa :reader has_2fa :initarg :has_2fa) |
|
| 41 |
+ (two_factor_type :reader two_factor_type :initarg :two_factor_type) |
|
| 42 |
+ (has_files :reader has_files :initarg :has_files))) |
|
| 43 |
+ |
|
| 44 |
+(defmethod print-object ((o user) s) |
|
| 45 |
+ (print-unreadable-object (o s :type t :identity t) |
|
| 46 |
+ (format s "~a: ~a" (id o) (name o)))) |
|
| 47 |
+ |
|
| 48 |
+(defmacro define-constructor (name (class &rest args)) |
|
| 49 |
+ `(defun ,name (source-hash-table) |
|
| 50 |
+ (make-instance ',class |
|
| 51 |
+ ,@(mapcan (lambda (arg) (list (make-keyword arg) |
|
| 52 |
+ `(gethash ,(symbol-name arg) |
|
| 53 |
+ source-hash-table))) |
|
| 54 |
+ args)))) |
|
| 55 |
+ |
|
| 56 |
+(define-constructor make-user (user id name deleted color profile is_admin is_owner is_primary_owner is_restricted is_ultra_restricted has_2fa two_factor_type has_files presence)) |
|
| 57 |
+ |
|
| 58 |
+ |
|
| 59 |
+(defparameter *api-token* |
|
| 60 |
+ "xoxb-21694007908-XtlBghcRjIZkTZCIbXQgdMIf") |
|
| 61 |
+ |
|
| 62 |
+(defgeneric send-message (client type &optional data)) |
|
| 63 |
+ |
|
| 64 |
+(defgeneric handle-message (type message) |
|
| 65 |
+ (:documentation "Handle a websocket message") |
|
| 66 |
+ (:method (_type message) |
|
| 67 |
+ (format t "~& Ok? ~s "(gethash "ok" message)) |
|
| 68 |
+ (when (eq 'yason:false (gethash "ok" message)) |
|
| 69 |
+ (format t "~&Problem: ~s~%" (hash-table-alist (gethash "error" message)))) |
|
| 70 |
+ (format t "Received a packet of type: ~a~%with data: ~s~%" _type |
|
| 71 |
+ (hash-table-alist message)))) |
|
| 72 |
+ |
|
| 73 |
+(defgeneric handle-mention (client event-data id channel message mentioned-pos) |
|
| 74 |
+ (:method (client event-data id channel message mentioned-pos))) |
|
| 75 |
+ |
|
| 76 |
+(defgeneric bot-command (command &rest args) |
|
| 77 |
+ (:method (c &rest r) |
|
| 78 |
+ (format t "Received command ~a with args ~s" c r))) |
|
| 79 |
+ |
|
| 80 |
+(defun make-attachment (title pretext text) |
|
| 81 |
+ (alist-hash-table |
|
| 82 |
+ `(("title" . ,title)
|
|
| 83 |
+ ("pretext" . ,pretext)
|
|
| 84 |
+ ("text" . ,text))
|
|
| 85 |
+ :test 'equal)) |
|
| 86 |
+ |
|
| 87 |
+(defun build-message (id channel text &rest attachments) |
|
| 88 |
+ (alist-hash-table |
|
| 89 |
+ `(("id" . ,id)
|
|
| 90 |
+ ("type" . "message")
|
|
| 91 |
+ ("channel" . ,channel)
|
|
| 92 |
+ ("text" . ,text)
|
|
| 93 |
+ ,@(when attachments |
|
| 94 |
+ (cons "attachments" |
|
| 95 |
+ (list attachments)))) |
|
| 96 |
+ :test 'equal)) |
|
| 97 |
+ |
|
| 98 |
+(let ((id 0)) |
|
| 99 |
+ (defun make-message (data channel) |
|
| 100 |
+ (incf id) |
|
| 101 |
+ (with-output-to-string (s) |
|
| 102 |
+ (yason:encode |
|
| 103 |
+ (alist-hash-table |
|
| 104 |
+ `(("id" . ,id)
|
|
| 105 |
+ ("type" . "message")
|
|
| 106 |
+ ("channel" . ,channel)
|
|
| 107 |
+ ("text" . ,data)))
|
|
| 108 |
+ s)))) |
|
| 109 |
+ |
|
| 110 |
+(defmethod send-message :around ((client slack-client) _type &optional data) |
|
| 111 |
+ (declare (ignorable client _type data)) |
|
| 112 |
+ (wsd:send (ws-client client) |
|
| 113 |
+ (with-output-to-string (s) |
|
| 114 |
+ (yason:encode |
|
| 115 |
+ (call-next-method) |
|
| 116 |
+ s)))) |
|
| 117 |
+ |
|
| 118 |
+(defmethod send-message ((client slack-client) (type (eql :ping)) &optional data) |
|
| 119 |
+ (let* ((id (incf (latest-id client))) |
|
| 120 |
+ (message `(("id" . ,id)
|
|
| 121 |
+ ("type" . "ping"))))
|
|
| 122 |
+ (when data |
|
| 123 |
+ (push (cons "data" data) |
|
| 124 |
+ message)) |
|
| 125 |
+ (incf (waiting-pings client)) |
|
| 126 |
+ (alist-hash-table message |
|
| 127 |
+ :test 'equal))) |
|
| 128 |
+ |
|
| 129 |
+(defun pick (keys h-t) |
|
| 130 |
+ (mapcar (plambda:plambda (gethash :1 h-t)) |
|
| 131 |
+ keys)) |
|
| 132 |
+ |
|
| 133 |
+(defun quote-output (str) |
|
| 134 |
+ (with-output-to-string (s) |
|
| 135 |
+ (format s "```~%~a```~%" str))) |
|
| 136 |
+ |
|
| 137 |
+(defvar *memory* '()) |
|
| 138 |
+ |
|
| 139 |
+(defvar *feeds* '("https://thejosias.com/feed"
|
|
| 140 |
+ "https://sancrucensis.wordpress.com/feed" |
|
| 141 |
+ "https://thomism.wordpress.com/feed")) |
|
| 142 |
+ |
|
| 143 |
+(defvar *books* (ubiquitous:defaulted-value '() :lists :books)) |
|
| 144 |
+ |
|
| 145 |
+(defclass list-manager () |
|
| 146 |
+ ()) |
|
| 147 |
+ |
|
| 148 |
+(defgeneric add-to-list (list-name item)) |
|
| 149 |
+ |
|
| 150 |
+(defmethod add-to-list ((list-name (eql :books)) item) |
|
| 151 |
+ (push item |
|
| 152 |
+ (ubiquitous:value :lists :books))) |
|
| 153 |
+ |
|
| 154 |
+(defmethod get-list ((list-name (eql :books))) |
|
| 155 |
+ (ubiquitous:value :lists :books)) |
|
| 156 |
+ |
|
| 157 |
+(defun get-random-article () |
|
| 158 |
+ (let* ((feed-url (elt *feeds* |
|
| 159 |
+ (funcall (compose #'random #'length) |
|
| 160 |
+ *feeds*))) |
|
| 161 |
+ (feed (alimenta.pull-feed:pull-feed feed-url))) |
|
| 162 |
+ (alimenta::get-random-item feed))) |
|
| 163 |
+ |
|
| 164 |
+(defmacro if-let* ((&rest bindings) &body (then-form &optional else-form)) |
|
| 165 |
+ "Like if-let, but sets bindings sequentially. Doesn't short-circuit." |
|
| 166 |
+ `(let* ,bindings |
|
| 167 |
+ (if (and ,@(mapcar #'car bindings)) |
|
| 168 |
+ ,then-form |
|
| 169 |
+ ,else-form))) |
|
| 170 |
+ |
|
| 171 |
+(defmethod handle-mention ((client slack-client) (event-data hash-table) (id string) (channel string) (message string) (mentioned-pos (eql 0))) |
|
| 172 |
+ (declare (optimize (debug 3))) |
|
| 173 |
+ (if-let ((message (if (starts-with #\D) (cdr (tokens message))))) |
|
| 174 |
+ (let* ((the-user (gethash (gethash "user" event-data) |
|
| 175 |
+ (users client))) |
|
| 176 |
+ (msg-text (string-case:string-case ((car message) :default "Not Recognized") |
|
| 177 |
+ ("users"
|
|
| 178 |
+ (if (is_admin the-user) |
|
| 179 |
+ (quote-output |
|
| 180 |
+ (with-output-to-string (s) |
|
| 181 |
+ (format-users client s))) |
|
| 182 |
+ "Can't help you")) |
|
| 183 |
+ ("josias"
|
|
| 184 |
+ (in-eventloop (cl) |
|
| 185 |
+ (let* ((feed (alimenta.pull-feed:pull-feed "http://thejosias.com/feed")) |
|
| 186 |
+ (item (alimenta::get-random-item feed))) |
|
| 187 |
+ (wsd:send (ws-client cl) |
|
| 188 |
+ (make-message (format nil "~a ( ~a )" |
|
| 189 |
+ (alimenta:title item) |
|
| 190 |
+ (alimenta:link item)) |
|
| 191 |
+ channel))))) |
|
| 192 |
+ |
|
| 193 |
+ ("recommend"
|
|
| 194 |
+ (string-case:string-case ((cadr message) |
|
| 195 |
+ :default (format nil |
|
| 196 |
+ "I don't know about ~a~p" |
|
| 197 |
+ (cadr message) |
|
| 198 |
+ 2)) |
|
| 199 |
+ ("book"
|
|
| 200 |
+ (wsd:send (ws-client client) |
|
| 201 |
+ (make-message |
|
| 202 |
+ (if-let* ((title (string-join (cddr message) #\space)) |
|
| 203 |
+ (message (format nil "I'll remember ~a" title))) |
|
| 204 |
+ (prog1 message |
|
| 205 |
+ (add-to-list :books title)) |
|
| 206 |
+ "No book suggested???") |
|
| 207 |
+ channel))) |
|
| 208 |
+ ("feed" (let ((feed (caddr message)))
|
|
| 209 |
+ (push (subseq feed |
|
| 210 |
+ 1 |
|
| 211 |
+ (1- (length feed))) |
|
| 212 |
+ *feeds*))))) |
|
| 213 |
+ ("suggest"
|
|
| 214 |
+ (string-case:string-case ((cadr message) :default (format nil "I don't know about ~a~p" |
|
| 215 |
+ (cadr message) 2)) |
|
| 216 |
+ ("book" (let ((*books* (get-list :books)))
|
|
| 217 |
+ (wsd:send (ws-client client) |
|
| 218 |
+ (make-message (elt *books* |
|
| 219 |
+ (random (length *books*))) |
|
| 220 |
+ channel)))) |
|
| 221 |
+ ("article" (in-eventloop (cl)
|
|
| 222 |
+ (let ((item (get-random-article))) |
|
| 223 |
+ (wsd:send (ws-client cl) |
|
| 224 |
+ (make-message (format nil "~a ( ~a )" |
|
| 225 |
+ (alimenta:title item) |
|
| 226 |
+ (alimenta:link item)) |
|
| 227 |
+ channel))))))) |
|
| 228 |
+ ("list"
|
|
| 229 |
+ (string-case:string-case ((cadr message) :default "No such list") |
|
| 230 |
+ ("feeds"
|
|
| 231 |
+ (wsd:send (ws-client *client*) |
|
| 232 |
+ (make-message (format nil "```~%~{~a~^~%~}~%```"
|
|
| 233 |
+ *feeds*) |
|
| 234 |
+ channel))) |
|
| 235 |
+ ("books"
|
|
| 236 |
+ (let ((*books* (ubiquitous:value :lists :books))) |
|
| 237 |
+ (wsd:send (ws-client *client*) |
|
| 238 |
+ (make-message (format nil "```~%~{~a~^~%~}~%```"
|
|
| 239 |
+ *books*) |
|
| 240 |
+ channel)))))) |
|
| 241 |
+ ("remember"
|
|
| 242 |
+ (wsd:send (ws-client client) |
|
| 243 |
+ (make-message (car (push (string-join (cdr message) |
|
| 244 |
+ #\space) |
|
| 245 |
+ *memory*)) |
|
| 246 |
+ channel))) |
|
| 247 |
+ ("recall"
|
|
| 248 |
+ (let ((mem-length (length *memory*))) |
|
| 249 |
+ (wsd:send (ws-client client) |
|
| 250 |
+ (make-message (elt *memory* |
|
| 251 |
+ (random mem-length)) |
|
| 252 |
+ channel))))))) |
|
| 253 |
+ (wsd:send (ws-client client) |
|
| 254 |
+ (make-message msg-text channel))))) |
|
| 255 |
+ |
|
| 256 |
+(defmethod handle-message ((type (eql :pong)) data) |
|
| 257 |
+ (with-accessors ((waiting-pings waiting-pings)) *client* |
|
| 258 |
+ (decf waiting-pings) |
|
| 259 |
+ (when (> waiting-pings 0) |
|
| 260 |
+ (format t "Something wrong? ~a waiting pings" waiting-pings) |
|
| 261 |
+ (when (> waiting-pings 5) |
|
| 262 |
+ (setf waiting-pings 0))))) |
|
| 263 |
+ |
|
| 264 |
+(defmethod handle-message ((type (eql :error)) data) |
|
| 265 |
+ (format t "~&~s~%" (hash-table-alist (gethash "error" data)))) |
|
| 266 |
+ |
|
| 267 |
+(defmethod handle-message ((type (eql :message)) data) |
|
| 268 |
+ (format t "~&~s~%" (hash-table-alist data)) |
|
| 269 |
+ (let* ((message (gethash "text" data)) |
|
| 270 |
+ (id (gethash "id" (self *client*))) |
|
| 271 |
+ (name (name *client*)) |
|
| 272 |
+ (channel (gethash "channel" data)) |
|
| 273 |
+ (mentioned (or (search (format nil "<@~a>" id) |
|
| 274 |
+ message) |
|
| 275 |
+ (search (format nil "~a " name) message) |
|
| 276 |
+ (search id message)))) |
|
| 277 |
+ (format t "~&Received a message with text: ~a~&" |
|
| 278 |
+ message) |
|
| 279 |
+ (format t "~&My id is: ~a~%" |
|
| 280 |
+ id) |
|
| 281 |
+ (format t "~&The message mentions me? ~a~%" |
|
| 282 |
+ mentioned) |
|
| 283 |
+ (when mentioned |
|
| 284 |
+ (handle-mention *client* data id channel message mentioned)))) |
|
| 285 |
+ |
|
| 286 |
+(defmethod handle-message ((type (eql :presence_change)) data) |
|
| 287 |
+ (let ((id (gethash "user" data)) |
|
| 288 |
+ (presence (gethash "presence" data))) |
|
| 289 |
+ (when-let* ((user (gethash id (users *client*))) |
|
| 290 |
+ (old-presence (presence user)) |
|
| 291 |
+ (user-name (name user))) |
|
| 292 |
+ (setf (presence user) |
|
| 293 |
+ presence) |
|
| 294 |
+ (format t "~&Presence change: ~a is now ~a (~a -> ~a)~%" |
|
| 295 |
+ user-name |
|
| 296 |
+ presence |
|
| 297 |
+ old-presence |
|
| 298 |
+ (presence user))))) |
|
| 299 |
+ |
|
| 300 |
+(defmethod handle-message ((type (eql :team_join)) data) |
|
| 301 |
+ (let ((user (gethash "user" data))) |
|
| 302 |
+ (when user |
|
| 303 |
+ (setf (gethash (gethash "id" user) |
|
| 304 |
+ (users *client*)) |
|
| 305 |
+ (make-user user)) |
|
| 306 |
+ (format t "~&Added user: ~a~%" (gethash "id" user))))) |
|
| 307 |
+ |
|
| 308 |
+(defun get-ws-url (slack-response) |
|
| 309 |
+ (gethash "url" slack-response)) |
|
| 310 |
+ |
|
| 311 |
+(defun make-client () |
|
| 312 |
+ (fw.lu:let-each (:be slack-data) |
|
| 313 |
+ (format nil "https://slack.com/api/rtm.start?token=~a" *api-token*) |
|
| 314 |
+ (drakma:http-request slack-data :want-stream t) |
|
| 315 |
+ (yason:parse slack-data) |
|
| 316 |
+ |
|
| 317 |
+ (let* ((url (get-ws-url slack-data)) |
|
| 318 |
+ (self (gethash "self" slack-data)) |
|
| 319 |
+ (users (gethash "users" slack-data)) |
|
| 320 |
+ (client (wsd:make-client url))) |
|
| 321 |
+ |
|
| 322 |
+ (wsd:on :message client |
|
| 323 |
+ (lambda (message) |
|
| 324 |
+ (let* ((message (yason:parse message |
|
| 325 |
+ :object-as :hash-table |
|
| 326 |
+ :json-booleans-as-symbols t)) |
|
| 327 |
+ (type (funcall (compose #'make-keyword #'string-upcase) |
|
| 328 |
+ (gethash "type" message "DEFAULT-TYPE")))) |
|
| 329 |
+ (handle-message type message)))) |
|
| 330 |
+ |
|
| 331 |
+ (make-instance 'slack-client |
|
| 332 |
+ :self self |
|
| 333 |
+ :url url |
|
| 334 |
+ :slack-info slack-data |
|
| 335 |
+ :ws-client client |
|
| 336 |
+ :users (alist-hash-table |
|
| 337 |
+ (loop for user in users |
|
| 338 |
+ collect (cons (gethash "id" user) |
|
| 339 |
+ (make-user (copy-hash-table user :test 'equalp)))) |
|
| 340 |
+ :test 'equal))))) |
|
| 341 |
+ |
|
| 342 |
+(defun start-heartbeat (client &optional (interval 5)) |
|
| 343 |
+ (bordeaux-threads:make-thread |
|
| 344 |
+ (lambda () |
|
| 345 |
+ (let ((*client* client)) |
|
| 346 |
+ (loop |
|
| 347 |
+ (in-eventloop (*client*) |
|
| 348 |
+ (send-message *client* :ping)) |
|
| 349 |
+ (sleep interval)))) |
|
| 350 |
+ :name "Heartbeat")) |
|
| 351 |
+ |
|
| 352 |
+(defun start-client () |
|
| 353 |
+ (let ((slack-client (make-client))) |
|
| 354 |
+ (values |
|
| 355 |
+ slack-client |
|
| 356 |
+ (bordeaux-threads:make-thread |
|
| 357 |
+ (lambda () |
|
| 358 |
+ (let ((*client* slack-client)) |
|
| 359 |
+ (as:with-event-loop () |
|
| 360 |
+ (websocket-driver.ws.base:start-connection (ws-client slack-client)) |
|
| 361 |
+ (format t "... after start-connection ...") |
|
| 362 |
+ (as:idle |
|
| 363 |
+ (lambda () |
|
| 364 |
+ (multiple-value-bind (message message-p) (sb-concurrency:receive-message-no-hang (work-mailbox *client*)) |
|
| 365 |
+ (when message-p |
|
| 366 |
+ (format t "~&got message~&") |
|
| 367 |
+ (funcall message *client*)))))))) |
|
| 368 |
+ :name "Server")))) |
|
| 369 |
+ |
|
| 370 |
+(defun call-in-eventloop (client cb) |
|
| 371 |
+ (sb-concurrency:send-message (work-mailbox client) |
|
| 372 |
+ cb)) |
|
| 373 |
+ |
|
| 374 |
+(defmacro in-eventloop ((client) &body body) |
|
| 375 |
+ `(call-in-eventloop *client* |
|
| 376 |
+ (lambda (,client) |
|
| 377 |
+ (declare (ignorable ,client)) |
|
| 378 |
+ ,@body))) |
|
| 379 |
+ |
|
| 380 |
+(defun format-users (client &optional (stream t)) |
|
| 381 |
+ (format stream "~&~:{~a: ~{~19<~a~>~^ ~}~%~}"
|
|
| 382 |
+ (stable-sort |
|
| 383 |
+ (sort |
|
| 384 |
+ (loop for id being the hash-keys of (users client) using (hash-value user) |
|
| 385 |
+ collect (list id (list (name user) (presence user)))) |
|
| 386 |
+ #'string-lessp |
|
| 387 |
+ :key #'caadr) |
|
| 388 |
+ #'string-lessp |
|
| 389 |
+ :key #'cadadr))) |
| 0 | 390 |
new file mode 100644 |
| ... | ... |
@@ -0,0 +1,219 @@ |
| 1 |
+;;;; hhgbot.lisp |
|
| 2 |
+ |
|
| 3 |
+(in-package #:hhgbot) |
|
| 4 |
+ |
|
| 5 |
+(eval-when (:compile-toplevel :load-toplevel :execute) |
|
| 6 |
+ (set-dispatch-macro-character #\# #\{
|
|
| 7 |
+ (lambda (stream char param) |
|
| 8 |
+ (declare (ignore char param)) |
|
| 9 |
+ (let ((elems (read-delimited-list #\} stream t)) |
|
| 10 |
+ (rest-sym (gensym "rest"))) |
|
| 11 |
+ `(lambda (&rest ,rest-sym) |
|
| 12 |
+ (apply ',(car elems) ,@(cdr elems) ,rest-sym))))) |
|
| 13 |
+ (set-macro-character #\} (get-macro-character #\) nil))) |
|
| 14 |
+ |
|
| 15 |
+(defparameter *api-token* |
|
| 16 |
+ "xoxb-21694007908-XtlBghcRjIZkTZCIbXQgdMIf") |
|
| 17 |
+ |
|
| 18 |
+ |
|
| 19 |
+(defun write-crlf (stream) |
|
| 20 |
+ (format stream "~c" |
|
| 21 |
+ #\linefeed)) |
|
| 22 |
+ |
|
| 23 |
+ |
|
| 24 |
+(defun write-crlf (stream) |
|
| 25 |
+ (format stream "~c~c" |
|
| 26 |
+ #\return |
|
| 27 |
+ #\linefeed)) |
|
| 28 |
+ |
|
| 29 |
+; GET /websocket/lEEwhrr2xA4rxHXxY0bPY7Ir06hXul4yhvYfIN2iU8-zBRIHrDIMfTDhIzbs67fAKy0Iw2wrLY1mggMTkO1xAq8WtGTVYMtdE4HhP7jWQrLJNxfSsneGAuvAN_wGWvW9cPxv6hLBjFfA_QQl3FFwHnspEQelNdKGj8ISdIsYYLI= HTTP/1.1 |
|
| 30 |
+; |
|
| 31 |
+; Host: mpmulti-y1d8.slack-msgs.com:443 |
|
| 32 |
+; Upgrade: WebSocket |
|
| 33 |
+; Connection: Upgrade |
|
| 34 |
+; Pragma: no-cache |
|
| 35 |
+; Cache-Control: no-cache |
|
| 36 |
+; Sec-WebSocket-Key: fcat0W4ssKWT29LZoAKgaw== |
|
| 37 |
+; Sec-WebSocket-Version: 13 |
|
| 38 |
+ |
|
| 39 |
+ |
|
| 40 |
+(defun format-with-crlf (s control &rest args) |
|
| 41 |
+ (apply #'format s control args) |
|
| 42 |
+ (write-crlf s)) |
|
| 43 |
+ |
|
| 44 |
+(defun make-connection-string (puri &optional s) |
|
| 45 |
+ ;(let ((s (make-broadcast-stream *standard-output* s))) |
|
| 46 |
+ (fresh-line s) |
|
| 47 |
+ (format-with-crlf s "GET ~a HTTP/1.1" (puri:uri-path puri)) |
|
| 48 |
+ (format-with-crlf s "Host: ~a:443" (puri:uri-host puri)) |
|
| 49 |
+ (format-with-crlf s "User-Agent: hhgbot") |
|
| 50 |
+ (format-with-crlf s "Upgrade: websocket") |
|
| 51 |
+ (format-with-crlf s "Connection: Upgrade") |
|
| 52 |
+ (format-with-crlf s "Pragma: no-cache") |
|
| 53 |
+ (format-with-crlf s "Cache-Control: no-cache") |
|
| 54 |
+ (format-with-crlf s "Sec-WebSocket-Key: fcat0W4ssKWT29LZoAKgaw==") |
|
| 55 |
+ (format-with-crlf s "Sec-WebSocket-Version: 13") |
|
| 56 |
+ (format-with-crlf s "") |
|
| 57 |
+ (finish-output s) |
|
| 58 |
+ );) |
|
| 59 |
+ |
|
| 60 |
+(defclass content-type () |
|
| 61 |
+ ((%genus :initarg :genus :initform (error "need a genus") :reader genus) |
|
| 62 |
+ (%species :initarg :species :initform (error "need a species") :reader species) |
|
| 63 |
+ (%metadata :initarg :metadata :initform '() :reader metadata))) |
|
| 64 |
+ |
|
| 65 |
+(defmethod print-object ((object content-type) s) |
|
| 66 |
+ (print-unreadable-object (object s :type t :identity t) |
|
| 67 |
+ (format s "~a/~a ~s" |
|
| 68 |
+ (genus object) |
|
| 69 |
+ (species object) |
|
| 70 |
+ (metadata object) |
|
| 71 |
+ ))) |
|
| 72 |
+ |
|
| 73 |
+(defgeneric parse-header-value (key value) |
|
| 74 |
+ (:method (key value) |
|
| 75 |
+ value)) |
|
| 76 |
+ |
|
| 77 |
+(defmethod parse-header-value ((key (eql :content-length)) value) |
|
| 78 |
+ (parse-integer value)) |
|
| 79 |
+ |
|
| 80 |
+(defmethod parse-header-value ((key (eql :expires)) value) |
|
| 81 |
+ (parse-integer value)) |
|
| 82 |
+ |
|
| 83 |
+(defmethod parse-header-value ((key (eql :content-type)) value) |
|
| 84 |
+ (let ((parts (mapcar (plambda (string-trim '(#\space #\tab) :1)) |
|
| 85 |
+ (split-sequence:split-sequence #\; value)))) |
|
| 86 |
+ (destructuring-bind (content-type . parameters) parts |
|
| 87 |
+ (destructuring-bind (type subtype) (split-sequence:split-sequence #\/ content-type) |
|
| 88 |
+ (make-instance 'content-type |
|
| 89 |
+ :genus type |
|
| 90 |
+ :species subtype |
|
| 91 |
+ :metadata (mapcar (plambda |
|
| 92 |
+ (funcall (alexandria:compose #'alexandria:make-keyword #'string-upcase) |
|
| 93 |
+ (split-sequence:split-sequence #\= :1))) |
|
| 94 |
+ parameters)))))) |
|
| 95 |
+ |
|
| 96 |
+(defun parse-header (header-string) |
|
| 97 |
+ (declare (optimize (debug 3))) |
|
| 98 |
+ (let ((keywords-to-remove '())) |
|
| 99 |
+ (flet ((temp-keyword (name) |
|
| 100 |
+ (declare (optimize (debug 3))) |
|
| 101 |
+ (multiple-value-bind (keyword status) (funcall (alexandria:compose #'alexandria:make-keyword #'string-upcase) |
|
| 102 |
+ name)))) |
|
| 103 |
+ (let* ((sep-position (position #\: header-string)) |
|
| 104 |
+ (name (alexandria:make-keyword |
|
| 105 |
+ (string-upcase |
|
| 106 |
+ (subseq header-string 0 sep-position)))) |
|
| 107 |
+ |
|
| 108 |
+ (value (subseq header-string (+ 2 sep-position)))) |
|
| 109 |
+ (cons name |
|
| 110 |
+ (parse-header-value name value)))))) |
|
| 111 |
+ |
|
| 112 |
+(defun get-google (puri char-stream &optional (ostream char-stream)) |
|
| 113 |
+ (make-connection-string puri ostream) |
|
| 114 |
+ (loop with buf = (make-string 1) |
|
| 115 |
+ for q = (read-sequence buf char-stream) |
|
| 116 |
+ when (> q 0) |
|
| 117 |
+ do (princ buf))) |
|
| 118 |
+ |
|
| 119 |
+(defun ssl-connect (puri port continuation) |
|
| 120 |
+ (let ((hn (puri:uri-host puri))) |
|
| 121 |
+ (usocket:with-client-socket (socket stream hn port |
|
| 122 |
+ :element-type '(unsigned-byte 8)) |
|
| 123 |
+ (let* ((ssl-stream (cl+ssl:make-ssl-client-stream stream :hostname hn)) |
|
| 124 |
+ (char-stream (flexi-streams:make-flexi-stream ssl-stream |
|
| 125 |
+ :external-format '(:utf-8)))) |
|
| 126 |
+ (unwind-protect |
|
| 127 |
+ (progn (format t "~a~%" puri) |
|
| 128 |
+ (funcall continuation puri char-stream |
|
| 129 |
+ char-stream)) |
|
| 130 |
+ (close ssl-stream)))))) |
|
| 131 |
+ |
|
| 132 |
+(progn (defparameter *ws-url* |
|
| 133 |
+ (puri:parse-uri |
|
| 134 |
+ (funcall (alexandria:compose #'cdr |
|
| 135 |
+ (plambda (assoc "url" :1 |
|
| 136 |
+ :test #'string-equal))) |
|
| 137 |
+ (yason:parse |
|
| 138 |
+ (drakma:http-request |
|
| 139 |
+ (format nil "https://slack.com/api/rtm.start?token=~a" |
|
| 140 |
+ *api-token*) |
|
| 141 |
+ :want-stream t) |
|
| 142 |
+ :object-as :alist))) |
|
| 143 |
+ ) |
|
| 144 |
+ (make-connection-string *ws-url* t) |
|
| 145 |
+ (format t "'~a~%" *ws-url*) |
|
| 146 |
+ ) |
|
| 147 |
+ |
|
| 148 |
+(let ((headers '()) |
|
| 149 |
+ (body '()) |
|
| 150 |
+ (body-count 0) |
|
| 151 |
+ (tmp-header-string nil) |
|
| 152 |
+ (mode :header) |
|
| 153 |
+ (*ws-url* |
|
| 154 |
+ (puri:parse-uri |
|
| 155 |
+ (funcall (alexandria:compose #'cdr |
|
| 156 |
+ (plambda (assoc "url" :1 |
|
| 157 |
+ :test #'string-equal))) |
|
| 158 |
+ (yason:parse |
|
| 159 |
+ (drakma:http-request |
|
| 160 |
+ (format nil "https://slack.com/api/rtm.start?token=~a" |
|
| 161 |
+ *api-token*) |
|
| 162 |
+ :want-stream t) |
|
| 163 |
+ :object-as :alist))))) |
|
| 164 |
+ (as:start-event-loop |
|
| 165 |
+ (lambda () |
|
| 166 |
+ |
|
| 167 |
+ (declare (optimize (debug 3))) |
|
| 168 |
+ (cl-async-ssl:tcp-ssl-connect |
|
| 169 |
+ "slack.com" 443 |
|
| 170 |
+ (lambda (socket data) |
|
| 171 |
+ (let* ((data (babel:octets-to-string data))) |
|
| 172 |
+ (when tmp-header-string |
|
| 173 |
+ (psetf data (concatenate 'string |
|
| 174 |
+ tmp-header-string |
|
| 175 |
+ data) |
|
| 176 |
+ tmp-header-string nil)) |
|
| 177 |
+ |
|
| 178 |
+ (case mode |
|
| 179 |
+ (:header |
|
| 180 |
+ (loop for next-divide = (position #\return data) |
|
| 181 |
+ while next-divide |
|
| 182 |
+ for next-header = (subseq data 0 next-divide) |
|
| 183 |
+ until (string= next-header "") |
|
| 184 |
+ |
|
| 185 |
+ when (alexandria:starts-with-subseq "HTTP" next-header) do |
|
| 186 |
+ (format t "Initial line: ~a~%" next-header) |
|
| 187 |
+ |
|
| 188 |
+ unless (alexandria:starts-with-subseq "HTTP" next-header) do |
|
| 189 |
+ (push (parse-header next-header) |
|
| 190 |
+ headers) |
|
| 191 |
+ (format t "GOT: ~s~%" (car headers)) |
|
| 192 |
+ |
|
| 193 |
+ when (< next-divide (1- (length data))) do |
|
| 194 |
+ (setf data (subseq data (+ 2 next-divide))) |
|
| 195 |
+ |
|
| 196 |
+ finally |
|
| 197 |
+ (when (> (length data) 0) |
|
| 198 |
+ (setf tmp-header-string data)) |
|
| 199 |
+ (when (string= next-header "") |
|
| 200 |
+ (setf mode :body) |
|
| 201 |
+ (push data body) |
|
| 202 |
+ (incf body-count (length data)) |
|
| 203 |
+ (setf tmp-header-string "")))) |
|
| 204 |
+ (:body |
|
| 205 |
+ (push data body) |
|
| 206 |
+ (incf body-count (length data)))) |
|
| 207 |
+ |
|
| 208 |
+ (format t "loop done, body count: ~d, content-length ~d ~%" |
|
| 209 |
+ body-count |
|
| 210 |
+ (cdr (assoc :content-length headers))) |
|
| 211 |
+ (when (>= body-count |
|
| 212 |
+ (or (cdr (assoc :content-length headers)) 0)) |
|
| 213 |
+ (as:close-socket socket)))) |
|
| 214 |
+ :event-cb (lambda (ev) |
|
| 215 |
+ (format t "EV: ~a~%" ev)) |
|
| 216 |
+ :read-timeout 3 |
|
| 217 |
+ :data (with-output-to-string (s) |
|
| 218 |
+ (make-connection-string *ws-url* s))))) |
|
| 219 |
+ (values headers (apply #'concatenate 'string body))) |
| 0 | 220 |
new file mode 100644 |
| ... | ... |
@@ -0,0 +1,22 @@ |
| 1 |
+;; Classes |
|
| 2 |
+(defclass slack-client () |
|
| 3 |
+ ((self :reader self :initarg :self) |
|
| 4 |
+ (url :reader url :initarg :url) |
|
| 5 |
+ (users :accessor users :initarg :users :initform (make-hash-table :test 'equal)) |
|
| 6 |
+ (slack-info :reader slack-info :initarg :slack-info) |
|
| 7 |
+ (work-mailbox :reader work-mailbox :initform (make-instance 'chanl:bounded-channel :size 10)) |
|
| 8 |
+ (name :reader name) |
|
| 9 |
+ (waiting-pings :accessor waiting-pings :initform 0) |
|
| 10 |
+ (latest-id :accessor latest-id :initform 0) |
|
| 11 |
+ (message-id :accessor message-id :initform 0) |
|
| 12 |
+ (ws-client :reader ws-client :initarg :ws-client))) |
|
| 13 |
+ |
|
| 14 |
+(defmethod initialize-instance :after ((client slack-client) &rest r) |
|
| 15 |
+ (declare (ignore r)) |
|
| 16 |
+ (let ((self (self client))) |
|
| 17 |
+ (setf (slot-value client 'name) |
|
| 18 |
+ (gethash "name" self)))) |
|
| 19 |
+ |
|
| 20 |
+(defmethod handle-message ((type (eql :error)) data) |
|
| 21 |
+ (format t "~&~s~%" (hash-table-alist (gethash "error" data)))) |
|
| 22 |
+ |
| 0 | 11 |
new file mode 100644 |
| ... | ... |
@@ -0,0 +1,46 @@ |
| 1 |
+(in-package :hhgbot-augmented-assistant) |
|
| 2 |
+ |
|
| 3 |
+(defmacro define-constructor (name (class &rest args)) |
|
| 4 |
+ `(defun ,name (source-hash-table) |
|
| 5 |
+ (make-instance ',class |
|
| 6 |
+ ,@(mapcan (lambda (arg) (list (make-keyword arg) |
|
| 7 |
+ `(gethash ,(symbol-name arg) |
|
| 8 |
+ source-hash-table))) |
|
| 9 |
+ args)))) |
|
| 10 |
+ |
|
| 11 |
+(defclass user () |
|
| 12 |
+ ((id :reader id :initarg :id) |
|
| 13 |
+ (name :reader name :initarg :name) |
|
| 14 |
+ (presence :accessor presence :initarg :presence) |
|
| 15 |
+ (deleted :reader deleted :initarg :deleted) |
|
| 16 |
+ (color :reader color :initarg :color) |
|
| 17 |
+ (profile :reader profile :initarg :profile) |
|
| 18 |
+ (is_admin :reader is_admin :initarg :is_admin) |
|
| 19 |
+ (is_owner :reader is_owner :initarg :is_owner) |
|
| 20 |
+ (is_primary_owner :reader is_primary_owner :initarg :is_primary_owner) |
|
| 21 |
+ (is_restricted :reader is_restricted :initarg :is_restricted) |
|
| 22 |
+ (is_ultra_restricted :reader is_ultra_restricted :initarg :is_ultra_restricted) |
|
| 23 |
+ (has_2fa :reader has_2fa :initarg :has_2fa) |
|
| 24 |
+ (two_factor_type :reader two_factor_type :initarg :two_factor_type) |
|
| 25 |
+ (has_files :reader has_files :initarg :has_files))) |
|
| 26 |
+ |
|
| 27 |
+(define-constructor make-user |
|
| 28 |
+ (user id name deleted color profile |
|
| 29 |
+ is_admin is_owner is_primary_owner is_restricted is_ultra_restricted |
|
| 30 |
+ has_2fa two_factor_type has_files presence)) |
|
| 31 |
+ |
|
| 32 |
+(defmethod print-object ((o user) s) |
|
| 33 |
+ (print-unreadable-object (o s :type t :identity t) |
|
| 34 |
+ (format s "~a: ~a" (id o) (name o)))) |
|
| 35 |
+ |
|
| 36 |
+(defun format-users (client &optional (stream t)) |
|
| 37 |
+ (format stream "~&~:{~a: ~{~19<~a~>~^ ~}~%~}"
|
|
| 38 |
+ (stable-sort |
|
| 39 |
+ (sort |
|
| 40 |
+ (loop for id being the hash-keys of (users client) using (hash-value user) |
|
| 41 |
+ collect (list id (list (name user) (presence user)))) |
|
| 42 |
+ #'string-lessp |
|
| 43 |
+ :key #'caadr) |
|
| 44 |
+ #'string-lessp |
|
| 45 |
+ :key #'cadadr))) |
|
| 46 |
+ |