factor/extra/oauth/oauth.factor

! 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 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 ;