60 lines
2.6 KiB
Common Lisp
60 lines
2.6 KiB
Common Lisp
;;; auth.lisp
|
|
|
|
(in-package :seanut)
|
|
|
|
(defun get-access-token (domain options)
|
|
(let ((token
|
|
(if (getf options :quick-connect-p)
|
|
|
|
;; go through the whole quick connect rigamarole
|
|
(quick-connect-dance domain)
|
|
|
|
;; authenticates the user via username and password
|
|
(gethash "AccessToken"
|
|
(json-request (format-url domain "Users/AuthenticateByName")
|
|
:auth (generate-authorization)
|
|
:method :post
|
|
:content `(("Username" . ,(getf options :username))
|
|
("Pw" . ,(getf options :password))))))))
|
|
(format t "Your access token: ~A~&Next time you use seanut, pass this with -t to skip having to authorize~&"
|
|
token)
|
|
token))
|
|
|
|
(defun quick-connect-dance (domain)
|
|
(let* ((auth (generate-authorization))
|
|
(qc-session (handler-case
|
|
(json-request (format-url domain "QuickConnect/Initiate") :auth auth)
|
|
(dex:http-request-unauthorized ()
|
|
(error "QuickConnect not enabled on this server.")))))
|
|
;; initiate quick connect session
|
|
;; display code to user
|
|
;; sleep 5 seconds
|
|
;; poll QuickConnect/Connect?secret=~A
|
|
;; until "Authenticated" is t or we've looped 20 times (~1min)
|
|
;; if we time out signal an error
|
|
;; else POST to Users/AuthenticateWithQuickConnect with "Secret"
|
|
;; return "AccessToken"
|
|
(format t "QuickConnect Code: ~A~%" (gethash "Code" qc-session))
|
|
(force-output)
|
|
(loop :with counter := 1
|
|
:with authed
|
|
|
|
:until (or authed (> counter 20))
|
|
:do
|
|
(sleep 5)
|
|
(let ((state (json-request (format-url domain "QuickConnect/Connect?secret=~A"
|
|
(gethash "Secret" qc-session))
|
|
:auth auth)))
|
|
(setf authed (gethash "Authenticated" state)
|
|
counter (1+ counter)))
|
|
|
|
:finally
|
|
(when (> counter 20)
|
|
(error "QuickConnect session timed out.")))
|
|
(gethash "AccessToken"
|
|
(json-request (format-url domain "Users/AuthenticateWithQuickConnect")
|
|
:auth auth
|
|
:method :post
|
|
:content (jzon:stringify (alist-hash-table `(("Secret" . ,(gethash "Secret" qc-session)))))
|
|
:extra-headers '(("Content-Type" . "application/json"))))))
|