@@ -1,11 +1,20 @@

 ;;;; cl-oid-connect.asd

 (asdf:defsystem :cl-oid-connect

-  :description "Describe cl-oid-connect here"

-  :author "Your Name <your.name@example.com>"

-  :license "Specify license here"

-  :depends-on (#:drakma)

+  :description "A Common Lisp Implementation of Various OAuth2 Authentication Protocols"

+  :author "Ed L <(format nil \"~a@~a\" \"el-projects\" \"howit.is\")>"

+  :license "2=Clause BSD"

+  :depends-on (:drakma

+               :ningle

+               :clack

+               :cljwt

+               :cl-json

+               :anaphora

+               :alexandria

+               :lack-middleware-session

+               :cl-who)

   :serial t

   :components ((:file "package")

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

+

@@ -1,97 +1,143 @@

 ;;;; cl-oid-connect.lisp

 #|

- |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.

- |

- |#

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

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

-

-(with-open-file (fbook-info #P"facebook-secrets.json")

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

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

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

-    (defvar *FBOOK-CLIENT-ID* client-id)

-    (defvar *FBOOK-CLIENT-SECRET* secret)))

-

-(with-open-file (goog-info #P"google-secrets.json")

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

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

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

-    (defvar *GOOG-CLIENT-ID* client-id)

-    (defvar *GOOG-CLIENT-SECRET* secret)))

-

-;;; "cl-oid-connect" goes here. Hacks and glory await!

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

-(defvar *state* nil)

-

-;; These tokens specify the auth endpoint. These are autodiscovered, if the relevant

-;; functions are wrapped with the "with-goog-endpoints" macro.

-(defvar *auth-endpoint* nil)

-(defvar *token-endpoint* nil)

-(defvar *client-id* nil)

-(defvar *client-secret* nil)

-(defvar *user-info-cb* (lambda ()))

-(defvar *get-access-token* (lambda ()))

-(defvar *redirect-uri* nil)

+; Should this be here?

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

-(defmacro with-goog-endpoints (&body body)

-  (alexandria:with-gensyms (discovery-document)

-    `(let* ((,discovery-document

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

-                (drakma:http-request "https://accounts.google.com/.well-known/openid-configuration")))

-            (*auth-endpoint* (assoc-cdr :authorization--endpoint ,discovery-document))

-            (*token-endpoint* (assoc-cdr :token--endpoint ,discovery-document))

-            (*client-id* *GOOG-CLIENT-ID*)

-            (*client-secret* *GOOG-CLIENT-SECRET*)

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

-            )

-       ,@body)))     

-

-

-(defmacro with-fbook-endpoints (&body body)

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

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

-          (*client-id* *FBOOK-CLIENT-ID*)

-          (*client-secret* *FBOOK-CLIENT-SECRET*)

-          (*user-info-cb* #'fb-get-userinfo)

-          (*get-access-token* #'fb-get-access-token)

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

-     ,@body))     

-

-(defun fb-get-userinfo (access-token)

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

+(sheeple:defproto =endpoint-schema= ()

+                  ((auth-endpoint nil :accessor t)

+                   (token-endpoint nil :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=)))

+

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

+

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

+

+

+; fbook needs personal attention

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

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

@@ -109,27 +155,15 @@

       (with-goog-endpoints

         (funcall app env)))))

-(defun get-access-token (code)

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

-    (drakma:http-request *token-endpoint*

-                         :method :post

-                         :redirect nil

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

-                                       ("client_id" . ,*client-id*)

-                                       ("app_id" . ,*client-id*)

-                                       ("client_secret" . ,*client-secret*)

-                                       ("redirect_uri" . ,*redirect-uri*)

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

-

-(defun do-auth-request (state)

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

-  (drakma:http-request *auth-endpoint*

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

-                                       ("app_id" . ,*client-id*)

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

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

                                      ("response_type" . "code")

                                      ("scope" . "email")

-                                     ("redirect_uri" . ,*redirect-uri*)

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

                                      ("state" . ,state))))

 (defun gen-state (len)

@@ -138,6 +172,7 @@

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

          #'(lambda ,args

@@ -158,29 +193,22 @@

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

          (progn

            ,@body)

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

+         (progn

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

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

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

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

      ,@body))

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

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

-    (:html

-      (:head

-        (:title "Login"))

-      (:body

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

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

-

-

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

   (with-session (session)

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

       (setf (gethash :state session) state)

-      (with-goog-endpoints 

-        (multiple-value-bind (content rcode headers) (do-auth-request 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))))))

@@ -190,28 +218,21 @@

   (with-session (session)

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

       (setf (gethash :state session) state)

-      (with-fbook-endpoints 

-        (multiple-value-bind (content rcode headers uri) (do-auth-request 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" (params)

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

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

-;    (with-fbook-endpoints

-;      (check-state received-state

-;                   (let* ((a-t (get-access-token code)))

-;                     (format nil "~s" a-t))

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

-

 (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-goog-endpoints 

-                     (let* ((a-t (get-access-token code)) (id-token (assoc-cdr :id--token a-t))

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

@@ -221,19 +242,19 @@

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

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

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

-    (with-fbook-endpoints 

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

       (check-state received-state

                    (with-session (session)

-                     (let* ((a-t (get-access-token code))

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

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

-                       (setf (gethash :userinfo session) (funcall *user-info-cb* id-token))

+                       (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-fbook-endpoints 

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

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

 (def-route "/logout" (params)

@@ -241,16 +262,25 @@

     (setf (gethash :userinfo session) nil)

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

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

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

+    (:html

+      (:head

+        (:title "Login"))

+      (:body

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

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

+

 (def-route "/" (params)

   (with-session (session)

-    (require-login 

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

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

-              (gethash :counter session)

-              (alexandria:hash-table-alist session)

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

-

-

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

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

+      (require-login 

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

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

@@ -7,7 +7,9 @@

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

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