extra/oauth/oauth.factor

   1 ! Copyright (C) 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs base64 calendar checksums.hmac
   4 checksums.sha combinators fry http http.client kernel locals
   5 make math namespaces present random sequences sorting strings
   6 urls urls.encoding urls.private checksums ;
   7 IN: oauth
   8
   9 SYMBOL: consumer-token
  10
  11 TUPLE: token key secret user-data ;
  12
  13 : <token> ( key secret -- token )
  14     token new
  15         swap >>secret
  16         swap >>key ;
  17
  18 <PRIVATE
  19
  20 TUPLE: token-params
  21 consumer-token
  22 timestamp
  23 nonce ;
  24
  25 : new-token-params ( class -- params )
  26     new
  27         consumer-token get >>consumer-token
  28         now timestamp>unix-time >integer >>timestamp
  29         16 random-bytes hex-string >>nonce ; inline
  30
  31 : present-base-url ( url -- string )
  32     [
  33         [ unparse-protocol ]
  34         [ path>> url-encode % ] bi
  35     ] "" make ;
  36
  37 :: signature-base-string ( url request-method params -- string )
  38     [
  39         request-method % "&" %
  40         url present-base-url url-encode-full % "&" %
  41         params assoc>query url-encode-full %
  42         url query>> [ assoc>query "&" prepend url-encode-full % ] when*
  43     ] "" make ;
  44
  45 : hmac-key ( consumer-secret token-secret -- key )
  46     [ url-encode-full ] [ "" or url-encode-full ] bi* "&" glue ;
  47
  48 : make-token-params ( params quot -- assoc )
  49     '[
  50         "1.0" "oauth_version" ,,
  51         "HMAC-SHA1" "oauth_signature_method" ,,
  52
  53         _
  54         [
  55             [ consumer-token>> key>> "oauth_consumer_key" ,, ]
  56             [ timestamp>> "oauth_timestamp" ,, ]
  57             [ nonce>> "oauth_nonce" ,, ]
  58             tri
  59         ] bi
  60     ] H{ } make ; inline
  61
  62 :: sign-params ( url request-method consumer-token request-token params -- signed-params )
  63     params sort-keys :> params
  64     url request-method params signature-base-string :> sbs
  65     consumer-token secret>> request-token dup [ secret>> ] when hmac-key :> key
  66     sbs key sha1 hmac-bytes >base64 >string :> signature
  67     params { "oauth_signature" signature } prefix ;
  68
  69 : extract-user-data ( assoc -- assoc' )
  70     [
  71         drop
  72         { "oauth_token" "oauth_token_secret" } member? not
  73     ] assoc-filter ;
  74
  75 : parse-token ( response data -- token )
  76     nip
  77     query>assoc
  78     [ [ "oauth_token" ] dip at ]
  79     [ [ "oauth_token_secret" ] dip at ]
  80     [ extract-user-data ]
  81     tri
  82     [ <token> ] dip >>user-data ;
  83
  84 PRIVATE>
  85
  86 TUPLE: request-token-params < token-params
  87 { callback-url initial: "oob" } ;
  88
  89 : <request-token-params> ( -- params )
  90     request-token-params new-token-params ;
  91
  92 <PRIVATE
  93
  94 :: <token-request> ( url consumer-token request-token params -- request )
  95     url "POST" consumer-token request-token params sign-params
  96     url
  97     <post-request> ;
  98
  99 : make-request-token-params ( params -- assoc )
 100     [ callback-url>> "oauth_callback" ,, ] make-token-params ;
 101
 102 : <request-token-request> ( url params -- request )
 103     [ consumer-token>> f ] [ make-request-token-params ] bi
 104     <token-request> ;
 105
 106 PRIVATE>
 107
 108 : obtain-request-token ( url params -- token )
 109     <request-token-request> http-request parse-token ;
 110
 111 TUPLE: access-token-params < token-params request-token verifier ;
 112
 113 : <access-token-params> ( -- params )
 114     access-token-params new-token-params ;
 115
 116 <PRIVATE
 117
 118 : make-access-token-params ( params -- assoc )
 119     [
 120         [ request-token>> key>> "oauth_token" ,, ]
 121         [ verifier>> "oauth_verifier" ,, ]
 122         bi
 123     ] make-token-params ;
 124
 125 : <access-token-request> ( url params -- request )
 126     [ consumer-token>> ]
 127     [ request-token>> ]
 128     [ make-access-token-params ] tri
 129     <token-request> ;
 130
 131 PRIVATE>
 132
 133 : obtain-access-token ( url params -- token )
 134     <access-token-request> http-request parse-token ;
 135
 136 SYMBOL: access-token
 137
 138 TUPLE: oauth-request-params < token-params access-token ;
 139
 140 : <oauth-request-params> ( -- params )
 141     oauth-request-params new-token-params
 142         access-token get >>access-token ;
 143
 144 <PRIVATE
 145
 146 :: signed-oauth-request-params ( request params -- params )
 147     request url>>
 148     request method>>
 149     params consumer-token>>
 150     params access-token>>
 151     params
 152     [
 153         access-token>> key>> "oauth_token" ,,
 154         request post-data>> %%
 155     ] make-token-params
 156     sign-params ;
 157
 158 : build-auth-string ( params -- string )
 159     [ [ present url-encode-full ] bi@ "\"" "\"" surround "=" glue ] { } assoc>map
 160     ", " join "OAuth realm=\"\", " prepend ;
 161
 162 PRIVATE>
 163
 164 : set-oauth ( request params -- request )
 165     dupd signed-oauth-request-params build-auth-string
 166     "Authorization" set-header ;