From 7e318bae5771c75bf5e2e08e849610747db60245 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 5 Jul 2010 22:14:06 -0400
Subject: [PATCH] oauth: basic implementation of an OAuth consumer

---
 extra/oauth/authors.txt        |   1 +
 extra/oauth/oauth-tests.factor |  26 ++++++
 extra/oauth/oauth.factor       | 159 +++++++++++++++++++++++++++++++++
 3 files changed, 186 insertions(+)
 create mode 100644 extra/oauth/authors.txt
 create mode 100644 extra/oauth/oauth-tests.factor
 create mode 100644 extra/oauth/oauth.factor

diff --git a/extra/oauth/authors.txt b/extra/oauth/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/extra/oauth/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/extra/oauth/oauth-tests.factor b/extra/oauth/oauth-tests.factor
new file mode 100644
index 0000000000..4f4907e439
--- /dev/null
+++ b/extra/oauth/oauth-tests.factor
@@ -0,0 +1,26 @@
+USING: oauth oauth.private tools.test accessors kernel assocs
+strings namespaces ;
+IN: oauth.tests
+
+[ "%26&b" ] [ "&" "b" hmac-key ] unit-test
+[ "%26&" ] [ "&" f hmac-key ] unit-test
+
+[ "B&http%3A%2F%2Ftwitter.com&a%3Db" ] [
+    "http://twitter.com"
+    "B"
+    { { "a" "b" } }
+    signature-base-string
+] unit-test
+
+[ "Z5tUa83q43qiy6dGGCb92bN/4ik=" ] [
+    "ABC" "DEF" <token> consumer-token set
+
+    "http://twitter.com"
+    <request-token-params>
+        12345 >>timestamp
+        54321 >>nonce
+    <request-token-request>
+    post-data>>
+    "oauth_signature" swap at
+    >string
+] unit-test
diff --git a/extra/oauth/oauth.factor b/extra/oauth/oauth.factor
new file mode 100644
index 0000000000..0b00e9b875
--- /dev/null
+++ b/extra/oauth/oauth.factor
@@ -0,0 +1,159 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs base64 calendar checksums.hmac
+checksums.sha combinators fry http http.client kernel locals
+make math namespaces present random sequences sorting strings
+urls urls.encoding ;
+IN: oauth
+
+SYMBOL: consumer-token
+
+TUPLE: token key secret user-data ;
+
+: <token> ( key secret -- token )
+    token new
+        swap >>secret
+        swap >>key ;
+
+<PRIVATE
+
+TUPLE: token-params
+consumer-token
+timestamp
+nonce ;
+
+: new-token-params ( class -- params )
+    new
+        consumer-token get >>consumer-token
+        now timestamp>unix-time >integer >>timestamp
+        random-32 >>nonce ; inline
+
+:: signature-base-string ( url request-method params -- string )
+    [
+        request-method % "&" %
+        url present url-encode-full % "&" %
+        params assoc>query url-encode-full %
+    ] "" make ;
+
+: hmac-key ( consumer-secret token-secret -- key )
+    [ url-encode-full ] [ "" or url-encode-full ] bi* "&" glue ;
+
+: make-token-params ( params quot -- assoc )
+    '[
+        "1.0" "oauth_version" set
+        "HMAC-SHA1" "oauth_signature_method" set
+
+        _
+        [
+            [ consumer-token>> key>> "oauth_consumer_key" set ]
+            [ timestamp>> "oauth_timestamp" set ]
+            [ nonce>> "oauth_nonce" set ]
+            tri
+        ] bi
+    ] H{ } make-assoc ; inline
+
+:: sign-params ( url request-method consumer-token request-token params -- signed-params )
+    params >alist sort-keys :> params
+    url request-method params signature-base-string :> sbs
+    consumer-token secret>> request-token dup [ secret>> ] when hmac-key :> key
+    sbs key sha1 hmac-bytes >base64 >string :> signature
+    params { "oauth_signature" signature } prefix ;
+
+: extract-user-data ( assoc -- assoc' )
+    [
+        drop
+        { "oauth_token" "oauth_token_secret" } member? not
+    ] assoc-filter ;
+
+: parse-token ( response data -- token )
+    nip
+    query>assoc
+    [ [ "oauth_token" ] dip at ]
+    [ [ "oauth_token_secret" ] dip at ]
+    [ extract-user-data ]
+    tri
+    [ <token> ] dip >>user-data ;
+
+PRIVATE>
+
+TUPLE: request-token-params < token-params
+{ callback-url initial: "oob" } ;
+
+: <request-token-params> ( -- params )
+    request-token-params new-token-params ;
+
+<PRIVATE
+
+:: <token-request> ( url consumer-token request-token params -- request )
+    url "POST" consumer-token request-token params sign-params
+    url
+    <post-request> ;
+
+: make-request-token-params ( params -- assoc )
+    [ callback-url>> "oauth_callback" set ] make-token-params ;
+
+: <request-token-request> ( url params -- request )
+    [ consumer-token>> f ] [ make-request-token-params ] bi
+    <token-request> ;
+
+PRIVATE>
+
+: obtain-request-token ( url params -- token )
+    <request-token-request> http-request parse-token ;
+
+TUPLE: access-token-params < token-params request-token verifier ;
+
+: <access-token-params> ( -- params )
+    access-token-params new-token-params ;
+
+<PRIVATE
+
+: make-access-token-params ( params -- assoc )
+    [
+        [ request-token>> key>> "oauth_token" set ]
+        [ verifier>> "oauth_verifier" set ]
+        bi
+    ] make-token-params ;
+
+: <access-token-request> ( url params -- request )
+    [ consumer-token>> ]
+    [ request-token>> ]
+    [ make-access-token-params ] tri
+    <token-request> ;
+
+PRIVATE>
+
+: obtain-access-token ( url params -- token )
+    <access-token-request> http-request parse-token ;
+
+SYMBOL: access-token
+
+TUPLE: oauth-request-params < token-params access-token ;
+
+: <oauth-request-params> ( -- params )
+    oauth-request-params new-token-params
+        access-token get >>access-token ;
+
+<PRIVATE
+
+:: signed-oauth-request-params ( request params -- params )
+    request url>>
+    request method>>
+    params consumer-token>>
+    params access-token>>
+    params
+    [
+        access-token>> key>> "oauth_token" set
+        namespace request post-data>> assoc-union! drop
+    ] make-token-params
+    sign-params ;
+
+: build-auth-string ( params -- string )
+    [ [ present url-encode-full ] bi@ "\"" "\"" surround "=" glue ] { } assoc>map
+    ", " join "OAuth realm=\"\", " prepend ;
+
+PRIVATE>
+
+: set-oauth ( request params -- request )
+    dupd signed-oauth-request-params build-auth-string
+    "Authorization" set-header ;