Welcome to the CHICKEN Scheme pasting service

(use uri-common http-client intarweb)
(use data-structures)

;export make-oauth-service-provider
;       make-oauth-service
;       authenticated-call-with-input-request
;       with-oauth
;       acquire-temporary-credential
;       authorize-resource-owner
;       acquire-token-credential


(define empty-credential  '("" . ""))

(define (make-oauth-credential identifier secret)
 (cons identifier secret))

(define token car)
(define secret cdr)

(define supported-signatures   '(plaintext)) ; '(plaintext hmac-sha1 rsa-sha1)
(define supported-methods      '(POST)) ; '(POST GET)
(define supported-transmission '(authorization-header)) ; '(authorization-header request-entity-body query-string)

; Differences between 1.0 and 1.0a
;   http://code.google.com/p/oauth/source/diff?spec=svn1058&old=991&r=1058&format=unidiff&path=%2Fspec%2Fcore%2F1.0a%2Foauth-core-1_0a.xml
;     + oauth_callback in temporary credential acquisition rather than owner auth
;     + oauth_callback_confirmed in temporary credential response
;     + presence of oauth_verifier in owner auth callback query string
;     + in absence of callback, display of verification code rather than assertion that auth has completed.
; Differences between 1.0a and rfc5849
;   http://tools.ietf.org/html/rfc5849#appendix-A
;     + MUST use TLS/SSL with PLAINTEXT
;     + nonce and timestamp parameters OPTIONAL when using PLAINTEXT
;     + permitted omitting empty oauth_token
;     + various other things only relevant for non PLAINTEXT signatures
(define supported-versions     '(1.0 1.0a rfc5849))

(define (memv? obj lst) (and (memv obj lst) #t))


; Particulars specified by RFC5849, Section 2
(define (make-oauth-service-provider #!key protocol-version signature-method owner-auth-url
				     credential-request-url (credential-request-method 'POST)
				     token-request-url (token-request-method 'POST)
				     (transmission-method 'authorization-header))
  (assert (memv protocol-version supported-versions))
  (assert (string? credential-request-url))
  (assert (string? owner-auth-url))
  (assert (string? token-request-url))
  (assert (memv signature-method supported-signatures))
  (assert (memv credential-request-method supported-methods))
  (assert (memv token-request-method supported-methods))
  (assert (memv transmission-method supported-transmission))

  (let ((credential-request-url (uri-reference credential-request-url))
	(owner-auth-url         (uri-reference owner-auth-url))
	(token-request-url      (uri-reference token-request-url)))
    (assert (eqv? 'https (uri-scheme credential-request-url)))
    (assert (eqv? 'https (uri-scheme token-request-url)))

    `((protocol-version       . ,protocol-version)
      (signature-method       . ,signature-method)
      (credential-request-req . ,(make-request uri:    credential-request-url
					       method: credential-request-method))
      (owner-auth-url         . ,owner-auth-url)
      (token-request-req      . ,(make-request uri:    token-request-url
					       method: token-request-method))
      (confirms-callback      . ,(memv? protocol-version '(1.0a rfc5849)))
      (callback-on-credential . ,(memv? protocol-version '(1.0a rfc5849)))
      (callback-on-owner-auth . ,(memv? protocol-version '(1.0)))
      (sends-oauth-verifier   . ,(memv? protocol-version '(1.0a rfc5849)))
      )))


(define (make-oauth-service #!key service client-credential)
 (alist-cons 'client-credential client-credential service))


(define (authenticated-call-with-input-request service protocol-parameters token-credential uri-or-request writer reader)
  (let* ((uri (cond ((uri? uri-or-request) uri-or-request) ; stolen from http-client
		    ((string? uri-or-request) (uri-reference uri-or-request))
		    (else (request-uri uri-or-request))))
	 (req (if (request? uri-or-request) ; stolen from http-client
		uri-or-request
		(make-request uri: uri method: (if writer 'POST 'GET))))
	 (body (if (list? writer) writer #f)) ; RFC5849: Section 3.4.1.3.1. Parameter Sources
	 (signature-method (alist-ref 'signature-method service))
	 (protocol-parameters
	   (append protocol-parameters
		   `((oauth_consumer_key     . ,(token (alist-ref 'client-credential service)))
		     (oauth_token            . ,(token token-credential))
		     (oauth_signature_method . ,(string-upcase (symbol->string signature-method)))
		     (oauth_version          . ,(exact->inexact (alist-ref 'protocol-version service)))
		     ,@(if (not (eqv? 'plaintext signature-method))
			 `((oauth_timestamp . "bar")
			   (oauth_nonce . "bar"))
			 '()))))
	 (signature (sign-request req protocol-parameters body service token-credential))
	 (protocol-parameters (alist-cons 'oauth_signature signature protocol-parameters)))
    (call-with-input-request
      (update-request
	req
	headers: (headers `((authorization . (#(OAuth ,protocol-parameters))))))
      (or body writer)
      reader)))


(define %encode uri-encode-string)


(define (sign-request request protocol-parameters body service token-credential)
  ; For hmac-sha1 and rsa-sha1 we must assert the http request entity-body conditions of RFC5849: Section 3.4.1.3.1
  (let ((signature-method (alist-ref 'signature-method service)))
    (case signature-method
      ((plaintext) ; RFC5849: Section 3.4.4 - MUST be used with TLS/SSL.
       ;(assert (eqv? 'https (uri-scheme (request-uri request))))
       (let ((client-credential (alist-ref 'client-credential service)))
	 (conc (%encode (secret client-credential)) "&" (%encode (secret token-credential)))))
      (else (abort (conc signature-method " signature method not implemented!"))))))


; This generates an "Authorization: Oauth ..." header. The OAuth spec calls for
; "Authorization: OAuth ..." but HTTP declares it as case-insensitive:
;
; "HTTP provides a simple challenge-response authentication mechanism that MAY
; be used by a server to challenge a client request and by a client to provide
; authentication information. It uses an extensible, case-insensitive token to
; identify the authentication scheme, followed by a comma-separated list of
; attribute-value pairs which carry the parameters necessary for achieving
; authentication via that scheme."
;  -- RFC2617, section 1.2
;
(authorization-param-subunparsers
  (alist-cons
    'OAuth
    (lambda (params)
      (string-intersperse
	(map (lambda (p)
	       (conc  (%encode (symbol->string (car p))) "=\"" (%encode (->string (cdr p))) "\""))
	     params)
      ", "))
    (authorization-param-subunparsers)))


(define (with-oauth service token-credential thunk)
  (fluid-let ((call-with-input-request
		(cut authenticated-call-with-input-request service '() token-credential <> <> <>)))
	      (thunk)))


(define (acquire-temporary-credential service #!optional callback-url)
  (let* ((callback-on-credential (alist-ref 'callback-on-credential service))
	 (_ (if (and (not callback-on-credential) callback-url)
	     (abort "This service does not accept callback-url during temporary credential acquisition.")))
	 (resp
	   (nth-value 0 (authenticated-call-with-input-request
			  service
			  `(,@(if (and callback-on-credential callback-url)
				`((oauth_callback . ,callback-url))
				'()))
			  empty-credential
			  (alist-ref 'credential-request-req service)
			  "" ; forces POST even if credential-request-req isn't a request object.
			  (lambda (p) (form-urldecode (read-string #f p)))))) ; string that stray \r ???
	 (credential (make-oauth-credential
		       (alist-ref 'oauth_token resp eqv? "")
		       (alist-ref 'oauth_token_secret resp eqv? "")))
	 (_ (if (alist-ref 'confirms-callback service)
	      (assert (alist-ref 'oauth_callback_confirmed resp)))) ; RFC5849: Section 2.1
	 (rest (remove
		 (lambda (e) (memv (car e) '(oauth_token_secret oauth_token oauth_callback_confirmed)))
		 resp)))
    (values credential rest)))

(define (authorize-resource-owner service temporary-credential #!optional callback-url)
  (let* ((callback-on-owner-auth (alist-ref 'callback-on-owner-auth service))
	 (_ (if (and (not callback-on-owner-auth) callback-url)
	      (abort "This service does not accept callback-url during resource owner authorization.")))
	 (callback-url (cond ((uri? callback-url) (uri->string callback-url))
			     (else callback-url)))
	 (uri (alist-ref 'owner-auth-url service))
	 (query (uri-query uri))
	 (query (alist-cons 'oauth_token (token temporary-credential) query))
	 (query (if (and callback-on-owner-auth callback-url)
		  (alist-cons 'oauth_callback callback-url query)
		  query))
	 (uri (update-uri uri query: query)))
  uri)) ; return a uri object that the user can be redirected to.

(define (acquire-token-credential service temporary-credential #!optional verifier)
  (let* ((_ (if (alist-ref 'sends-oauth-verifier service) (abort "oauth_verifier MUST be supplied!")))
	 (resp (nth-value 0 (authenticated-call-with-input-request
			      service
			      (if verifier `((oauth_verifier . ,verifier)) '())
			      temporary-credential
			      (alist-ref 'token-request-req service)
			      ""; forces POST even if token-request-req isn't a request object.
			      (lambda (p) (form-urldecode (read-string #f p)))))) ; string that stray \r ???
	 (credential (make-oauth-credential
		       (alist-ref 'oauth_token resp eqv? "")
		       (alist-ref 'oauth_token_secret resp eqv? "")))
	 (rest (remove
		 (lambda (e) (memv (car e) '(oauth_token_secret oauth_token)))
		 resp)))
    (values credential rest)))




(define dropbox (make-oauth-service-provider
		  protocol-version: 1.0
		  credential-request-url: "https://api.dropbox.com/1/oauth/request_token"
		  owner-auth-url: "https://www.dropbox.com/1/oauth/authorize"
		  token-request-url: "https://api.dropbox.com/1/oauth/access_token"
		  signature-method: 'plaintext))
;(define mydropbox (make-oauth-service service: dropbox client-credential: (make-oauth-credential "p" "q")))
;  (with-oauth mydropbox '("a" . "b") (lambda () (call-with-input-request "http://www.google.com" #f (cut read-string #f <>))