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