new file mode 100644

@@ -0,0 +1,5 @@

+*-secrets.json

+.*.sw?

+*.fasl

+bin/*

+[#]*[#]

@@ -18,10 +18,12 @@

                 :plump

                 :cl-who

                 :postmodern

-                :iterate)

+                :iterate

+                :fwoar.lisputils)

   :serial t

-  :components ((:file "utils")

-               (:file "package")

+  :components ((:file "package")

+               (:file "utils")  

+               (:file "objects")  

                (:file "cl-oid-connect")))

@@ -37,215 +37,23 @@

 (in-package :cl-oid-connect)

 ; Should this be here?

-(eval-when (:compile-toplevel :execute :load-toplevel)

-  (defun vars-to-symbol-macrolets (vars obj)

-    (iterate:iterate (iterate:for (store key) in (ensure-mapping vars))

-                     (iterate:collect `(,store (gethash ,(alexandria:make-keyword key) ,obj))))))

-

-(defmacro with-session-values (vars session &body body)

-  (alexandria:once-only (session)

-    `(symbol-macrolet ,(vars-to-symbol-macrolets vars session)

-       ,@body)))

-

-; This probably should eventually go?

-(defmacro with-endpoints (endpoint-schema  &body body)

-  `(let* ((*endpoint-schema* ,endpoint-schema))

-     ,@body))

-

-(defmacro with-session ((var) &body body)

-  `(progn

-     (format t "The session var is: ~a it contains: ~a~%"  ,(symbol-name var) ,var)

-     (let ((,var (context :session)))

-       (format t "The session var is: ~a it now contains: ~a~%"  ,(symbol-name var) ,var)

-       ,@body)))

-

-(defmacro def-route ((url args &key (app *oid*) (method :GET)) &body body)

-  `(setf (ningle:route ,app ,url :method ,method)

-         (lambda ,args

-           (declare (ignorable ,@args))

-           ,@body)))

-

-(defun gen-state (len)

-  (with-output-to-string (stream)

-    (let ((*print-base* 36))

-      (loop repeat len

-            do (princ (random 36) stream)))))

-

-(defun valid-state (received-state)

-  (let* ((session (context :session))

-         (saved-state (gethash :state session)))

-    (equal saved-state received-state)))

-

-(defmacro my-with-context-variables ((&rest vars) &body body)

-  "This improves fukamachi's version by permitting the variable to be stored somewhere

-   besides the symbol corresponding to the keyword."

-  `(symbol-macrolet

-       ,(loop for (var key) in (ensure-mapping vars)

-              for form = `(context ,(intern (string key) :keyword))

-              collect `(,var ,form))

-     ,@body))

-

-(defparameter *oid* (make-instance 'ningle:<app>))

-(setf drakma:*text-content-types* (cons '("application" . "json") drakma:*text-content-types*))

-

-(setf =service-info= (object :parents '()

-                             :properties '((client-id nil :accessor client-id)

-                                           (secret nil :accessor secret))))

-

-(setf =endpoint-schema= (object :parents '()

-                                :properties '((auth-endpoint nil :accessor auth-endpoint)

-                                              (token-endpoint nil :accessor token-endpoint)

-                                              (userinfo-endpoint nil :accessor t)

-                                              (auth-scope "openid profile email" :accessor t)

-                                              (redirect-uri nil :accessor t))))

-

-(sheeple:defmessage get-user-info (a b))

-(sheeple:defmessage get-access-token (a b))

-

-(sheeple:defreply get-user-info ((a =endpoint-schema=) (b sheeple:=string=)))

-(sheeple:defreply get-access-token ((a =endpoint-schema=) (b sheeple:=string=)))

-

-(defparameter *endpoint-schema* nil)

-(defmacro string-assoc (key alist) `(assoc ,key ,alist :test #'equal))

-(defmacro assoc-cdr (key alist &optional (test '#'eql)) `(cdr (assoc ,key ,alist :test ,test)))

-

-(defun discover-endpoints (schema discovery-doc-url &key (gat nil gat-p) (gui nil gui-p))

-  "Discover endpoints on the basis of a discovery document stored at a particular url.

-   The two keyword arguments define a function to bind to sheeple replies for get-user-token

-   and get-access-token."

-  (prog1 schema

-    (let ((discovery-document (cl-json:decode-json-from-string (drakma:http-request discovery-doc-url))))

-      (setf (auth-endpoint schema) (assoc-cdr :authorization--endpoint discovery-document)

-            (token-endpoint schema) (assoc-cdr :token--endpoint discovery-document)

-            (userinfo-endpoint schema) (assoc-cdr :userinfo--endpoint discovery-document))

-      (when gui-p

-        (format t "defining gui-p")

-        (sheeple:defreply get-user-info ((a schema)) (funcall gui a)))

-      (when gat-p

-        (format t "defining gat-p")

-        (sheeple:defreply get-access-token ((a schema) (b sheeple:=string=))

-          (funcall gat a b))))))

-

-(defun do-auth-request (endpoint-schema state)

-  (drakma:http-request (auth-endpoint endpoint-schema)

-                       :redirect nil

-                       :parameters `(("client_id" . ,(client-id endpoint-schema))

-                                     ("app_id" . ,(client-id endpoint-schema))

-                                     ("response_type" . "code")

-                                     ("scope" . ,(auth-scope endpoint-schema))

-                                     ("redirect_uri" . ,(redirect-uri endpoint-schema))

-                                     ("state" . ,state))))

-

-(defmacro auth-entry-point (name endpoint-schema)

-  `(defun ,name (params)

-     (declare (ignore params))

-     (with-session-values (state endpoint-schema) (context :session)

-       (setf state (gen-state 36)

-             endpoint-schema ,endpoint-schema)

-       (with-endpoints ,endpoint-schema

-         (multiple-value-bind (content rcode headers uri) (do-auth-request ,endpoint-schema state)

-           (declare (ignore headers))

-           (if (< rcode 400) `(302 (:location ,(format nil "~a" uri)))

-             content))))))

-

 (defun run-callback-function (endpoint-schema params get-app-user-cb get-login-data)

   (flet ((get-code (params) (assoc-cdr "code" params #'equal)))

     (let ((a-t (get-access-token endpoint-schema (get-code params))))

-      (auth-callback-skeleton params (:endpoint-schema endpoint-schema

-                                      :auth-session-vars (accesstoken userinfo idtoken app-user))

-        (multiple-value-bind (access-token user-info id-token) (funcall get-login-data a-t)

+      (multiple-value-bind (access-token user-info id-token) (funcall get-login-data a-t)

+        (auth-callback-skeleton params (:endpoint-schema endpoint-schema

+                                        :auth-session-vars (accesstoken userinfo idtoken app-user))

           (setf accesstoken access-token

                 userinfo user-info

                 idtoken id-token

                 app-user (funcall get-app-user-cb user-info id-token access-token)))

         '(302 (:location "/"))))))

-(defmacro generate-auth-callback (name endpoint-schema params &body body)

-  (with-gensyms (get-app-user-cb cb-params)

-    `(defun ,name (,get-app-user-cb)

-       (lambda (,cb-params)

-         (run-callback-function

-           ,endpoint-schema ,cb-params ,get-app-user-cb

-           (lambda ,params

-             ,@body))))))

-

-(defmacro reject-when-state-invalid (params &body body)

-  (alexandria:with-gensyms (received-state)

-    (alexandria:once-only (params)

-      `(let ((,received-state (cdr (string-assoc "state" ,params))))

-         (if (not (valid-state ,received-state))

-           '(403 '() "Out, vile imposter!")

-        ,@body)))))

-

-(defmacro auth-callback-skeleton (params (&key endpoint-schema auth-session-vars) &body body)

-  (alexandria:with-gensyms (session)

-    (alexandria:once-only (params endpoint-schema)

-      `(reject-when-state-invalid ,params

-         (with-endpoints ,endpoint-schema

-           (my-with-context-variables ((,session session))

-             ,(if (null auth-session-vars)

-                `(progn

-                   ,@body)

-                `(with-session-values ,auth-session-vars ,session

-                   ,@body))))))))

-

 (define-condition user-not-logged-in (error) ())

-(defmacro ensure-logged-in (&body body)

-  "Ensure that the user is logged in: otherwise throw the condition user-not-logged-in"

-  (alexandria:with-gensyms (session userinfo)

-    `(my-with-context-variables ((,session session))

-       (with-session-values ((,userinfo userinfo)) ,session

-         (if (null ,userinfo)

-           (error 'user-not-logged-in)

-           (progn ,@body))))))

-

-(flet ((handle-no-user (main-body handler-body)

-         `(handler-case (ensure-logged-in ,@main-body)

-            (user-not-logged-in (e) (declare (ignorable e))

-                                ,@handler-body))))

-

-  (defmacro check-login (&body body)

-    "Returns an HTTP 401 Error if not logged in."

-    (handle-no-user body `('(401 () "Unauthorized"))))

-  (defmacro require-login (&body body)

-    "Redirects to /login if not logged in."

-    (handle-no-user body

-                    `((with-session-values (next-page) (context :session)

-                        (setf next-page (lack.request:request-path-info *request*))

-                        '(302 (:location "/login")))))))

-(defparameter *fbook-info* (sheeple:clone =service-info=))

-(defparameter *goog-info* (sheeple:clone =service-info=))

-(defparameter *goog-endpoint-schema* (defobject (=endpoint-schema= *goog-info*)))

-(defproto *fbook-endpoint-schema* (=endpoint-schema= *fbook-info*)

-          ((auth-endpoint "https://www.facebook.com/dialog/oauth")

-           (token-endpoint "https://graph.facebook.com/v2.3/oauth/access_token")

-           (userinfo-endpoint "https://graph.facebook.com/v2.3/me")

-           (auth-scope "email")

-           (redirect-uri  "http://srv2.elangley.org:9090/oidc_callback/facebook")))

-

-(sheeple:defreply get-access-token ((endpoint-schema *fbook-endpoint-schema*) (code sheeple:=string=))

-  (cl-json:decode-json-from-string

-    (drakma:http-request (token-endpoint endpoint-schema)

-                         :method :post

-                         :redirect nil

-                         :parameters `(("code" . ,code)

-                                       ("client_id" . ,(client-id endpoint-schema))

-                                       ("app_id" . ,(client-id endpoint-schema))

-                                       ("client_secret" . ,(secret endpoint-schema))

-                                       ("redirect_uri" . ,(redirect-uri endpoint-schema))

-                                       ("grant_type" . "authorization_code")

-                                       ("")

-                                       ))))

-

-(sheeple:defreply get-user-info ((endpoint-schema *fbook-endpoint-schema*) (access-token sheeple:=string=))

-  (let ((endpoint (userinfo-endpoint endpoint-schema)))

-    (cl-json:decode-json-from-string

-      (drakma:http-request endpoint

-                           :parameters `(("access_token" . ,access-token))))))

 (defun load-provider-secrets (provider-info secrets)

   (setf (client-id provider-info) (assoc-cdr :client-id secrets)

@@ -265,21 +73,13 @@

 (defun load-goog-endpoint-schema ()

   (discover-endpoints *goog-endpoint-schema*

                       "https://accounts.google.com/.well-known/openid-configuration"

-                      :gat #'goog-get-access-token)

+                      #'goog-get-access-token)

   (setf (redirect-uri *goog-endpoint-schema*) "http://srv2.elangley.org:9090/oidc_callback/google"))

-(sheeple:defreply get-user-info ((endpoint-schema *goog-endpoint-schema*) (access-token sheeple:=string=))

-  (format t "getting user data: ~a~%" "blarg")

-  (let ((endpoint (userinfo-endpoint endpoint-schema)))

-    (cl-json:decode-json-from-string

-      (drakma:http-request endpoint

-                           :parameters `(("alt" . "json")

-                                         ("access_token" . ,access-token))))))

+(define-auth-entry-point google-login-entry *goog-endpoint-schema*)

+(define-auth-entry-point facebook-login-entry *fbook-endpoint-schema*)

-(auth-entry-point google-login-entry *goog-endpoint-schema*)

-(auth-entry-point facebook-login-entry *fbook-endpoint-schema*)

-

-(generate-auth-callback google-callback *goog-endpoint-schema* (a-t)

+(define-auth-callback google-callback *goog-endpoint-schema* (a-t)

   (labels ((get-real-access-token (a-t) (assoc-cdr :access--token a-t))

            (get-id-token (a-t) (cljwt:decode (assoc-cdr :id--token a-t) :fail-if-unsupported nil)))

     (let ((access-token (get-real-access-token a-t)))

@@ -287,7 +87,7 @@

         (get-user-info *goog-endpoint-schema* access-token)

         (get-id-token a-t)))))

-(generate-auth-callback facebook-callback *fbook-endpoint-schema* (a-t)

+(define-auth-callback facebook-callback *fbook-endpoint-schema* (a-t)

   (labels ((get-id-token (a-t) (assoc-cdr :access--token a-t)))

     ; ^-- access--token is not a mistake here

     (let ((id-token (get-id-token a-t)))

@@ -306,16 +106,3 @@

         (route app "/oidc_callback/google" :method :get) (google-callback login-callback)

         (route app "/oidc_callback/facebook" :method :get) (facebook-callback login-callback)))

-(defmacro setup-oid-connect (app args &body callback)

-  `(bind-oid-connect-routes ,app (lambda ,args ,@callback)))

-

-(defmacro redirect-if-necessary (sessionvar &body body)

-  (with-gensyms (session)

-    `(let* ((,session ,sessionvar)

-            (next-page (gethash :next-page ,session)))

-       (if (and (not (null next-page))

-                (not (string= next-page (lack.request:request-path-info *request*))))

-         (progn

-           (setf (gethash :next-page ,session) nil)

-           `(302 (:location ,next-page)))

-         ,@body))))

new file mode 100644

@@ -0,0 +1,120 @@

+#|

+ |Copyright (c) 2015 Edward Langley

+ |All rights reserved.

+ |

+ |Redistribution and use in source and binary forms, with or without

+ |modification, are permitted provided that the following conditions

+ |are met:

+ |

+ |Redistributions of source code must retain the above copyright notice,

+ |this list of conditions and the following disclaimer.

+ |

+ |Redistributions in binary form must reproduce the above copyright

+ |notice, this list of conditions and the following disclaimer in the

+ |documentation and/or other materials provided with the distribution.

+ |

+ |Neither the name of the project's author nor the names of its

+ |contributors may be used to endorse or promote products derived from

+ |this software without specific prior written permission.

+ |

+ |THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

+ |"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

+ |LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS

+ |FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

+ |HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

+ |SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES  INCLUDING, BUT NOT LIMITED

+ |TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR

+ |PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF

+ |LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING

+ |NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS

+ |SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ |

+ |#

+

+(in-package :cl-oid-connect.objects)

+

+(defparameter *oid* (make-instance 'ningle:<app>))

+(setf drakma:*text-content-types* (cons '("application" . "json") drakma:*text-content-types*))

+

+(setf =service-info= (object :parents '()

+                             :properties '((client-id nil :accessor client-id)

+                                           (secret nil :accessor secret))))

+(defparameter *fbook-info* (clone =service-info=))

+(defparameter *goog-info* (clone =service-info=))

+

+(setf =endpoint-schema= (object :parents '()

+                                :properties '((auth-endpoint nil :accessor auth-endpoint)

+                                              (token-endpoint nil :accessor token-endpoint)

+                                              (userinfo-endpoint nil :accessor t)

+                                              (auth-scope "openid profile email" :accessor t)

+                                              (redirect-uri nil :accessor t))))

+(defparameter *endpoint-schema* nil)

+

+(defmessage get-user-info (a b))

+(defmessage get-access-token (a b))

+(defmessage discover-endpoints (a b c))

+

+(defreply get-user-info ((a =endpoint-schema=) (b =string=)))

+(defreply get-access-token ((a =endpoint-schema=) (b =string=)))

+

+(defreply discover-endpoints ((schema =endpoint-schema=) discovery-doc-url get-access-token)

+  "Discover endpoints on the basis of a discovery document stored at a particular url.

+   The two keyword arguments define a function to bind to sheeple replies for get-user-token

+   and get-access-token."

+  (let ((discovery-document (yason:parse (drakma:http-request discovery-doc-url))))

+    (setf (auth-endpoint schema)     (gethash "authorization_endpoint" discovery-document)

+          (token-endpoint schema)    (gethash "token_endpoint" discovery-document)

+          (userinfo-endpoint schema) (gethash "userinfo_endpoint" discovery-document))

+    (defreply get-access-token ((a schema) (b =string=))

+      (funcall get-access-token a b))

+

+    schema))

+

+(defparameter *goog-endpoint-schema* (defobject (=endpoint-schema= *goog-info*)))

+

+(defreply get-user-info ((endpoint-schema *goog-endpoint-schema*) (access-token =string=))

+  (format t "getting user data: ~a~%" "blarg")

+  (let ((endpoint (userinfo-endpoint endpoint-schema)))

+    (cl-json:decode-json-from-string

+      (drakma:http-request endpoint

+                           :parameters `(("alt" . "json")

+                                         ("access_token" . ,access-token))))))

+

+

+(defproto *fbook-endpoint-schema* (=endpoint-schema= *fbook-info*)

+          ((auth-endpoint "https://www.facebook.com/dialog/oauth")

+           (token-endpoint "https://graph.facebook.com/v2.3/oauth/access_token")

+           (userinfo-endpoint "https://graph.facebook.com/v2.3/me")

+           (auth-scope "email")

+           (redirect-uri  "http://srv2.elangley.org:9090/oidc_callback/facebook")))

+

+

+(defreply get-access-token ((endpoint-schema *fbook-endpoint-schema*) (code =string=))

+  (cl-json:decode-json-from-string

+    (drakma:http-request (token-endpoint endpoint-schema)

+                         :method :post

+                         :redirect nil

+                         :parameters `(("code" . ,code)

+                                       ("client_id" . ,(client-id endpoint-schema))

+                                       ("app_id" . ,(client-id endpoint-schema))

+                                       ("client_secret" . ,(secret endpoint-schema))

+                                       ("redirect_uri" . ,(redirect-uri endpoint-schema))

+                                       ("grant_type" . "authorization_code")))))

+

+(defreply get-user-info ((endpoint-schema *fbook-endpoint-schema*) (access-token =string=))

+  (let ((endpoint (userinfo-endpoint endpoint-schema)))

+    (cl-json:decode-json-from-string

+      (drakma:http-request endpoint

+                           :parameters `(("access_token" . ,access-token))))))

+

+(defun do-auth-request (endpoint-schema state)

+  (drakma:http-request (auth-endpoint endpoint-schema)

+                       :redirect nil

+                       :parameters `(("client_id" . ,(client-id endpoint-schema))

+                                     ("app_id" . ,(client-id endpoint-schema))

+                                     ("response_type" . "code")

+                                     ("scope" . ,(auth-scope endpoint-schema))

+                                     ("redirect_uri" . ,(redirect-uri endpoint-schema))

+                                     ("state" . ,state))))

+

+

@@ -1,32 +1,23 @@

 ;;;; package.lisp

-(defpackage :cl-oid-connect

+(defpackage #:cl-oid-connect.utils

+  (:use #:cl #:alexandria #:anaphora #:fwoar.lisputils)

+  (:export #:vars-to-symbol-macrolets #:with-session-values #:with-endpoints

+           #:with-session #:def-route #:gen-state #:valid-state #:my-with-context-variables

+           #:string-assoc #:assoc-cdr #:define-auth-entry-point #:define-auth-callback

+           #:reject-when-state-invalid #:auth-callback-skeleton #:ensure-logged-in

+           #:setup-oid-connect #:check-login #:require-login #:redirect-if-necessary))

+

+(defpackage #:cl-oid-connect.objects

+  (:use #:cl #:alexandria #:anaphora #:fwoar.lisputils #:cl-oid-connect.utils #:sheeple))

+

+(defpackage #:cl-oid-connect

   (:use

-    #:cl

-    #:alexandria

-    #:anaphora

-    #:clack

-    #:cl-json

-    #:cljwt

-    #:cl-who

-    #:drakma

+    #:cl #:alexandria #:anaphora #:clack #:cl-json #:cljwt #:cl-who #:drakma

     ;#:lack-middleware-session

-    #:iterate

-    #:ningle

-    #:lquery

-    #:plump

-    #:sheeple

-    #:whitespace.utils

-    )

+    #:iterate #:ningle #:lquery #:plump #:sheeple #:fwoar.lisputils

+    #:cl-oid-connect.objects #:cl-oid-connect.utils)

   (:export

-    #:redirect-if-necessary

-    #:def-route

-    #:require-login

-    #:oauth2-login-middleware

-    #:with-session

-    #:assoc-cdr

-    #:session ; private!!

-    #:vars-to-symbol-macrolets

-    #:initialize-oid-connect

-    ))

+    #:redirect-if-necessary #:def-route #:require-login #:oauth2-login-middleware #:with-session

+    #:assoc-cdr #:session #| private!! |# #:vars-to-symbol-macrolets #:initialize-oid-connect))

@@ -1,77 +1,167 @@

-(defpackage whitespace.utils

-  (:use #:cl #:alexandria #:iterate))

-

-(in-package whitespace.utils)

-

-(defun ensure-mapping (list)

-  "Make sure that each item of the list is a pair of symbols"

-  (mapcar (lambda (x) (if (symbolp x) (list x x) x)) list))

-(export 'ensure-mapping)

-

-(defun alist-string-hash-table (alist)

-  (alexandria:alist-hash-table alist :test #'string=))

-(export 'alist-string-hash-table)

-

-(defun make-pairs (symbols)

-  (cons 'list (iterate (for (key value) in symbols)

-                       (collect (list 'list* (symbol-name key) value)))))

-(export 'make-pairs)

-

-(defmacro copy-slots (slots from-v to-v)

-  (with-gensyms (from to)

-    `(let ((,from ,from-v) (,to ,to-v))

-       ,@(iterate (for (fro-slot to-slot) in (ensure-mapping slots))

-                  (collect `(setf (slot-value ,to ',to-slot) (slot-value ,from ',fro-slot))))

-       ,to)))

-(export 'copy-slots)

-

-

-(defun transform-alist (pair-transform alist)

-  (iterate (for (k . v) in-sequence alist)

-           (collect

-             (funcall pair-transform k v))))

-(export 'transform-alist)

-

-(defun %json-pair-transform (k v)

-  (cons (make-keyword (string-downcase k))

-        (typecase v

-          (string (coerce v 'simple-string))

-          (t v))))

-(export '%json-pair-transform)

-

-(defun %default-pair-transform (k v)

-  (cons (make-keyword (string-upcase k)) v))

-(export '%default-pair-transform)

-

-(defmacro default-when (default test &body body)

-  (once-only (default)

-    `(or (when ,test

-           ,@body)

-         ,default)))

-(export 'default-when)

-

-(defmacro transform-result ((list-transform pair-transform) &body alist)

-  `(funcall ,list-transform

-            (transform-alist ,pair-transform

-                             ,@alist)))

-(export 'transform-result)

-

-

-(defmacro slots-to-pairs (obj (&rest slots))

-  (once-only (obj)

-    (let* ((slots (ensure-mapping slots))

-           (bindings (iterate (for (slot v &key bind-from) in slots)

-                              (collect (or bind-from slot)))))

-      `(with-slots ,bindings ,obj

-         ,(make-pairs slots)))))

-(export 'slots-to-pairs)

-

-(defun normalize-html (html)

-  (let ((plump-parser:*tag-dispatchers* plump:*html-tags*))

-    (with-output-to-string (ss)

-      (prog1 ss

-        (map 'vector

-           (lambda (x) (plump:serialize (plump:parse (plump:text x)) ss))

-           html)))))

-(export 'normalize-html)

+#|

+ |Copyright (c) 2015 Edward Langley

+ |All rights reserved.

+ |

+ |Redistribution and use in source and binary forms, with or without

+ |modification, are permitted provided that the following conditions

+ |are met:

+ |

+ |Redistributions of source code must retain the above copyright notice,

+ |this list of conditions and the following disclaimer.

+ |

+ |Redistributions in binary form must reproduce the above copyright

+ |notice, this list of conditions and the following disclaimer in the

+ |documentation and/or other materials provided with the distribution.

+ |

+ |Neither the name of the project's author nor the names of its

+ |contributors may be used to endorse or promote products derived from

+ |this software without specific prior written permission.

+ |

+ |THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

+ |"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

+ |LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS

+ |FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

+ |HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

+ |SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES  INCLUDING, BUT NOT LIMITED

+ |TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR

+ |PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF

+ |LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING

+ |NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS

+ |SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ |

+ |#

+

+(in-package :cl-oid-connect.utils)

+(eval-when (:compile-toplevel :execute :load-toplevel)

+  (defun vars-to-symbol-macrolets (vars obj)

+    (iterate:iterate (iterate:for (store key) in (ensure-mapping vars))

+                     (iterate:collect `(,store (gethash ,(alexandria:make-keyword key) ,obj))))))

+

+(defmacro with-session-values (vars session &body body)

+  (alexandria:once-only (session)

+    `(symbol-macrolet ,(vars-to-symbol-macrolets vars session)

+       ,@body)))

+

+; This probably should eventually go?

+(defmacro with-endpoints (endpoint-schema  &body body)

+  `(let* ((*endpoint-schema* ,endpoint-schema))

+     ,@body))

+

+(defmacro with-session ((var) &body body)

+  `(progn

+     (format t "The session var is: ~a it contains: ~a~%"  ,(symbol-name var) ,var)

+     (let ((,var (context :session)))

+       (format t "The session var is: ~a it now contains: ~a~%"  ,(symbol-name var) ,var)

+       ,@body)))

+

+(defmacro def-route ((url args &key (app *oid*) (method :GET)) &body body)

+  `(setf (ningle:route ,app ,url :method ,method)

+         (lambda ,args

+           (declare (ignorable ,@args))

+           ,@body)))

+(defun gen-state (len)

+  (with-output-to-string (stream)

+    (let ((*print-base* 36))

+      (loop repeat len

+            do (princ (random 36) stream)))))

+

+(defun valid-state (received-state)

+  (let* ((session (context :session))

+         (saved-state (gethash :state session)))

+    (equal saved-state received-state)))

+

+(defmacro my-with-context-variables ((&rest vars) &body body)

+  "This improves fukamachi's version by permitting the variable to be stored somewhere

+   besides the symbol corresponding to the keyword."

+  `(symbol-macrolet

+       ,(loop for (var key) in (ensure-mapping vars)

+              for form = `(context ,(intern (string key) :keyword))

+              collect `(,var ,form))

+     ,@body))

+

+(defmacro string-assoc (key alist) `(assoc ,key ,alist :test #'equal))

+(defmacro assoc-cdr (key alist &optional (test '#'eql)) `(cdr (assoc ,key ,alist :test ,test)))

+

+(defmacro define-auth-entry-point (name endpoint-schema)

+  `(defun ,name (params)

+     (declare (ignore params))

+     (with-session-values (state endpoint-schema) (context :session)

+       (setf state (gen-state 36)

+             endpoint-schema ,endpoint-schema)

+       (with-endpoints ,endpoint-schema

+         (multiple-value-bind (content rcode headers uri) (do-auth-request ,endpoint-schema state)

+           (declare (ignore headers))

+           (if (< rcode 400) `(302 (:location ,(format nil "~a" uri)))

+             content))))))

+

+(defmacro define-auth-callback (name endpoint-schema params &body body)

+  (with-gensyms (get-app-user-cb cb-params)

+    `(defun ,name (,get-app-user-cb)

+       (lambda (,cb-params)

+         (run-callback-function

+           ,endpoint-schema ,cb-params ,get-app-user-cb

+           (lambda ,params

+             ,@body))))))

+

+(defmacro reject-when-state-invalid (params &body body)

+  (alexandria:with-gensyms (received-state)

+    (alexandria:once-only (params)

+      `(let ((,received-state (cdr (string-assoc "state" ,params))))

+         (if (not (valid-state ,received-state))

+           '(403 '() "Out, vile imposter!")

+        ,@body)))))

+

+(defmacro auth-callback-skeleton (params (&key endpoint-schema auth-session-vars) &body body)

+  (alexandria:with-gensyms (session)

+    (alexandria:once-only (params endpoint-schema)

+      `(reject-when-state-invalid ,params

+         (with-endpoints ,endpoint-schema

+           (my-with-context-variables ((,session session))

+             ,(if (null auth-session-vars)

+                `(progn

+                   ,@body)

+                `(with-session-values ,auth-session-vars ,session

+                   ,@body))))))))

+

+(defmacro ensure-logged-in (&body body)

+  "Ensure that the user is logged in: otherwise throw the condition user-not-logged-in"

+  (alexandria:with-gensyms (session userinfo)

+    `(my-with-context-variables ((,session session))

+       (with-session-values ((,userinfo userinfo)) ,session

+         (handler-case

+           (if (null ,userinfo)

+             (error 'user-not-logged-in)

+             (progn ,@body))

+           (error (c)

+             (setf ,userinfo nil)

+             (error c)))))))

+

+(defmacro setup-oid-connect (app args &body callback)

+  `(bind-oid-connect-routes ,app (lambda ,args ,@callback)))

+

+(flet ((handle-no-user (main-body handler-body)

+         `(handler-case (ensure-logged-in ,@main-body)

+            (user-not-logged-in (e) (declare (ignorable e))

+                                ,@handler-body))))

+

+  (defmacro check-login (&body body)

+    "Returns an HTTP 401 Error if not logged in."

+    (handle-no-user body `('(401 () "Unauthorized"))))

+

+  (defmacro require-login (&body body)

+    "Redirects to /login if not logged in."

+    (handle-no-user body

+                    `((with-session-values (next-page) (context :session)

+                        (setf next-page (lack.request:request-path-info *request*))

+                        '(302 (:location "/login")))))))

+

+(defmacro redirect-if-necessary (sessionvar &body body)

+  (with-gensyms (session)

+    `(let* ((,session ,sessionvar)

+            (next-page (gethash :next-page ,session)))

+       (if (and (not (null next-page))

+                (not (string= next-page (lack.request:request-path-info *request*))))

+         (progn

+           (setf (gethash :next-page ,session) nil)

+           `(302 (:location ,next-page)))))))