steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

http.client, automatically add basic auth from urls if present

locals-and-roots
Jon Harper 2016-02-19 17:32:10 +01:00 committed by John Benediktsson
parent 2bf3eb3919
commit e272a5a670
3 changed files with 12 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
basis/http/client/client-docs.factor
View File

@ -281,6 +281,7 @@ $nl
"http.client.encoding" "http.client.encoding"
"http.client.errors" "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" } ; { $see-also "urls" } ;
ABOUT: "http.client" ABOUT: "http.client"

7
basis/http/client/client.factor
View File

@ -37,9 +37,16 @@ ERROR: too-many-redirects ;
: set-cookie-header ( header cookies -- header ) : set-cookie-header ( header cookies -- header )
unparse-cookie "cookie" pick set-at ; 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 ) : write-request-header ( request -- request )
dup header>> >hashtable dup header>> >hashtable
over url>> host>> [ set-host-header ] when over url>> host>> [ set-host-header ] when
over url>> "Authorization" ?set-basic-auth
over post-data>> [ set-post-data-headers ] when* over post-data>> [ set-post-data-headers ] when*
over cookies>> [ set-cookie-header ] unless-empty over cookies>> [ set-cookie-header ] unless-empty
write-header ; write-header ;

5
basis/http/http.factor
View File

@ -143,8 +143,11 @@ redirects ;
: set-header ( request/response value key -- request/response ) : set-header ( request/response value key -- request/response )
pick header>> set-at ; pick header>> set-at ;
: basic-auth ( username password -- str )
":" glue >base64 "Basic " "" prepend-as ;
: set-basic-auth ( request username password -- request ) : set-basic-auth ( request username password -- request )
":" glue >base64 "Basic " "" prepend-as "Authorization" set-header ; basic-auth "Authorization" set-header ;
: <request> ( -- request ) : <request> ( -- request )
request new request new