Merge branch 'master' of git://factorcode.org/git/factor

basis/http/client/client-docs.factor

@@ -56,8 +56,7 @@ HELP: http-request
 
 HELP: with-http-request
 { $values { "request" request } { "quot" { $quotation "( chunk -- )" } } { "response" response } }
-{ $description "Sends an HTTP request to an HTTP server, and reads the response incrementally. Chunks of data are passed to the quotation as they are read." }
-{ $errors "Throws an error if the HTTP request fails." } ;
+{ $description "Sends an HTTP request to an HTTP server, and reads the response incrementally. Chunks of data are passed to the quotation as they are read. Does not throw an error if the HTTP request fails; to do so, call " { $link check-response } " on the " { $snippet "response" } "." } ;
 
 ARTICLE: "http.client.get" "GET requests with the HTTP client"
 "Basic usage involves passing a " { $link url } " and getting a " { $link response } " and data back:"

basis/http/client/client.factor

@@ -141,12 +141,15 @@ ERROR: download-failed response ;
 : check-response ( response -- response )
     dup code>> success? [ download-failed ] unless ;
 
+: check-response-with-body ( response body -- response body )
+    [ >>body check-response ] keep ;
+
 : with-http-request ( request quot -- response )
-    [ (with-http-request) check-response ] with-destructors ; inline
+    [ (with-http-request) ] with-destructors ; inline
 
 : http-request ( request -- response data )
     [ [ % ] with-http-request ] B{ } make
-    over content-charset>> decode ;
+    over content-charset>> decode check-response-with-body ;
 
 : <get-request> ( url -- request )
     "GET" <client-request> ;

basis/http/http-docs.factor

@@ -113,6 +113,12 @@ HELP: set-header
 { $notes "This word always returns the same object that was input. This allows for a “pipeline” coding style, where several header parameters are set in a row." }
 { $side-effects "request/response" } ;
 
+HELP: set-basic-auth
+{ $values { "request" request } { "username" string } { "password" string } }
+{ $description "Sets the " { $snippet "Authorization" } " header of " { $snippet "request" } " to perform HTTP Basic authentication with the given " { $snippet "username" } " and " { $snippet "password" } "." }
+{ $notes "This word always returns the same object that was input. This allows for a “pipeline” coding style, where several header parameters are set in a row." }
+{ $side-effects "request" } ;
+
 ARTICLE: "http.cookies" "HTTP cookies"
 "Every " { $link request } " and " { $link response } " instance can contain cookies."
 $nl

basis/http/http-tests.factor

@@ -359,3 +359,8 @@ SYMBOL: a
 ! Test cloning
 [ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test
 [ f ] [ <404> dup clone "b" "a" <cookie> put-cookie drop "a" get-cookie ] unit-test
+
+! Test basic auth
+[ "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" ] [ <request> "Aladdin" "open sesame" set-basic-auth "Authorization" header ] unit-test
+
+

basis/http/http.factor

@@ -7,7 +7,8 @@ calendar.format present urls fry
 io io.encodings io.encodings.iana io.encodings.binary
 io.encodings.8-bit io.crlf
 unicode.case unicode.categories
-http.parsers ;
+http.parsers
+base64 ;
 IN: http
 
 : (read-header) ( -- alist )
@@ -142,6 +143,9 @@ cookies ;
 : set-header ( request/response value key -- request/response )
     pick header>> set-at ;
 
+: set-basic-auth ( request username password -- request )
+    ":" glue >base64 "Basic " prepend "Authorization" set-header ;
+    
 : <request> ( -- request )
     request new
         "1.1" >>version
@@ -156,6 +160,7 @@ cookies ;
 : header ( request/response key -- value )
     swap header>> at ;
 
+
 TUPLE: response
 version
 code

extra/twitter/twitter.factor

@@ -0,0 +1,22 @@
+USING: accessors assocs hashtables http http.client json.reader
+kernel namespaces urls.secure urls.encoding ;
+IN: twitter
+
+SYMBOLS: twitter-username twitter-password ;
+
+: set-twitter-credentials ( username password -- )
+    [ twitter-username set ] [ twitter-password set ] bi* ; 
+
+: set-request-twitter-auth ( request -- request )
+    twitter-username twitter-password [ get ] bi@ set-basic-auth ;
+
+: update-post-data ( update -- assoc )
+    "status" associate ;
+
+: tweet* ( string -- result )
+    update-post-data "https://twitter.com/statuses/update.json" <post-request>
+        set-request-twitter-auth 
+    http-request nip json> ;
+
+: tweet ( string -- ) tweet* drop ;
+