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