@@ -36,16 +36,34 @@

 (in-package :cl-oid-connect)

 ; Should this be here?

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

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

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

-    (iterate:iterate (iterate:for var in vars)

-                     (iterate:collect `(,var (gethash ,(alexandria:make-keyword var) ,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)))

+

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

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

@@ -70,9 +88,6 @@

 (defparameter *endpoint-schema* nil)

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

-(defun get-base-url (request)

-  (format nil "~a//~a/oidc_callback" (lack.request:request-query-parameters)))

-

 (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")

@@ -104,25 +119,23 @@

 (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))

-  (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))

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

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

-

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

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

-                (funcall gat a b)))

-

-    schema))

-

-; This probably should eventually go?

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

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

-     ,@body))

+  "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)

-  (format t "~%client-id: ~a~%" (auth-endpoint endpoint-schema))

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

                        :redirect nil

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

@@ -139,44 +152,49 @@

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

-(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 valid-state (received-state)

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

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

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

-(defmacro check-state (received-state then else)

-  (alexandria:with-gensyms (saved-state session)

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

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

-       (if (equal ,saved-state ,received-state)

-         ,then

-         ,else))))

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

-(defmacro check-login (&body body)

-  (alexandria:with-gensyms (session)

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

-       (if (not (eql nil (gethash :userinfo ,session)))

-         (progn ,@body)

-         (progn

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

-           '(401 () "Unauthorized"))))))

+(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 require-login (&body body)

-  (alexandria:with-gensyms (session)

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

-       (if (not (eql nil (gethash :userinfo ,session)))

-         (progn ,@body)

-         (progn

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

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

-

-(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 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")))))))

 (defun load-facebook-info (loadfrom)

   (with-open-file (fbook-info (truename loadfrom))

@@ -209,7 +227,7 @@

   (discover-endpoints *goog-endpoint-schema*

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

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

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

+  (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")

@@ -217,81 +235,73 @@

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

       (drakma:http-request endpoint

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

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

-                           ))))

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

+(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))))))

+

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

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

+

+(defmacro def-callback-generator (name generator-args callback-args &body body)

+  `(defun ,name ,generator-args

+     (lambda ,callback-args

+       ,@body)))

-(defun google-login-entry (params)

-  (declare (ignore params))

-  (with-context-variables (session)

-    (let ((state (gen-state 36)))

-      (setf (gethash :state session) state)

-      (with-endpoints *goog-endpoint-schema*

-        (setf (gethash :endpoint-schema session) *goog-endpoint-schema*)

-        (multiple-value-bind (content rcode headers) (do-auth-request *goog-endpoint-schema* state)

-          (if (< rcode 400)

-            `(302 (:location ,(cdr (assoc :location headers))))

-            content))))))

-

-(defun facebook-login-entry (params)

-  (declare (ignore params))

-  (let ((session (ningle:context :session))

-        (state (gen-state 36)))

-      (setf (gethash :state session) state)

-      (with-endpoints *fbook-endpoint-schema*

-        (setf (gethash :endpoint-schema session) *fbook-endpoint-schema*)

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

-          (declare (ignore headers))

-          (if (< rcode 400)

-            `(302 (:location ,(format nil "~a" uri)))

-            content)))))

-

-(defun google-callback (login-callback)

-  (lambda (params)

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

-          (code (cdr (string-assoc "code" params))))

-      (check-state received-state

-                   (with-context-variables (session)

-                     (with-endpoints *goog-endpoint-schema*

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

-                              (access-token (assoc-cdr :access--token a-t)) ;; Argh

-                              (id-token (assoc-cdr :id--token a-t))

-                              (decoded (cljwt:decode id-token :fail-if-unsupported nil))

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

-                         (setf (gethash :idtoken session) id-token

-                               (gethash :accesstoken session) access-token

-                               (gethash :userinfo session) user-info

-                               (gethash :app-user session) (funcall login-callback

-                                                                    user-info

-                                                                    decoded

-                                                                    access-token))

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

-                         )))

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

-

-(defmacro setup-session ((session) &rest rest &key nonsense &allow-other-keys)

-  (declare (ignorable nonsense))

-  (cons 'progn

-        (iterate:iterate (iterate:for key   in rest       by #'cddr )

-                         (iterate:for value in (cdr rest) by #'cddr)

-                         (iterate:collect `(setf (gethash ,(alexandria:make-keyword (key)) ,session) ,value)))))

-

-(defun facebook-callback (login-callback)

-  (lambda (params)

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

-          (code (cdr (string-assoc "code" params))))

-      (with-endpoints *fbook-endpoint-schema*

-        (check-state received-state

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

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

-                            (user-info (get-user-info *fbook-endpoint-schema* id-token)))

-                       (with-session-values (accesstoken userinfo idtoken app-user) (context :session)

-                                            (setf accesstoken a-t

-                                                  userinfo user-info

-                                                  idtoken id-token

-                                                  app-user (funcall login-callback user-info id-token a-t)))

-

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

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

+(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))

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

+               ,@body)))))))

+

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

+

+  (def-callback-generator google-callback (get-app-user-cb) (params)

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

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

+      (flet ((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* ((a-t (get-access-token *goog-endpoint-schema* (get-code params)))

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

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

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

+          (setf accesstoken access-token

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

+            idtoken id-token

+            userinfo user-info)

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

+

+  (def-callback-generator facebook-callback (get-app-user-cb) (params)

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

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

+      (flet ((get-id-token (a-t) (assoc-cdr :access--token a-t))) ; <-- access--token is not a mistake

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

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

+               (user-info (get-user-info *fbook-endpoint-schema* id-token)))

+          (setf accesstoken a-t

+            app-user (funcall get-app-user-cb user-info id-token a-t)

+            idtoken id-token

+            userinfo user-info)

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

 (defun userinfo-route (params)

   (declare (ignore params))

@@ -313,7 +323,7 @@

   (setf (route app "/userinfo.json" :method :get) #'userinfo-route

         (route app "/logout"  :method :get) #'logout-route

         (route app "/login/google" :method :get) #'google-login-entry

-        (route app "/login/facebook" :method :get) #'facebook-login-entry 

+        (route app "/login/facebook" :method :get) #'facebook-login-entry

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

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

   (lambda (app) (lambda (env) (funcall app env))))

@@ -328,6 +338,3 @@

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

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

          ,@body))))

-

-(export '(redirect-if-necessary def-route require-login))

-(export '(oauth2-login-middleware with-session))