@@ -12,6 +12,7 @@

                :anaphora

                :alexandria

                :lack-middleware-session

+               :sheeple

                :cl-who)

   :serial t

   :components ((:file "package")

@@ -33,41 +33,15 @@

 |#

 (in-package :cl-oid-connect)

+(declaim (optimize (debug 2)))

 ; Should this be here?

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

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

 (sheeple:defproto =service-info= ()

                   ((client-id nil :accessor t)

                    (secret nil :accessor t)))

-(defvar *FBOOK-INFO* (sheeple:clone =service-info=))

-(defun load-facebook-info (loadfrom)

-  (setf *FBOOK-INFO* 

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

-          (let* ((data (yason:parse fbook-info))

-                 (client-id (gethash "client-id" data))

-                 (secret (gethash "secret" data)))

-            (sheeple:defobject (=service-info=)

-                               ((client-id client-id)

-                                (secret secret)))))))

-

-(defvar *GOOG-INFO* (sheeple:clone =service-info=))

-(defun load-google-info (loadfrom)

-  (setf *GOOG-INFO*

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

-          (let* ((data (yason:parse goog-info))

-                 (client-id (gethash "client-id" data))

-                 (secret (gethash "secret" data)))

-            (sheeple:defobject (=service-info=)

-                               ((client-id client-id)

-                                (secret secret)))))))

-

-(load-facebook-info #p"facebook-secrets.json")

-(load-google-info #p"google-secrets.json")

-

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

-(defmacro assoc-cdr (key alist) `(cdr (assoc ,key ,alist)))

-

 (sheeple:defproto =endpoint-schema= ()

                   ((auth-endpoint nil :accessor t)

                    (token-endpoint nil :accessor t)

@@ -78,42 +52,11 @@

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

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

-(defun discover-endpoints (service-info 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)))

-        (schema (sheeple:object :parents `(,=endpoint-schema= ,service-info))))

-

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

-    (setf (token-endpoint schema) (assoc-cdr :token--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?

-(defvar *endpoint-schema* nil)

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

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

-     ,@body))

-

-(defun goog-get-access-token (endpoint-schema code)

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

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

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

-                                       ("grant_type" . "authorization_code")))))

-

+(defparameter *FBOOK-INFO* (sheeple:clone =service-info=))

+(defparameter *GOOG-INFO* (sheeple:clone =service-info=))

+(defparameter *endpoint-schema* nil)

 ; goog is well behaved

