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 http http.client kernel make math math.parser
   5 namespaces present random sequences sorting strings
   6 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 ! Checksum all the params but only return the oauth_ params for use in the auth header.
  64 ! See https://github.com/factor/factor/issues/2487
  65 :: sign-params ( url request-method consumer-token request-token params -- oauth-params )
  66     params sort-keys :> params
  67     url request-method params signature-base-string :> sbs
  68     consumer-token secret>> request-token dup [ secret>> ] when hmac-key :> key
  69     sbs key sha1 hmac-bytes >base64 >string :> signature
  70     params { "oauth_signature" signature } prefix
  71     [ drop "oauth_" head? ] assoc-filter ;
  72
  73 : extract-user-data ( assoc -- assoc' )
  74     [
  75         drop
  76         { "oauth_token" "oauth_token_secret" } member? not
  77     ] assoc-filter ;
  78
  79 : parse-token ( response data -- token )
  80     nip
  81     query>assoc
  82     [ [ "oauth_token" ] dip at ]
  83     [ [ "oauth_token_secret" ] dip at ]
  84     [ extract-user-data ]
  85     tri
  86     [ <token> ] dip >>user-data ;
  87
  88 PRIVATE>
  89
  90 TUPLE: request-token-params < token-params
  91 { callback-url initial: "oob" } ;
  92
  93 : <request-token-params> ( -- params )
  94     request-token-params new-token-params ;
  95
  96 <PRIVATE
  97
  98 :: <token-request> ( url consumer-token request-token params -- request )
  99     url "POST" consumer-token request-token params sign-params
 100     url
 101     <post-request> ;
 102
 103 : make-request-token-params ( params -- assoc )
 104     [ callback-url>> "oauth_callback" ,, ] make-token-params ;
 105
 106 : <request-token-request> ( url params -- request )
 107     [ consumer-token>> f ] [ make-request-token-params ] bi
 108     <token-request> ;
 109
 110 PRIVATE>
 111
 112 : obtain-request-token ( url params -- token )
 113     <request-token-request> http-request parse-token ;
 114
 115 TUPLE: access-token-params < token-params request-token verifier ;
 116
 117 : <access-token-params> ( -- params )
 118     access-token-params new-token-params ;
 119
 120 <PRIVATE
 121
 122 : make-access-token-params ( params -- assoc )
 123     [
 124         [ request-token>> key>> "oauth_token" ,, ]
 125         [ verifier>> "oauth_verifier" ,, ]
 126         bi
 127     ] make-token-params ;
 128
 129 : <access-token-request> ( url params -- request )
 130     [ consumer-token>> ]
 131     [ request-token>> ]
 132     [ make-access-token-params ] tri
 133     <token-request> ;
 134
 135 PRIVATE>
 136
 137 : obtain-access-token ( url params -- token )
 138     <access-token-request> http-request parse-token ;
 139
 140 SYMBOL: access-token
 141
 142 TUPLE: oauth-request-params < token-params access-token ;
 143
 144 : <oauth-request-params> ( -- params )
 145     oauth-request-params new-token-params
 146         access-token get >>access-token ;
 147
 148 <PRIVATE
 149
 150 :: signed-oauth-request-params ( request params -- oauth-params )
 151     request url>>
 152     request method>>
 153     params consumer-token>>
 154     params access-token>>
 155     params
 156     [
 157         access-token>> key>> "oauth_token" ,,
 158         request post-data>> %%
 159     ] make-token-params
 160     sign-params ;
 161
 162 : build-auth-string ( oauth-params -- string )
 163     [ [ present url-encode-full ] bi@ "\"" "\"" surround "=" glue ] { } assoc>map
 164     ", " join "OAuth realm=\"\", " prepend ;
 165
 166 PRIVATE>
 167
 168 : set-oauth ( request params -- request )
 169     dupd signed-oauth-request-params build-auth-string
 170     "Authorization" set-header ;