extra/github/github.factor

   1 ! Copyright (C) 2017 Doug Coleman.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs assocs.extras calendar.parser
   4 cli.git combinators combinators.extras combinators.short-circuit
   5 continuations formatting hashtables http.client io.pathnames
   6 json json.http kernel math math.order namespaces.extras
   7 sequences sorting urls ;
   8 IN: github
   9
  10 ! Github API Docs: https://docs.github.com/en/rest
  11 ! Setup: https://github.com/settings/tokens add to ~/.factor-boot-rc `USE: tools.scaffold scaffold-factor-boot-rc`
  12 ! USING: github namespaces ;
  13 ! "erg" github-username set-global
  14 ! "the-generated-token" github-token set-global
  15
  16 SYMBOL: github-username
  17 SYMBOL: github-token
  18
  19 : ?github-api ( str -- str' )
  20     dup "https://api.github.com" head?
  21     [ "https://api.github.com" prepend ] unless ;
  22
  23 : >github-url ( str -- url )
  24     ?github-api >url
  25     github-username required >>username
  26     github-token required >>password ;
  27
  28 : github-get ( url -- json ) >github-url http-get nip ;
  29 : github-get* ( url -- response data ) >github-url http-get* ;
  30 : github-get-success? ( url -- ? ) github-get* drop code>> 204 = ;
  31 : github-get-json ( url -- json ) >github-url http-get-json nip ;
  32 : github-post ( post-data url -- json ) [ ?>json ] [ >github-url ] bi* http-post-json nip ;
  33 : github-put ( post-data url -- json ) [ ?>json ] [ >github-url ] bi* http-put-json nip ;
  34 : github-put-success? ( url -- json ) f swap >github-url http-put* drop code>> 204 = ;
  35 : github-put-payload-success? ( post-data url -- json ) [ ?>json ] [ >github-url ] bi* http-put* drop code>> 204 = ;
  36 : github-patch ( post-data url -- json ) [ ?>json ] [ >github-url ] bi* http-patch-json nip ;
  37 : github-delete ( url -- json ) >github-url http-delete-json nip ;
  38 : github-delete* ( url -- ) >github-url http-delete* 2drop ;
  39
  40 ! type is one of { "orgs" "users" }
  41 : map-github-pages ( base-url params param-string -- seq )
  42     [ 0 [ dup ] ] 3dip '[
  43         1 + _ _ pick suffix _ vsprintf append github-get
  44         dup { [ empty? ] [ "[]" = ] } 1|| [ 2drop f f ] when
  45     ] produce nip concat ; inline
  46
  47 ! type is one of { "orgs" "users" }
  48 : map-github-pages-json ( base-url params param-string -- seq )
  49     [ 0 [ dup ] ] 3dip '[
  50         1 + _ _ pick suffix _ vsprintf append github-get-json
  51         dup empty? [ 2drop f f ] when
  52     ] produce nip concat ; inline
  53
  54 : map-github-pages-100 ( base-url -- seq )
  55     { 100 } "?per_page=%d&page=%d" map-github-pages ;
  56
  57 : map-github-pages-100-json ( base-url -- seq )
  58     { 100 } "?per_page=%d&page=%d" map-github-pages-json ;
  59
  60 : get-user ( user -- json ) "/users/%s" sprintf github-get-json ;
  61 : get-users ( users -- seq ) [ get-user ] map ;
  62
  63 : get-repositories-for-type ( type org/user -- seq )
  64     "/%s/%s/repos" sprintf map-github-pages-100 ;
  65
  66 : get-org-repositories ( org -- seq ) [ "orgs" ] dip get-repositories-for-type ;
  67 : get-user-repositories ( user -- seq ) [ "users" ] dip get-repositories-for-type ;
  68
  69 : github-org-or-user ( org/user -- orgs/users )
  70     get-user "type" of {
  71         { "User" [ "users" ] }
  72         { "Organization" [ "orgs" ] }
  73         [  type>> "Unknown github username type: " prepend throw ]
  74     } case ;
  75
  76 : get-repositories ( org/user -- seq )
  77     [ github-org-or-user ] [ ] bi
  78     "/%s/%s/repos" sprintf map-github-pages-100 ;
  79
  80 : list-repository-languages ( owner repo -- seq )
  81     "/repos/%s/%s/languages" sprintf map-github-pages-100 ;
  82
  83 : list-repository-tags ( owner repo -- seq )
  84     "/repos/%s/%s/tags" sprintf map-github-pages-100 ;
  85
  86 : list-repository-tags-all ( owner repo -- seq )
  87     "/repos/%s/%s/git/refs/tags" sprintf github-get-json ;
  88
  89 : list-repository-branches-matching ( owner repo ref -- seq )
  90     "/repos/%s/%s/git/matching-refs/heads/%s" sprintf github-get-json ;
  91
  92 : list-repository-tags-matching ( owner repo ref -- seq )
  93     "/repos/%s/%s/git/matching-refs/tags/%s" sprintf github-get-json ;
  94
  95 : list-repository-teams ( owner repo -- seq )
  96     "/repos/%s/%s/teams" sprintf github-get-json ;
  97
  98 : list-teams-for-organization ( org -- seq )
  99     "/orgs/%s/teams" sprintf map-github-pages-100-json ;
 100
 101 : list-repository-topics ( owner repo -- seq )
 102     "/repos/%s/%s/topics" sprintf github-get-json ;
 103
 104 : github-file-meta-and-contents ( owner repo path -- meta contents )
 105     "/repos/%s/%s/contents/%s" sprintf github-get
 106     dup "download_url" of http-get nip ;
 107
 108 : github-file-contents ( owner repo path -- contents )
 109     github-file-meta-and-contents nip ;
 110
 111 : github-sha-file-meta-and-contents ( owner repo sha path -- meta/f contents/f )
 112     [
 113         swap
 114         "/repos/%s/%s/contents/%s?ref=%s" sprintf github-get
 115         dup "download_url" of http-get nip
 116     ] [
 117         dup { [ download-failed? ] [ response>> code>> 404 = ] } 1&&
 118         [ 5drop f f ] [ rethrow ] if
 119     ] recover ;
 120
 121 : github-sha-file-contents ( owner repo sha path -- contents )
 122     github-sha-file-meta-and-contents nip ;
 123
 124 : github-sha-files-recursive-for-path ( owner repo sha path/f -- files )
 125     "/repos/%s/%s/git/trees/%s?recursive=1&%s" sprintf github-get-json ;
 126
 127 : github-sha-files-recursive ( owner repo sha -- files )
 128     f github-sha-files-recursive-for-path ;
 129
 130 : github-sha-files-for-path ( owner repo sha path -- files )
 131     swap "/repos/%s/%s/contents/%s?ref=%s" sprintf github-get-json ;
 132
 133 : github-code-search ( query -- seq )
 134     "/search/code?q=%s" sprintf github-get-json ;
 135
 136 : github-factor-code-search ( query -- seq )
 137     "/search/code?q=%s+language:factor" sprintf github-get-json ;
 138
 139 : check-enabled-vulnerability-alerts ( owner repo -- json )
 140     "/repos/%s/%s/vulnerability-alerts" sprintf github-get-json ;
 141
 142 : enable-vulnerability-alerts ( owner repo -- json )
 143     [ f ] 2dip
 144     "/repos/%s/%s/vulnerability-alerts" sprintf github-put ;
 145
 146 : disable-vulnerability-alerts ( owner repo -- json )
 147     "/repos/%s/%s/vulnerability-alerts" sprintf github-delete ;
 148
 149 : get-codes-of-conduct ( -- seq ) "/codes_of_conduct" github-get-json ;
 150 ! key: contributor_covenant|citizen_code_of_conduct
 151 : get-code-of-conduct ( key -- seq ) "/codes_of_conduct/%s" sprintf github-get-json ;
 152
 153 ! H{ { "names" { "programming-language" "factor" "stack" "concatenative" "language" } }
 154 : set-repository-topics ( assoc owner repo -- json )
 155     [ >json ] 2dip "/repos/%s/%s/topics" sprintf github-put ;
 156
 157 : get-forks ( owner repo -- seq )
 158     "/repos/%s/%s/forks" sprintf map-github-pages-100 ;
 159
 160 ! H{ { "organization" "rotcaf" } { "name" "pr-fun" } { "default_branch_only" "true" } }
 161 : create-fork ( json owner repo -- res )
 162     [ >json ] 2dip "/repos/%s/%s/forks" sprintf github-post ;
 163
 164 : list-issues-for-repository ( owner repo -- seq )
 165     "/repos/%s/%s/issues" sprintf map-github-pages-100 ;
 166
 167 ! Pull Requests
 168 : get-pull-requests ( owner repo -- seq )
 169     "/repos/%s/%s/pulls" sprintf map-github-pages-100 ;
 170
 171 : get-pull-request ( owner repo n -- seq )
 172     "/repos/%s/%s/pulls/%d" sprintf github-get-json ;
 173
 174 : get-open-pull-requests ( owner repo -- seq )
 175     "/repos/%s/%s/pulls?state=open" sprintf github-get-json ;
 176
 177 : get-pull-request-files ( owner repo pr-number -- seq )
 178     "/repos/%s/%s/pulls/%d/files" sprintf github-get-json ;
 179
 180 : get-files-from-sha ( owner repo sha files -- seq )
 181     [ "filename" of github-sha-file-meta-and-contents 2array ] with with with zip-with ;
 182
 183 : get-pull-request-files-old-new ( owner repo pr-number -- pr pr-files old new )
 184     [ drop ] [ get-pull-request ] [ get-pull-request-files ] 3tri
 185     [ 2nipd ]
 186     [ [ "base" of "sha" of ] dip get-files-from-sha ]
 187     [ [ "head" of "sha" of ] dip get-files-from-sha ] 4tri ;
 188
 189 ! H{ { "title" "pr2 - updated!" } { "head" "pr2" } { "base" "main" } { "body" "omg pr2 first post" } { "head_repo" "repo-string" } { "issue" 1 } { "draft" "true" } }
 190 : post-pull-request ( assoc owner repo -- res )
 191     [ >json ] 2dip "/repos/%s/%s/pulls" sprintf github-post ;
 192
 193 : update-pull-request ( assoc owner repo n -- res )
 194     [ >json ] 3dip "/repos/%s/%s/pulls/%d" sprintf github-patch ;
 195
 196 : list-commits-pull-request ( owner repo n -- res )
 197     "/repos/%s/%s/pulls/%d/commits" sprintf map-github-pages-100 ;
 198
 199 : list-files-pull-request ( owner repo n -- res )
 200     "/repos/%s/%s/pulls/%d/files" sprintf map-github-pages-100 ;
 201
 202 : pull-request-merged? ( owner repo n -- res )
 203     "/repos/%s/%s/pulls/%d/merge" sprintf github-get-json ;
 204
 205 ! H{ { "commit_title" "oh wow" } { "commit_message" "messaged123" } { "merge_method" "merge|squash|rebase" } { "sha" "0c001" } }
 206 : merge-pull-request ( assoc owner repo n -- res )
 207     [ >json ] 3dip "/repos/%s/%s/pulls/%d/merge" sprintf github-put ;
 208
 209 ! H{ { "expected_head_shastring" "0c001" } }
 210 : update-branch-pull-request ( assoc owner repo n -- res )
 211     [ >json ] 3dip "/repos/%s/%s/pulls/%d/update-branch" sprintf github-put ;
 212
 213 : get-users-page ( page -- seq )
 214     [ "/users" ] dip
 215     '{ 100 _ } "?per_page=%d&page=%d" vsprintf append github-get-json ;
 216
 217 : get-labels ( owner repo -- seq )
 218     "/repos/%s/%s/labels" sprintf map-github-pages-100 ;
 219
 220 : get-label-names ( owner repo -- seq )
 221     get-labels [ "name" of ] map ;
 222
 223 : get-issues-by-label ( owner repo -- seq )
 224     list-issues-for-repository
 225     [ "labels" of [ "name" of ] map ] collect-by-multi ;
 226
 227 : get-issues-for-label ( owner repo label -- seq )
 228     [ get-issues-by-label ] dip of ;
 229
 230 : get-issues-by-all-labels ( owner repo -- seq )
 231     [ get-label-names [ V{ } clone ] H{ } map>assoc ]
 232     [ list-issues-for-repository ] 2bi
 233     [ "labels" of [ "name" of ] map ] collect-by-multi! ;
 234
 235 : get-empty-labels ( owner repo -- seq ) get-issues-by-all-labels sift-values ;
 236 : get-issues-with-no-labels ( owner repo -- seq ) list-issues-for-repository [ "labels" of empty? ] filter ;
 237
 238 : get-branches ( owner repo -- json ) "/repos/%s/%s/branches" sprintf github-get-json ;
 239 : get-branch ( owner repo branch -- json ) "/repos/%s/%s/branches/%s" sprintf github-get-json ;
 240 : post-rename-branch ( owner repo branch new-name -- json )
 241     "new-name" associate -roll
 242     "/repos/%s/%s/branches/%s/rename" sprintf github-post ;
 243
 244 : get-my-issues ( -- json ) "/issues" github-get-json ;
 245 : get-my-org-issues ( org -- json ) "/orgs/%s/issues" sprintf github-get-json ;
 246 ! H{ { "title" "issue 1" } { "body" "dear, i found a bug" } { "assignees" { "erg" "mrjbq7" } } } >json
 247 : create-issue ( json owner repo -- json )
 248     "/repos/%s/%s/issues" sprintf github-post ;
 249 : get-issue ( owner repo n -- json )
 250     "/repos/%s/%s/issues/%d" sprintf github-get-json ;
 251 ! H{ { "title" "issue 1" } { "body" "dear, i found a bug" } { "state" "open|closed" } { "state_reason" "completed|not_planned|reopened|null" } { "assignees" { "erg" "mrjbq7" } } } ! milestone, labels
 252 : update-issue ( json owner repo n -- json )
 253     "/repos/%s/%s/issues/%d" sprintf github-patch ;
 254
 255 ! issue comments
 256 : list-issue-comments ( owner repo -- json )
 257     "/repos/%s/%s/issues/comments" sprintf github-get-json ;
 258 : list-issue-comment-by-id ( owner repo comment-id -- json )
 259     "/repos/%s/%s/issues/comments/%s" sprintf github-get-json ;
 260 ! H{ { "body" "update my stuff" } }
 261 : update-issue-comment-by-id ( json owner repo comment-id -- json )
 262     "/repos/%s/%s/issues/comments/%s" sprintf github-patch ;
 263 : delete-issue-comment-by-id ( owner repo comment-id -- json )
 264     "/repos/%s/%s/issues/comments/%s" sprintf github-delete ;
 265 : list-issue-comments-by-id ( owner repo comment-id -- json )
 266     "/repos/%s/%s/issues/%d/comments" sprintf github-get-json ;
 267 ! H{ { "body" "update my stuff" } }
 268 : create-issue-comment-by-id ( json owner repo issue-number -- json )
 269     "/repos/%s/%s/issues/%d/comments" sprintf github-post ;
 270
 271 ! H{ { "lock_reason" "topic|too heated|resolved|spam" } }
 272 : lock-issue ( json owner repo n -- json )
 273     "/repos/%s/%s/issues/%d/lock" sprintf github-put ;
 274 : unlock-issue ( owner repo n -- json )
 275     "/repos/%s/%s/issues/%d/lock" sprintf github-delete ;
 276 : user-issues ( -- json ) "/user/issues" github-get-json ;
 277
 278 ! stargazers
 279 : list-all-stargazers ( owner repo -- json )
 280     "/repos/%s/%s/stargazers" sprintf map-github-pages-100 ;
 281
 282 : list-my-starred-projects ( -- json ) "/user/starred" map-github-pages-100 ;
 283
 284 : single-repository-starred? ( owner repo -- ? )
 285     "/user/starred/%s/%s" sprintf github-get-success? ;
 286
 287 : star-repository ( owner repo -- )
 288     "/user/starred/%s/%s" sprintf github-put-success? drop ;
 289
 290 : unstar-repository ( owner repo -- )
 291     "/user/starred/%s/%s" sprintf github-delete* ;
 292
 293 : list-repositories-starred-by-user ( user -- json )
 294     "/users/%s/starred" sprintf map-github-pages-100-json ;
 295
 296
 297 : list-organization-members ( org -- json )
 298     "/orgs/%s/members" sprintf map-github-pages-100-json ;
 299
 300 : list-pull-requests-for-repository ( owner repo -- json )
 301     "/repos/%s/%s/pulls" sprintf map-github-pages-100-json ;
 302
 303 : list-repository-collaborators ( owner repo -- json )
 304     "/repos/%s/%s/collaborators" sprintf map-github-pages-100-json ;
 305
 306 : list-gists-for-user ( user -- json )
 307     "/users/%s/gists" sprintf map-github-pages-100-json ;
 308
 309
 310
 311 : list-repositories-for-authenticated-user ( -- json ) "/user/repos" map-github-pages-100-json ;
 312
 313 : find-repos-by-name ( seq quot: ( name -- ? ) -- seq' ) '[ "name" of @ ] filter ; inline
 314 : find-repos-by-visibility ( seq quot: ( name -- ? ) -- seq' ) '[ "visibility" of @ ] filter ; inline
 315 : find-public-repos ( seq -- seq' ) [ "visibility" of "public" = ] filter ; inline
 316 : find-private-repos ( seq -- seq' ) [ "private" of ] filter ; inline
 317
 318 : sort-repos-by-time ( seq name quot: ( obj1 obj2 -- <=> ) -- seq' ) '[ [ _ of rfc3339>timestamp ] bi@ @ ] sort-with ; inline
 319 : sort-repos-by-created-at<=> ( seq -- seq' ) "created_at" [ <=> ] sort-repos-by-time ;
 320 : sort-repos-by-created-at>=< ( seq -- seq' ) "created_at" [ >=< ] sort-repos-by-time ;
 321 : sort-repos-by-pushed-at<=> ( seq -- seq' ) "pushed_at" [ <=> ] sort-repos-by-time ;
 322 : sort-repos-by-pushed-at>=< ( seq -- seq' ) "pushed_at" [ >=< ] sort-repos-by-time ;
 323 : sort-repos-by-updated-at<=> ( seq -- seq' ) "updated_at" [ <=> ] sort-repos-by-time ;
 324 : sort-repos-by-updated-at>=< ( seq -- seq' ) "updated_at" [ >=< ] sort-repos-by-time ;
 325
 326 : sync-github-org-or-user ( directory name -- )
 327     get-repositories [ "ssh_url" of ] map sync-repositories ;
 328
 329 : github-git-uri ( org/user project -- uri ) [ "git@github.com" ] 2dip "/" glue ":" glue ;
 330 : github-ssh-uri ( org/user project -- uri ) [ "https://github.com" ] 2dip 3append-path ;
 331 : github-git-clone-as ( org/user project name -- process ) [ github-git-uri ] dip git-clone-as ;
 332 : github-ssh-clone-as ( org/user project name -- process ) [ github-ssh-uri ] dip git-clone-as ;
 333 : github-git-clone ( org/user project -- process ) dup github-git-clone-as ;
 334 : github-ssh-clone ( org/user project -- process ) dup github-ssh-clone-as ;
 335
 336 : github-http-uri ( org/user project -- uri ) "http://github.com/%s/%s" sprintf ;
 337 : github-https-uri ( org/user project -- uri ) "https://github.com/%s/%s" sprintf ;
 338
 339 : github-mirror-path ( org/user -- path ) "github-factor-pristine" home-path prepend-path ;
 340 : mirror-github-org ( org/user -- )
 341     [ github-mirror-path ] [ ] bi sync-github-org-or-user ;