From e272a5a670affae86c73dc5820d074165e2e8aeb Mon Sep 17 00:00:00 2001
From: Jon Harper <jon.harper87@gmail.com>
Date: Fri, 19 Feb 2016 17:32:10 +0100
Subject: [PATCH] http.client, automatically add basic auth from urls if
 present

---
 basis/http/client/client-docs.factor | 1 +
 basis/http/client/client.factor      | 7 +++++++
 basis/http/http.factor               | 5 ++++-
 3 files changed, 12 insertions(+), 1 deletion(-)

diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor
index e7b661b038..ac55c79472 100644
--- a/basis/http/client/client-docs.factor
+++ b/basis/http/client/client-docs.factor
@@ -281,6 +281,7 @@ $nl
     "http.client.encoding"
     "http.client.errors"
 }
+"For authentication, only Basic Access Authentication is implemented, using the username/password from the target url. Alternatively, the " { $link set-basic-auth } " word can be called on the " { $link request } " object."
 { $see-also "urls" } ;
 
 ABOUT: "http.client"
diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor
index 3c9174c96b..47645d3281 100644
--- a/basis/http/client/client.factor
+++ b/basis/http/client/client.factor
@@ -37,9 +37,16 @@ ERROR: too-many-redirects ;
 : set-cookie-header ( header cookies -- header )
     unparse-cookie "cookie" pick set-at ;
 
+: ?set-basic-auth ( header url name -- header )
+    swap [
+        [ username>> ] [ password>> ] bi 2dup and
+        [ basic-auth swap pick set-at ] [ 3drop ] if
+    ] [ drop ] if* ;
+
 : write-request-header ( request -- request )
     dup header>> >hashtable
     over url>> host>> [ set-host-header ] when
+    over url>> "Authorization" ?set-basic-auth
     over post-data>> [ set-post-data-headers ] when*
     over cookies>> [ set-cookie-header ] unless-empty
     write-header ;
diff --git a/basis/http/http.factor b/basis/http/http.factor
index 9e1f6377cd..a2025a4e0d 100644
--- a/basis/http/http.factor
+++ b/basis/http/http.factor
@@ -143,8 +143,11 @@ redirects ;
 : set-header ( request/response value key -- request/response )
     pick header>> set-at ;
 
+: basic-auth ( username password -- str )
+    ":" glue >base64 "Basic " "" prepend-as ;
+
 : set-basic-auth ( request username password -- request )
-    ":" glue >base64 "Basic " "" prepend-as "Authorization" set-header ;
+    basic-auth "Authorization" set-header ;
 
 : <request> ( -- request )
     request new