extra/mediawiki/api/api.factor

   1 ! Copyright (C) 2021 Giftpflanze.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays accessors assocs assocs.extras calendar
   4 combinators continuations formatting http http.client io
   5 json.reader kernel locals make math math.parser namespaces
   6 oauth1 prettyprint sequences strings system threads ;
   7 IN: mediawiki.api
   8
   9 TUPLE: oauth-login consumer-token consumer-secret access-token
  10 access-secret ;
  11 TUPLE: password-login username password ;
  12
  13 C: <oauth-login> oauth-login
  14 C: <password-login> password-login
  15
  16 SYMBOLS: botflag contact cookies csrf-token endpoint oauth-login
  17 password-login ;
  18
  19 <PRIVATE
  20
  21 SYMBOLS: basetimestamp curtimestamp ;
  22
  23 PRIVATE>
  24
  25 t botflag set-global
  26
  27 <PRIVATE
  28
  29 : prepare ( params -- params' )
  30     [ {
  31         { [ dup t = ] [ drop "true" ] }
  32         { [ dup number? ] [ number>string ] }
  33         { [ dup string? ] [ ] }
  34         { [ dup sequence? ] [
  35             [ {
  36                 { [ dup number? ] [ number>string ] }
  37                 [ ]
  38             } cond ] map "|" join
  39         ] }
  40     } cond ] assoc-map ;
  41
  42 : <api-request> ( params -- request )
  43         {
  44             { "format" "json" }
  45             { "formatversion" 2 }
  46             { "maxlag" 5 }
  47         } swap assoc-union prepare
  48         endpoint get
  49     <post-request>
  50         contact get vm-version vm-git-id 7 head
  51         "%s Factor/%s %s mediawiki.api" sprintf "User-Agent"
  52         set-header ;
  53
  54 : oauth-post ( params -- response data )
  55     oauth-login get
  56         dup consumer-token>>
  57         over consumer-secret>> <token> consumer-token set
  58         dup access-token>>
  59         swap access-secret>> <token> access-token set
  60     <api-request>
  61         <oauth-request-params> set-oauth
  62     http-request ;
  63
  64 : cookie-post* ( params -- assoc )
  65     <api-request>
  66         cookies get >>cookies
  67     http-request [ cookies>> cookies set-global ] dip json> ;
  68
  69 : login-token ( -- token )
  70     {
  71         { "action" "query" }
  72         { "meta" "tokens" }
  73         { "type" "login" }
  74     } cookie-post*
  75     "query" "tokens" "logintoken" [ of ] tri@ ;
  76
  77 : login ( -- cookies )
  78     [
  79         "login" "action" ,,
  80         password-login get dup username>> "lgname" ,,
  81         password>> "lgpassword" ,,
  82         login-token "lgtoken" ,,
  83     ] { } make cookie-post* drop cookies get ;
  84
  85 : cookie-post ( params -- response data )
  86     <api-request>
  87         cookies get [ login ] unless* >>cookies
  88     http-request ;
  89
  90 : anon-post ( params -- response data )
  91     <api-request> http-request ;
  92
  93 : code-200? ( response assoc -- ? )
  94     over code>> dup 200 = dup [ 3nip ] [
  95         -roll "http status code %d" printf
  96         swap header>> [ "=" glue print ] assoc-each
  97         ...
  98         10 minutes sleep
  99     ] if ;
 100
 101 : retry-after? ( response -- ? )
 102     header>> "retry-after" of dup [ dup seconds sleep ] when ;
 103
 104 : nonce-already-used? ( assoc -- ? )
 105     "error" of
 106     [ "code" of "mwoauth-invalid-authorization" = ]
 107     [ "info" of "Nonce already used" swap subseq-start ] bi
 108     and ;
 109
 110 : readonly? ( assoc -- ? )
 111     "error" "code" [ of ] bi@ "readonly" = dup
 112     [ 5 minutes sleep ] when ;
 113
 114 : failed? ( response assoc -- response assoc ? )
 115     2dup 2dup code-200? not
 116     rot retry-after? or
 117     over nonce-already-used? or
 118     swap readonly? or ;
 119
 120 : dispatch-call ( params -- response data )
 121     {
 122         { [ oauth-login get ] [ oauth-post ] }
 123         { [ password-login get ] [ cookie-post ] }
 124         [ anon-post ]
 125     } cond ;
 126
 127 PRIVATE>
 128
 129 : api-call ( params -- assoc )
 130     f f [
 131         failed?
 132     ] [
 133         2drop dup dispatch-call
 134         [ json> ] [ swap print rethrow ] recover
 135         "warnings" "errors" [ over at [ ... ] when* ] bi@
 136     ] do while 2nip ;
 137
 138 <PRIVATE
 139
 140 :: (query) ( params -- obj assoc )
 141     { { "action" "query" } } params assoc-union api-call dup
 142     dup "query" of [ nip ] when*
 143     "siprop" params key? [
 144         params { "prop" "list" "meta" } values-of sift first of
 145     ] unless swap ;
 146
 147 PRIVATE>
 148
 149 :: call-continue ( params quot1: ( params -- obj assoc )
 150 quot2: ( ... -- ... ) -- seq )
 151     f f [
 152         "continue" of dup
 153     ] [
 154         params assoc-union quot1 call
 155         [ quot2 call >alist append ] dip
 156     ] do while drop ; inline
 157
 158 : query ( params -- seq )
 159     [ (query) ] [ ] call-continue ;
 160
 161 :: page-content ( title -- content )
 162     {
 163         { "action" "query" }
 164         { "prop" "revisions" }
 165         { "rvprop" { "content" "timestamp" } }
 166         { "rvlimit" 1 }
 167         { "rvslots" "main" }
 168         { "titles" title }
 169         { "curtimestamp" t }
 170     } api-call
 171     [ "curtimestamp" of curtimestamp set-global ]
 172     [
 173         "query" of "pages" "revisions" [ of first ] bi@
 174         [ "timestamp" of basetimestamp set-global ]
 175         [ "slots" "main" "content" [ of ] tri@ ] bi
 176     ] bi ;
 177
 178 <PRIVATE
 179
 180 : get-csrf-token ( -- csrf-token )
 181     {
 182         { "meta" "tokens" }
 183         { "type" "csrf" }
 184     } query
 185     "csrftoken" of dup csrf-token set-global ;
 186
 187 PRIVATE>
 188
 189 : token-call ( params -- assoc )
 190     [
 191         %%
 192         csrf-token get [ get-csrf-token ] unless* "token" ,,
 193     ] { } make api-call ;
 194
 195 :: edit-page ( title text summary params -- assoc )
 196     [
 197         "edit" "action" ,,
 198         title "title" ,,
 199         summary "summary" ,,
 200         text "text" ,,
 201         curtimestamp get "now" or "starttimestamp" ,,
 202         basetimestamp get "now" or "basetimestamp" ,,
 203     ] { } make
 204     botflag get { { "bot" t } } { } ?
 205     params [ assoc-union ] bi@ token-call ;
 206
 207 :: move-page ( from to reason params -- assoc )
 208     {
 209         { "from" from }
 210         { "to" to }
 211         { "reason" reason }
 212         { "movetalk" t }
 213     } params assoc-union token-call ;
 214
 215 :: email ( target subject text -- assoc )
 216     {
 217         { "action" "emailuser" }
 218         { "target" target }
 219         { "subject" subject }
 220         { "text" text }
 221     } token-call ;