-(defvar *goog-endpoint-schema*

-  (discover-endpoints *GOOG-INFO* "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")

-

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

 ; fbook needs personal attention

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

@@ -142,18 +85,25 @@

       (drakma:http-request endpoint

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

-(defvar *fbook-mw*

-  (lambda (app)

-    (lambda (env)

-      (with-fbook-endpoints

-        (format t "~a" *client-id*)

-        (funcall app env)))))

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

+(defmacro assoc-cdr (key alist) `(cdr (assoc ,key ,alist)))

-(defvar *goog-mw*

-  (lambda (app)

-    (lambda (env)

-      (with-goog-endpoints

-        (funcall app env)))))

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

+

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

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

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

@@ -172,9 +122,9 @@

       (loop repeat len

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

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

-(defmacro def-route (url args &body body)

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

+

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

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

          #'(lambda ,args

              (declare (ignorable ,@args))

              ,@body)))

@@ -201,68 +151,131 @@

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

      ,@body))

+(defun load-facebook-info (loadfrom)

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

+    (let* ((data (yason:parse fbook-info))

+           (client-id (gethash "client-id" data))

+           (secret (gethash "secret" data)))

+      (setf (client-id *FBOOK-INFO*) client-id) 

+      (setf (secret *FBOOK-INFO*) secret))))

-(def-route "/login/google" (params)

-  (with-session (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 load-google-info (loadfrom)

+  (with-open-file (goog-info (truename loadfrom))

+    (let* ((data (yason:parse goog-info))

+           (client-id (gethash "client-id" data))

+           (secret (gethash "secret" data)))

+      (setf (client-id *GOOG-INFO*) client-id)

+      (setf (secret *GOOG-INFO*) secret))))

+(defun goog-get-access-token (endpoint-schema code)

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

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

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

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

-(def-route "/login/facebook" (params)

-  (with-session (session)

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

-          (if (< rcode 400)

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

-            content))))))

-

-(def-route "/oidc_callback/google" (params)

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

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

-    (check-state received-state

-                 (with-session (session)

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

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

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

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

-                       (setf (gethash :userinfo session) decoded)

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

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

-

-

-(def-route "/oidc_callback/facebook" (params)

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

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

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

-      (check-state received-state

-                   (with-session (session)

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

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

-                       (setf (gethash :userinfo session) (get-user-info *fbook-endpoint-schema* id-token))

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

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

-

-(def-route "/userinfo.json" (params)

-  (with-session (session)

-    (require-login 

-      (with-endpoints  (gethash :endpoint-schema session)

-        (cl-json:encode-json-to-string (gethash :userinfo session))))))

+(defun load-goog-endpoint-schema ()

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

-(def-route "/logout" (params)

-  (with-session (session)

-    (setf (gethash :userinfo session) nil)

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

-(def-route "/login" (params)

+(defun oauth2-login-middleware (&key google-info facebook-info)

+  (lambda (app)

+    (load-facebook-info facebook-info)

+    (load-goog-endpoint-schema)

+    (load-google-info google-info)

+

+    (def-route ("/login/google" (params) :app app)

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

+

+

+    (def-route ("/login/facebook" (params) :app app)

+      (with-session (session)

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

+

+    (def-route ("/oidc_callback/google" (params) :app app)

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

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

+        (check-state received-state

+                     (with-session (session)

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

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

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

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

+                           (setf (gethash :userinfo session) decoded)

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

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

+

+

+    (def-route ("/oidc_callback/facebook" (params) :app app)

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

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

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

+          (check-state received-state

+                       (with-session (session)

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

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

+                           (setf (gethash :userinfo session) (get-user-info *fbook-endpoint-schema* id-token))

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

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

+

+    (def-route ("/userinfo.json" (params) :app app)

+      (with-session (session)

+        (require-login 

+          (with-endpoints  (gethash :endpoint-schema session)

+            (cl-json:encode-json-to-string (gethash :userinfo session))))))

+

+    (def-route ("/logout" (params) :app app)

+      (with-session (session)

+        (setf (gethash :userinfo session) nil)

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

+

+    app))

+

+

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

+

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

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

+

+(in-package :cl-user)

+(import '(cl-oid-connect:redirect-if-necessary cl-oid-connect:def-route cl-oid-connect:require-login))

+(import '(cl-oid-connect:oauth2-login-middleware cl-oid-connect:with-session))

+

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

+

+(def-route ("/login" (params) :app *app*)

   (cl-who:with-html-output-to-string (s)

     (:html

       (:head

@@ -271,16 +284,23 @@

         (:div (:a :href "/login/facebook" "Facebook"))

         (:div (:a :href "/login/google" "Google")))))) 

-(def-route "/" (params)

+(def-route ("/" (params) :app *app*)

   (with-session (session)

-    (if (not (null (gethash :next-page session)))

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

+    (redirect-if-necessary session

       (require-login 

         (anaphora:sunless (gethash :counter session) (setf anaphora:it 0))

+        (incf (gethash :counter session))

         (format nil "~Ath visit<br/>~a<br/><br/>~S<br/>"

                 (gethash :counter session)

                 (alexandria:hash-table-alist session)

-                (alexandria:hash-table-alist (context :session)))))))

-

-(setf *handler* (clack:clackup (lack.builder:builder :session *app*) :port 9090))

+                (alexandria:hash-table-alist (ningle:context :session)))))))

+

+(setf *handler* (clack:clackup (lack.builder:builder

+                                 :backtrace

+                                 :session

+                                 (funcall

+                                   (oauth2-login-middleware

+                                     :facebook-info (truename "facebook-secrets.json") 

+                                     :google-info (truename "google-secrets.json"))

+                                   *app*)) :port 9090))

@@ -1,14 +1,14 @@

 ;;;; package.lisp

-(ql:quickload :ningle)

-(ql:quickload :clack)

-(ql:quickload :drakma)

-(ql:quickload :cljwt)

-(ql:quickload :cl-json)

-(ql:quickload :anaphora)

-(ql:quickload :alexandria)

-(ql:quickload :lack-middleware-session)

-(ql:quickload :cl-who)

-(ql:quickload :sheeple)

+;(ql:quickload :ningle)

+;(ql:quickload :clack)

+;(ql:quickload :drakma)

+;(ql:quickload :cljwt)

+;(ql:quickload :cl-json)

+;(ql:quickload :anaphora)

+;(ql:quickload :alexandria)

+;(ql:quickload :lack-middleware-session)

+;(ql:quickload :cl-who)

+;(ql:quickload :sheeple)

 (defpackage :cl-oid-connect

   (:use #:cl #:drakma #:ningle #:clack #:cljwt #:anaphora #:alexandria #:sheeple))