1. David Krentzlin
  2. open-uri


David Krentzlin  committed 04fbcb8 Draft

added support for authentication outside of the uri

  • Participants
  • Parent commits 2bc884c
  • Branches default

Comments (0)

Files changed (2)

File open-uri-http.scm

View file
  (import chicken scheme)
  (require-library open-uri-base http-client)
- (import open-uri-base http-client)
+(import open-uri-base http-client
+        (only utils read-all))
-(define (open-uri-http uri proc #!rest args)
-  (if (null? args)
-      (call-with-input-request uri #f proc)
-      (call-with-input-request uri (car args) proc)))
+(define (wrap-authentication thunk username password)
+  (lambda ()
+    (parameterize ((determine-username/password (lambda _
+                                                  (values username password))))
+      (thunk))))
+;; (define (wrap-proxy thunk proxy username password)
+;;   (lambda ()
+;;     (parameterize ((determine-proxy-username/password (lambda _ (values username password))))
+;;       (thunk))))
+(define (wrap-proxy thunk proxy username password) thunk)
+(define (open-uri-http uri #!key (reader (cut read-all <>)) request-arguments username password proxy proxy-username proxy-password)
+  (let* ((handler (lambda ()
+                    (call-with-input-request uri request-arguments reader)))
+         (handler/maybe-auth (if (and username password)
+                                 (wrap-authentication handler username password)
+                                 handler))
+         (final-handler (if (and proxy proxy-username proxy-password)
+                            (wrap-proxy handler/maybe-auth proxy proxy-username proxy-password)
+                            handler/maybe-auth)))
+    (final-handler)))
 (register-uri-opener! '(http https) open-uri-http)

File open-uri.scm

View file
 (import open-uri-base
-        (only uri-common uri-reference uri-scheme)
-        (only utils read-all))
+        (only uri-common uri-reference uri-scheme))
 (define (complain kind message)
     (make-property-condition kind
                              'message message))))
-(define (open-uri uri #!optional (proc (lambda (p) (read-all p))) #!rest opener-args)
+(define (open-uri uri #!rest opener-args)
   (let* ((uri-parsed (uri-reference uri))
          (opener (uri-opener-ref (uri-scheme uri-parsed))))
     (unless opener
       (complain 'uri-scheme-unsupported
                 (sprintf "The uri-scheme '~A' is unsupported by open-uri" (uri-scheme uri-parsed))))
-    (apply opener uri-parsed proc opener-args)))
+    (apply opener uri-parsed opener-args)))