;;;; cl-oid-connect.lisp

 ;;;; TODO: Need to refactor out server names!!!

 #|

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

 ; Should this be here?

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

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

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

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

 (defun load-goog-endpoint-schema ()
   (discover-endpoints *goog-endpoint-schema*
                       "https://accounts.google.com/.well-known/openid-configuration"

                       #'goog-get-access-token)

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

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

 (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)))
       (values access-token
         (get-user-info *goog-endpoint-schema* access-token)
         (get-id-token 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)))
       (values a-t (get-user-info *fbook-endpoint-schema* id-token) id-token))))
 
 (defun initialize-oid-connect (facebook-info google-info)
   "Load the Google and Facebook app secrets and initialize Google's openid-configuration
    form its well-known document"
   (load-provider-secrets *fbook-info* facebook-info)
   (load-provider-secrets *goog-info* google-info) 
   (load-goog-endpoint-schema))
 
 (defun bind-oid-connect-routes (app &optional (login-callback #'identity))
   (setf (route app "/login/google" :method :get) (lambda (params) (google-login-entry params))
         (route app "/login/facebook" :method :get) (lambda (params) (facebook-login-entry params))

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

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