├── .gitignore ├── CHANGES.md ├── Dockerfile ├── LICENSE.md ├── META.github.template ├── Makefile ├── README.md ├── TODO.md ├── appveyor.yml ├── dune-project ├── gist ├── dune ├── gist.ml └── json.ml ├── github-data.opam ├── github-jsoo.opam ├── github-unix.opam ├── github.opam ├── jar ├── create_release.ml ├── dune ├── jar.ml ├── jar_cli.ml ├── jar_cli.mli ├── jar_version.ml ├── list_events.ml ├── list_issues.ml ├── list_releases.ml ├── listen_events.ml ├── search.ml ├── sync_releases.ml └── upload_release.ml ├── js ├── dune ├── github.ml └── github.mli ├── lib ├── dune ├── github_core.ml ├── github_core.mli └── github_s.mli ├── lib_data ├── dune ├── github.atd └── github_json.ml ├── lib_test ├── checks.ml ├── config.ml.in ├── contributors.ml ├── create_hook.ml ├── create_issue.ml ├── create_milestone.ml ├── create_pull.ml ├── create_statuses.ml ├── current_user.ml ├── current_user_orgs.ml ├── delete_all_hooks.ml ├── deploy_keys.ml ├── dune ├── formac.ml ├── get_token.ml ├── index.html ├── issues.ml ├── labels.ml ├── milestones.ml ├── organization_repos.ml ├── organizations.ml ├── parse_events.ml ├── pulls.ml ├── releases.ml ├── repo_info.ml ├── repo_stats.ml ├── rwo.ml ├── tags.ml └── user_type.ml ├── passwd ├── dune ├── passwd.ml └── passwd.mli └── unix ├── dune ├── github.ml ├── github.mli ├── github_cookie_jar.ml └── github_cookie_jar.mli /.gitignore: -------------------------------------------------------------------------------- 1 | *.swp 2 | _build/ 3 | .merlin 4 | *.install 5 | lib_test/config.ml 6 | _opam/ 7 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## Unreleased 2 | - Add ping a repository and org webhook. (@tmcgilchrist #263) 3 | - Handle "Bot" user type (@zoggy #270) 4 | 5 | ## 4.4.1 (2022-01-26) 6 | - Fix older versions of github can be co-installed with github-data (@dra27 #261) 7 | - Fix github transitively depends on jsoo (@tmcgilchrist #262) 8 | 9 | ## 4.4.0 (2021-06-21) 10 | 11 | - Fixes to odoc warnings and cohttp dependencies (@Aaylor #244) 12 | - Support cohttp 4.0. (@tmcgilchrist #257) 13 | - Support for 4.12 and fixing recent compiler warnings (@tmcgilchrist #246 #252 and @emillon #250 #247 #251) 14 | - Add a new package `github-data` which contains just the serialisation logic 15 | without a dependency on the web stack (#248 @emillon) 16 | - Add Github checks API support (#249 @tmcgilchrist) 17 | - Label field missing in branch refs for ghost (@dra27 and @tmcgilchrist #256) 18 | - Get all commits for user/repo (@Stevendeo #245) 19 | 20 | ## 4.3.2 (2020-09-21) 21 | 22 | - Fix authentication on POST/PATCH/PUT requests. (#242 @Aaylor) 23 | - Add support for statistics endpoint. (#240 @tmcgilchrist) 24 | - Add support for listing organization's repository. (#239 @tmcgilchrist) 25 | - Remove the dependency `lambda-term`, which was only used to read password, for 26 | the package `github-unix`. (#238 @emillon) 27 | - Add the field `committer` in the datatype `git_commit`. (#235 @Aaylor) 28 | 29 | ## 4.3.1 (2020-08-18) 30 | 31 | - Fix a bug introduced by #228, by adding a default value when `user_type` is 32 | not defined (#232 @Aaylor) 33 | - Do not print errors on `stderr`. (#234 @emillon) 34 | 35 | ## 4.3.0 (2020-07-20) 36 | 37 | - Remove deprecated authentication method as GitHub has removed 38 | support for it (#230 @Aaylor) 39 | - Reintroduce `user_type` to distinguish organisations and 40 | users (#228 @Aaylor) 41 | 42 | ## 4.2.0 (2019-06-17) 43 | 44 | - Add repository permissions support (#226 @Aaylor) 45 | - Regenerate opam files automatically via dune-project (#227 @avsm) 46 | 47 | ## 4.1.0 (2019-06-03) 48 | 49 | - Add the interface for `/user/orgs` (#222 @Aaylor) 50 | - Switch to dune-release instead of topkg (#224 @avsm) 51 | - Do not use deprecated `Yojson.Safe.json` (#224 @avsm) 52 | - Support lambda-term/zed 2.0.0 interfaces (#224 @avsm) 53 | - Use wrapped `js_of_ocaml` 3.4.0 interfaces (@avsm) 54 | 55 | ## 4.0.0 (2018-12-11) 56 | 57 | - Port to latest Atd 2.0.0 interfaces (#218 by @mjambon and @avsm) 58 | - Port build system to Dune (@avsm) 59 | - Properly expose the GitHub JavaScript library and fix dependencies (#216 by @samoht) 60 | - Add `pull.merge_commit_sha` (#217 from @AltGr) 61 | - Convert local opam files to the 2.0 format. (@avsm) 62 | 63 | ## 3.1.0 (2018-02-14) 64 | 65 | - Make contributor stats author field nullable (#211, @rvantonder) 66 | - Support OCaml 4.06 by enabling `-safe-string` compatibility (#212, @jpdeplaix) 67 | - Add support for repository issue search (#196, @avsm and @samoht) 68 | - TLS isn't a hard dependency of githug (#208, @rgrinberg) 69 | 70 | ## 3.0.1 (2017-08-01): 71 | * Update to work with latest cohttp (#205 from @rgrinberg) 72 | * Fix atdgen JSON codec generation bug in 3.0.0 (#205) 73 | * Remove deprecated Hook module (#206) 74 | 75 | ## 3.0.0 (2017-07-03): 76 | 77 | Port to Jbuilder (#202 by @rgrinberg @dsheets @samoht). This 78 | splits up the `opam` packages into three separate ones: 79 | 80 | - `github`: the `github_s`, `github_core`, `github_j` and `github_t` modules. 81 | - `github-unix`: the `Github` and `Github_cookie_jar` modules. 82 | - `github-jsoo`: the js_of_ocaml `Github_js` module. 83 | 84 | Tools that depended on github-unix previously will now need to 85 | adjust their `opam` files to depend on the `github-[unix|jsoo]` 86 | packages, and should also to rename `github.unix` to `github-unix` 87 | and `github.js` to `github-jsoo`. However, transitional packages 88 | are available for the older findlib names, so you only need to 89 | immediately rename your `opam` files for the moment. 90 | 91 | * Minimum supported OCaml version is now 4.03.0 or higher. 92 | 93 | ## 2.3.0 (2017-04-13): 94 | * Changes marked with ! are type changes 95 | * ! repo_issue_event has changed the actor type to a linked_user option 96 | since GitHub sometimes returns a null response. 97 | * Fix various test cases that were not compiling due to API changes. 98 | * Add Issue.timeline_events 99 | * Add Organization.Hook 100 | * Expose Hook as Repo.Hook and deprecate Hook 101 | * Add Repo.Hook.parse_event_metadata 102 | * Add an optional `media_type` argument to API.get and API.get_stream 103 | 104 | ## 2.2.0 (2016-12-10): 105 | * Add Repo.get_ref (#175 from @samoht) 106 | * Add Endpoint.Version.t 107 | * Add Stream.since 108 | * Add Stream.version 109 | * Add Monad.catch 110 | * Add Monad.fail 111 | 112 | ## 2.1.0 (2016-11-03): 113 | * Changes marked with ! are type changes 114 | * ! push_event_hook_head_commit field added 115 | 116 | ## 2.0.3 (2016-09-30): 117 | * Changes marked with ! are type changes 118 | * ! repo_issue_event_label and repo_issues_event_label have changed type 119 | from label option to base_label option as the GitHub APIs for Issue 120 | Events and Issue Labels are not consistent with the inclusion of the 121 | url field 122 | * base_label type added (label without the url field) 123 | 124 | ## 2.0.2 (2016-09-26): 125 | * Changes marked with ! are type changes 126 | * ! Issue.remove_label now returns a label list Response.t Monad.t like 127 | the other issue label modification functions because GitHub does not 128 | treat this DELETE endpoint like others and return 204 No Content. The 129 | GitHub docs are wrong on this point (a support ticket has been filed 130 | as they have now moved their developer API docs into a closed source 131 | repo). Because any previous user of the API would have immediately 132 | encountered this exception, this is a patch release. 133 | 134 | ## 2.0.1 (2016-09-23): 135 | * Changes marked with ! are type changes 136 | * ! web_hook_config_content_type field is now optional because GitHub 137 | does not appear to byte-wise validate the field and some web hook 138 | users (e.g. CircleCI) set a `content-type` field rather than a 139 | `content_type` field. 140 | 141 | ## 2.0.0 (2016-09-21): 142 | * Changes marked with ! are type changes 143 | * ! Fix Event.for_repo_issues and rename to Issue.events_for_repo 144 | (#107 from @yallop) 145 | * update_issue type added 146 | * ! Change Issue.update to accept update_issue rather than new_issue 147 | This allows users to change issue state (open/close). 148 | * ! event_type now has Repository constructor 149 | * ! event_type now has All constructor 150 | * ! event_type now has Unknown fall-back constructor 151 | * ! event_constr now has Repository constructor 152 | * ! scope variant now has Unknown fall-back constructor 153 | * ! issue_sort variant now has Unknown fall-back constructor 154 | * ! team_permission variant now has Unknown fall-back constructor 155 | * ! wiki_page_action variant now has Unknown fall-back constructor 156 | * ! issue_comment_action variant now has Edited constructor 157 | * ! issue_comment_action variant now has Deleted constructor 158 | * ! issue_comment_action variant now has Unknown fall-back constructor 159 | * ! issues_action variant now has Edited constructor 160 | * ! issues_action variant now has Unknown fall-back constructor 161 | * ! member_action variant now has Unknown fall-back constructor 162 | * ! page_build_status variant now has Unknown fall-back constructor 163 | * ! pull_request_action variant now has Edited constructor 164 | * ! pull_request_action variant now has Unknown fall-back constructor 165 | * ! pull_request_review_comment_action variant now has Edited constructor 166 | * ! pull_request_review_comment_action variant now has Deleted constructor 167 | * ! pull_request_review_comment_action variant now has Unknown fall-back 168 | constructor 169 | * ! release_action variant now has Unknown fall-back constructor 170 | * ! watch_action variant now has Unknown fall-back constructor 171 | * ! status_state variant now has Unknown fall-back constructor 172 | * ! update_pull_base field added (PR target branch is now updatable) 173 | * ! URI.repo_issues was removed 174 | * ! URI.repo_issue was removed 175 | * ! URI.repo_pulls was removed 176 | * ! URI.repo_milestones was removed 177 | * ! URI.repo_contributors_stats was removed 178 | * ! URI.issue_comments was removed 179 | * ! URI.issue_comment was removed 180 | * ! URI.milestone was removed 181 | * ! Issue.comments signature changed 182 | * Add Labels API support (#146 from @dave-tucker) 183 | * Add Collaborators API support 184 | * Add Emojis API support 185 | * Make `tls` the default recommended dependency instead of OpenSSL 186 | * Require atdgen >= 1.10.0 for support 187 | * Add HTTP redirect support (Response.redirect(s) and Response.final_resource) 188 | * Improve GitHub error reporting (#151) 189 | * Add Organization.user_orgs (#130 from @yallop) 190 | * Add Hook.parse_event 191 | * Add event_hook_constr type for the web hook event variants 192 | * Add Repo.create 193 | * Add Repo.delete 194 | * Add Stream.fold 195 | * Add Issue.get 196 | * Add Status.get 197 | * Add Issue.comments_for_repo 198 | * Add Issue.get_comment 199 | * Add Issue.update_comment 200 | * Add Issue.delete_comment 201 | * Add repository_event 202 | * Add type Filter.issue_comment_sort 203 | * Add Issue.events 204 | * push_event_before field added 205 | 206 | ## 1.1.0 (2016-06-20): 207 | * Add new_status_context and status_context fields (#88) 208 | * Add setting the jar cookie by the `GH_COOKIE` env var (#100 by @rgrinberg) 209 | * Remove camlp4 as a build time dependency (#99, #104, #106 by @rgrinberg) 210 | * Add Windows tests via Appveyor (#98) 211 | * Add jar 'local' subcommand for printing local cookies (#111 by @rgrinberg) 212 | * Add Repo.contributor_stats for contributor statistics (#114 by @sevenEng) 213 | * Add stats_contributor type (#114 by @sevenEng) 214 | * Add stats_contributors type (#114 by @sevenEng) 215 | * Add contribution_week type 216 | * Fix Repo.get_tags_and_times exception when repository has no tags (#113) 217 | * Change Github_core.Make to accept an Env module making the library 218 | Mirage compatible by moving a Unix.getenv invocation into a parameter (#93) 219 | * Add contributor and contributors types (#112) 220 | * Add Repo.contributors to list contributors to a repository (#112) 221 | * Register automatically a Message exception printer (#116) 222 | * Fix `git jar` help strings to match the command reality. 223 | * Improve `git jar create --help` manual page. 224 | * Add `git-gist create [--public] --descr ` to 225 | upload new gists. 226 | 227 | ## 1.0.0 (2015-06-01): 228 | * Changes marked with ! are type changes (not including field additions) 229 | * ! Monad.bind now accepts a function first and then a Monad.t 230 | * ! API.{get,post,delete,patch,put} now take optional fail_handlers 231 | * ! API.{get,post,delete,patch,put} now take optional rate classification 232 | * ! API.{get,post,delete,patch,put} now return 'a Response.t Monad.t 233 | * ! URI.authorize now requires ~state argument to protect against CSRF. 234 | * ! URI.repo_issue ~issue_number argument was renamed to ~num 235 | * ! URI.issue_comments ~issue_number argument was renamed to ~num 236 | * ! URI.issue_comment ~commit_id argument was renamed to ~num 237 | * ! Scope.scope_of_string was renamed Scope.of_string 238 | * ! Scope.string_of_scope was renamed Scope.to_string 239 | * ! Scope.scopes_of_string was renamed Scope.list_of_string 240 | * ! Scope.list_of_string returns a scope list option for unparseable scopes 241 | * ! Scope.string_of_scopes was renamed Scope.list_to_string 242 | * ! Token.{create,get_all,get,delete} return _ authorization Response.t Monad.t 243 | * ! Token.{create,get_all,get,delete} now have additional ?otp:string argument 244 | * ! Token.create now has additional ?fingerprint:string argument 245 | * ! Token.get now returns auth option authorization Response.t Monad.t 246 | * ! Token.{get,delete} ~num argument was renamed to ~id and changed to int64 247 | * ! User.current_info ~token argument was made optional ?token 248 | * ! User.current_info now returns user_info Response.t Monad.t 249 | * ! User.info ~login argument was renamed to ~user 250 | * ! User.info now returns user_info Response.t Monad.t 251 | * ! User.repos is now User.repositories 252 | * ! User.repositories now accepts optional ?token and does not accept ?page 253 | * ! Pull.for_repo does not accept ?page and now returns pull Stream.t 254 | * ! Pull.list_commits was renamed Pull.commits and now returns commit Stream.t 255 | * ! Pull.list_files was renamed Pull.files and now returns file Stream.t 256 | * ! Pull.get now returns pull Response.t Monad.t 257 | * ! Pull.create now returns pull Response.t Monad.t 258 | * ! Pull.create_from_issue now returns pull Response.t Monad.t 259 | * ! Pull.update now returns pull Response.t Monad.t 260 | * ! Pull.is_merged now returns bool Response.t Monad.t 261 | * ! Pull.merge now returns merge Response.t Monad.t 262 | * ! Milestone.get now returns milestone Response.t Monad.t 263 | * ! Milestone.create now returns milestone Response.t Monad.t 264 | * ! Milestone.update now returns milestone Response.t Monad.t 265 | * ! Milestone.delete now returns unit Response.t Monad.t 266 | * ! Milestone.for_repo does not accept ?page 267 | * ! Milestone.for_repo now returns milestone Stream.t 268 | * ! Release.get now returns release Response.t Monad.t 269 | * ! Release.get ~num argument was renamed to ~id and changed to int64 270 | * ! Release.create now returns release Response.t Monad.t 271 | * ! Release.update now returns release Response.t Monad.t 272 | * ! Release.update ~num argument was renamed to ~id and changed to int64 273 | * ! Release.delete now returns unit Response.t Monad.t 274 | * ! Release.delete ~num argument was renamed to ~id and changed to int64 275 | * ! Release.upload_asset now returns unit Response.t Monad.t 276 | * ! Release.upload_asset ~id argument was changed to int64 277 | * ! Release.for_repo now returns release Stream.t 278 | * ! Deploy_key.get now returns deploy_key Response.t Monad.t 279 | * ! Deploy_key.get ~num argument was renamed to ~id and changed to int64 280 | * ! Deploy_key.create now returns deploy_key Response.t Monad.t 281 | * ! Deploy_key.delete now returns unit Response.t Monad.t 282 | * ! Deploy_key.delete ~num argument was renamed to ~id and changed to int64 283 | * ! Deploy_key.for_repo now returns deploy_key Stream.t 284 | * ! Issue.create now returns issue Response.t Monad.t 285 | * ! Issue.update now returns issue Response.t Monad.t 286 | * ! Issue.create_comment now returns issue_comment Response.t Monad.t 287 | * ! Issue.for_repo does not accept ?page and now returns issue Stream.t 288 | * ! Issue.update ~issue_number argument was renamed to ~num 289 | * ! Issue.comments ~issue_number argument was renamed to ~num 290 | * ! Issue.create_comment ~issue_number argument was renamed to ~num 291 | * ! Issue.comments now returns issue_comment Stream.t 292 | * ! Status.for_sha was renamed Status.for_ref and now returns status Stream.t 293 | * ! Status.for_ref ~sha argument was renamed to ~git_ref 294 | * ! Status.create now returns status Response.t Monad.t 295 | * ! Hook.for_repo now returns hook Stream.t 296 | * ! Hook.get now returns hook Response.t Monad.t 297 | * ! Hook.get ~num argument was renamed to ~id and changed to int64 298 | * ! Hook.create now returns hook Response.t Monad.t 299 | * ! Hook.update now returns hook Response.t Monad.t 300 | * ! Hook.update ~num argument was renamed to ~id and changed to int64 301 | * ! Hook.delete now returns unit Response.t Monad.t 302 | * ! Hook.delete ~num argument was renamed to ~id and changed to int64 303 | * ! Hook.test now returns unit Response.t Monad.t 304 | * ! Hook.test ~num argument was renamed to ~id and changed to int64 305 | * ! Repo.tags now returns repo_tag Stream.t 306 | * ! Repo.branches now returns repo_branch Stream.t 307 | * ! Repo.refs now returns git_ref Stream.t 308 | * ! Tag.get_tags_and_times was renamed Repo.get_tags_and_times 309 | * ! Repo.get_tags_and_times now returns (string * string) Stream.t 310 | * ! Tag.tag was renamed Repo.get_tag 311 | * ! Repo.info now returns repository Response.t Monad.t 312 | * ! Repo.fork now returns repository Response.t Monad.t 313 | * ! Repo.get_tag now returns tag Response.t Monad.t 314 | * ! Repo.commit was renamed Repo.get_commit and returns commit Response.t Monad.t 315 | * ! Gist.list_users was renamed Gist.for_user and now returns gist Stream.t 316 | * ! Gist.list was renamed Gist.all and now returns gist Stream.t 317 | * ! Gist.list_all_public was renamed Gist.all_public and now returns gist Stream.t 318 | * ! Gist.list_starred was renamed Gist.starred 319 | * ! Gist.starred ~token argument was made optional ?token 320 | * ! Gist.starred now returns gist Stream.t 321 | * ! Gist.get ~id argument is now int64 322 | * ! Gist.get now returns gist Response.t Monad.t 323 | * ! Gist.create ~token argument was made optional ?token 324 | * ! Gist.create ~contents argument was renamed to ~gist 325 | * ! Gist.create now returns gist Response.t Monad.t 326 | * ! Gist.edit was renamed Gist.update 327 | * ! Gist.update signature now has s/~token/?token/ s/~contents/~gist/ 328 | * ! Gist.update now returns gist Response.t Monad.t 329 | * ! Gist.update ~id argument is now int64 330 | * ! Gist.commits ~id argument is now int64 331 | * ! Gist.commits now returns gist_commit Stream.t 332 | * ! Gist.star ~token argument was made optional ?token 333 | * ! Gist.star ~id argument is now int64 334 | * ! Gist.star now returns unit Response.t Monad.t 335 | * ! Gist.unstar ~token argument was made optional ?token 336 | * ! Gist.unstar ~id argument is now int64 337 | * ! Gist.unstar now returns unit Response.t Monad.t 338 | * ! Gist.fork ~token argument was made optional ?token 339 | * ! Gist.fork ~id argument is now int64 340 | * ! Gist.fork now returns gist Response.t Monad.t 341 | * ! Gist.list_forks was renamed Gist.forks and now returns gist_fork Stream.t 342 | * ! Gist.forks ~id argument is now int64 343 | * ! Gist.delete ~token argument was made optional ?token 344 | * ! Gist.delete ~id argument is now int64 345 | * ! Gist.delete now returns unit Response.t Monad.t 346 | * ! Organization.teams now returns team Stream.t 347 | * ! Team.repos is now Team.repositories 348 | * ! Team.repositories now returns repository Stream.t 349 | * ! Team.repositories ~num argument was renamed to ~id and is now int64 350 | * ! Team.info now returns team_info Response.t Monad.t 351 | * ! Team.info ~num argument was renamed to ~id and is now int64 352 | * ! Git_obj.obj_type_to_string was renamed Git_obj.type_to_string 353 | * ! user:email scope constructor UserEmail has been renamed User_email 354 | * ! user:follow scope constructor UserFollow has been renamed User_follow 355 | * ! scope constructor `Admin_org_hook added 356 | * ! org_id, user_id, organization_id are now int64 357 | * ! team_id, team_info_id, team_add_info_id are now int64 358 | * ! auth_id is now int64 359 | * ! repo type has been renamed repository 360 | * ! repos type has been renamed repositories 361 | * ! repository_forks field renamed to repository_forks_count 362 | * ! repository_watchers field renamed to repository_stargazers_count 363 | * ! repository_open_issues field renamed to repository_open_issues_count 364 | * ! repository_master_branch field renamed to repository_default_branch 365 | * ! repository_description is now optional 366 | * ! repository_id is now int64 367 | * ! comment_id is now int64 368 | * ! release_name is now optional 369 | * ! release_body is now optional 370 | * ! release_id is now int64 371 | * ! new_release_name is now optional 372 | * ! new_release_body is now optional 373 | * ! branch_user is now optional 374 | * ! user_info_ty field removed in favor of specific user and organization types 375 | * ! user_type type has been removed 376 | * ! org_gravatar_id field and all derived fields (e.g. user_gravatar_id) removed 377 | * ! team_info_permission is now a variant type instead of a string 378 | * ! team_info_organization is now an org rather than a user 379 | * ! event_org field is now an org option rather than a user 380 | * ! event_id is now int64 381 | * ! web_hook_config_insecure_ssl is now a bool rather than a string 382 | * ! hook_config is now a hook_config rather than a web_hook_config 383 | * ! hook_id is now int64 384 | * ! new_hook_config is now a hook_config rather than a web_hook_config 385 | * ! update_hook_config is now a hook_config rather than a web_hook_config 386 | * ! deploy_key_id is now int64 387 | * ! status_id is now int64 388 | * ! change_statusdeletions field renamed to change_status_deletions 389 | * ! change_statusadditions field renamed to change_status_additions 390 | * ! change_statustotal field renamed to change_status_total 391 | * ! gist_history type has been renamed gist_commit 392 | * ! gist_historyurl field renamed to gist_commit_url 393 | * ! gist_historyversion field renamed to gist_commit_version 394 | * ! gist_historyuser field renamed to gist_commit_user 395 | * ! gist_historychange_status field renamed to gist_commit_change_status 396 | * ! gist_historycommitted_at field renamed to gist_commit_commited_at 397 | * ! gist_history_list type has been renamed gist_commits 398 | * ! gist_create_content type has been renamed new_gist_content (+ fields) 399 | * ! gist_create_contents type has been renamed new_gist_contents 400 | * ! gist_create type has been renamed new_gist (+ fields) 401 | * ! gist_edit type has been renamed update_gist_file 402 | * ! gist_edit_content field renamed to update_gist_file_content 403 | * ! gist_edit_filename field renamed to update_gist_file_name 404 | * ! gist_edits type has been renamed update_gist (+ fields) 405 | * ! gist_fork_id is now int64 406 | * Atdgen >=1.5.0 and Yojson >=1.2.0 are now required for tag_field support 407 | * Cohttp >=0.17.0 is now required for Link header support 408 | * Monad.map, Monad.(>|=), and Monad.embed : 'a Lwt.t -> 'a Monad.t added 409 | * Github.Response module added for metadata about responses 410 | * Monad.(>>~) added to bind and project a Response.t value 411 | * Add Stream module and API.get_stream function for paginated responses (#46) 412 | * `git-jar save` removed after Authorizations API response changes of 2015-04-20 413 | * `git-jar make` now requires a cookie name and defaults to that for token note 414 | * `git-jar revoke` now accepts either a cookie name or a token ID 415 | * Fix git-jar token file permissions security vulnerability 416 | * git-jar now supports 2FA (#38) 417 | * Github.authorization type added 418 | * Github.rate type added for classifying requests into rate limiting regime 419 | * Github.handler type added 420 | * Add API.code_handler to make creating fail_handlers easier 421 | * Github.Message exception added and raised when GitHub returns an API error 422 | * Add API.string_of_message for human consumption of structured errors 423 | * Add API.get_rate to retrieve possibly cached rate-limit information 424 | * Add API.get_rate_limit to retrieve the possibly cached query quota 425 | * Add API.get_rate_remaining to retrieve the possibly cached query quota remaining 426 | * Add API.get_rate_reset to retrieve the possibly cached quota expiry 427 | * Add Rate_limit module to perform explicit rate limit requests 428 | * Add Scope.max which contains a minimal set of scopes for maximum privilege 429 | * Add Repo.fork to create fork of a repository to the present user or given org 430 | * Add Repo.forks to list the forks of a given repository 431 | * Add Search module to access GitHub's search API 432 | * Filter.forks_sort type added 433 | * Add Event module with a variety of event sources 434 | * A new jar command, git-list-events, has been added to print events for a repo 435 | * A new test binary, parse_events, has been added which downloads and 436 | parses archive event data 437 | * Fixed bug in Issue.for_repo preventing listing of issues without 438 | milestone (#49,#53 Michael Grünewald) 439 | * A new jar command, git-list-issues, has been added to print issues for a repo 440 | * A new jar command, git-search, has been added to search GitHub 441 | * Add Gist manipulation command line tool (#48) 442 | * Filter.state now includes `All constructor (#59,#62 Michael Grünewald) 443 | * pull_ref type added from which pull now inherits 444 | * issue_pull_request optional field of pull_ref type added 445 | * Issue.is_issue and Issue.is_pull added to distinguish issues from PRs 446 | * organization type added 447 | * user and organization now inherit from org 448 | * user_info_updated_at field added 449 | * user_info_html_url field added 450 | * issue_created_at, issue_updated_at, issue_closed_at added (#50,#51 451 | from Michael Grünewald) 452 | * repository_subscribers_count field added (the new "watchers") 453 | * repository_language field added 454 | * repository_has_pages field added 455 | * comment type added 456 | * issue_comment_html_url field added 457 | * commit_comment type added 458 | * commit_comment_event type added 459 | * ref type added 460 | * create_event type added 461 | * delete_event type added 462 | * fork_event type added 463 | * wiki_page_action type added 464 | * wiki_page type added 465 | * gollum_event added 466 | * issue_comment_action type added 467 | * issue_comment_event type added 468 | * issues_action type added 469 | * issues_event type added 470 | * member_action type added 471 | * member_event type added 472 | * page_build_error type added 473 | * page_build_status type added 474 | * page_build type added 475 | * page_build_event type added 476 | * pull_request_action type added 477 | * pull_reqest_event type added 478 | * pull_request_review_comment_action type added 479 | * pull_request_review_comment type added 480 | * pull_request_review_comment_event type added 481 | * push_event_author type added 482 | * push_event_commit type added 483 | * push_event type added 484 | * release_action type added 485 | * release_event type added 486 | * status_branch_commit type added 487 | * status_branch type added 488 | * status_event type added 489 | * team_add_info type added 490 | * team_add_event type added 491 | * watch_action type added 492 | * watch_event type added 493 | * event_constr type added 494 | * event_payload field added 495 | * events type added 496 | * hook_config type added 497 | 498 | ## 0.9.4 (2014-12-18): 499 | * Add bindings for organisation teams and repositories (#45). 500 | * Use `Bytes` instead of `String` for future `safe-string` support. 501 | * Use the Cohttp 0.14.0 API in the test cases and make them optional 502 | (activate with `--enable-tests` during configure). 503 | * Add a `--json` option to `git-list-releases` so that it can emit 504 | the release information in JSON rather than Markdown. 505 | 506 | ## 0.9.3 (2014-11-28): 507 | * Add `repo_branches` and `branches` query functions (#44 from Jeff Hammerbacher). 508 | * Improve `opam` 1.2 metadata. 509 | 510 | ## 0.9.2 (2014-11-09): 511 | * Better log error messages (#39). 512 | * Tweak Makefile to build JavaScript version by default if `js_of_ocaml` is installed. 513 | 514 | ## 0.9.1 (2014-11-04): 515 | * Mark `published_at` and `created_at` fields in Releases to be optional, 516 | as they may not be set in the case of draft tags. 517 | 518 | ## 0.9.0 (2014-11-02): 519 | * Add `Jar_cli` module for use by applications that use the Git Jar (#34). 520 | * Add bindings to the Gist APIs for storing text fragments (#36). 521 | * Add a JavaScript port, using Cohttp and js_of_ocaml (#36). 522 | * Build `ocamldoc` HTML documentation by default. 523 | 524 | ## 0.8.6 (2014-08-10): 525 | * Fix `pull_action_type` `synchronize` tag typo (#33 from Philipp Gesang). 526 | * Add a `git create-release` to create a GitHub release, including binary assets 527 | (#32 from Markus Mottl). 528 | 529 | ## 0.8.5 (2014-05-08): 530 | * The `master_branch` field in the `repo` is actually optional, to fix the schema. 531 | 532 | ## 0.8.4 (2014-04-26): 533 | * Add `git list-releases` to list releases in sorted Markdown format. 534 | 535 | ## 0.8.3 (2014-04-13): 536 | * Add `git sync-releases` to copy release metadata between GitHub repos. 537 | * Add `git upload-release` to upload a binary file to a GitHub release tag. 538 | 539 | ## 0.8.2 (2014-04-01): 540 | * Remove use of `Re_str` to add POSIX thread safety. 541 | * Add deployment key support in the `Deploy_key` module. 542 | 543 | ## 0.8.1 (2014-03-07): 544 | * Sync to latest GitHub scopes API. 545 | 546 | ## 0.8.0 (2014-03-02): 547 | * Port to cohttp.0.10.x interfaces. 548 | * Make the `note` field in oAuth token creation mandatory to reflect GitHub API. 549 | * Pull requests are now allowed to have `null` bodys (#31). 550 | 551 | ## 0.7.1 (2014-02-28): 552 | * Log response bodies in the event of an API parsing failure. (#29) 553 | * Expose `log_active` as a reference so it can be used from the toplevel. (#30) 554 | * Add `Github.URI.pull_raw_diff` to point to the location of a pull request diff. 555 | 556 | ## 0.7.0 (2014-01-03): 557 | * Add a User.repos call to list a users repositories. 558 | * Change repo type such that the field 'pushed_at' is now an option type. 559 | * Accept optional page argument in Pull, Milestone, and Issue. 560 | * Add `UserEmail`, `UserFollow` and `Notifications` scopes. 561 | * Add `Releases` module to handle the release management addition to GitHub. 562 | * Add `GITHUB_DEBUG` environment variable to make debugging output optional. 563 | * Regenerate build files with OASIS 0.4.1. 564 | * OCamldoc improvements for the `GitHub` module. 565 | 566 | ## 0.6.1 (2013-06-21): 567 | * Abstract `Github_cookie_jar.t` and add `Github_cookie_jar.jar_path` accessor. 568 | 569 | ## 0.6.0 (2013-05-24): 570 | * Update to the Cohttp-0.9.8 interface. 571 | 572 | ## 0.5.0 (2013-05-10): 573 | * Force `-j-std` to ATDgen to always use standards-compliant JSON (#11). 574 | * Rename `Github.Issues` to `Github.Issue` to parallel other submodules. 575 | * Rename `Github.Issue.edit` to `Github.Issue.update` to parallel other CRUD interfaces. 576 | * Reorder named parameters to raw API submodule functions. 577 | * Add Pull Request API. 578 | * Add Hook API (generic "web" hooks only). 579 | * Add Statuses API. 580 | * Add structured semantic errors. 581 | * Nows sends partially configurable (via `API.set_user_agent`) User-Agent string. 582 | * Add `API.set_token` to bind an access token for subsequent requests. 583 | * Declare ocaml-re dependency. 584 | * Add anonymous bind operator (>>) to `Github.Monad`. 585 | * Add `Github.Token.delete` for revoking GitHub authorization tokens. 586 | * Add `Github_cookie_jar.delete` for deleting local token cookies. 587 | * Add `revoke` command to git-jar. 588 | * Support GitHub cookie jar names with slashes in. 589 | * Change the signature of `Github_cookie_jar.init` from `... -> unit` to `... -> unit Lwt.t`. 590 | 591 | ## 0.4.3 (2013-01-14): 592 | * Add filters and sort order parameters for `Issues` and `Milestones` for a repository. 593 | 594 | ## 0.4.2 (2012-12-29): 595 | * Add a `redirect_uri` option to `URI.authorize`, to permit the redirection URL to be parameterizable. 596 | * Add `User.current_info` and `User.info` to retrieve information about the logged in user, or a public one. 597 | * Add `Issues.edit` to patch an existing issue. 598 | * Correct the type of `Issues.milestone` to be an integer. 599 | * `Issues.labels` is now a `string list`, instead of a `string list option` (with the empty list denoting `None`). 600 | 601 | ## 0.4.1 (2012-12-27): 602 | * Add `Github.Issues.comments` to retrieve issue comments, and an `issue_comment` 603 | type in the ATD specification for the returned value. 604 | * Add `Github.Issues.create_comment` to add a new issue comment. 605 | * Expose the `milestone` field for an issue. 606 | * Create a default `lib_test/config.ml` if one doesnt exist (from the template 607 | in `lib_test/config.ml.in`. 608 | 609 | ## 0.4.0 (2012-12-25): 610 | * Add a `git-jar` command which provides a convenient command-line interface 611 | to list, create and save tokens. 612 | * Add a `github.unix` subpackage which provides a `Github_cookie_jar` module 613 | which saves tokens in `~/.github` for other applications to query if 614 | they use the Github API. 615 | * Complete the auth API, and rename functions slightly for consistency. We now 616 | have `Token.get_all` and `Token.get` to retrieve auth information, and 617 | `Token.create` for constructing them. The API also includes support for adding 618 | notes and URLs, which are stored on the Github side. 619 | 620 | ## 0.3.3 (2012-12-18): 621 | * Add `Repo.info` to retrieve repository metadata. 622 | 623 | ## 0.3.2 (2012-12-14): 624 | * Add ATD descriptions for commits, tags, author info, and repo tags. 625 | * Add API calls to retrieve tags, dates and refs. 626 | 627 | ## 0.3.1 (2012-10-14): 628 | * Support PREFIX during build for installation prefix. 629 | * Adapt to uri-1.3.3 interface (which now supports multi-value 630 | queries, as per the RFC). 631 | 632 | ## 0.3.0 (2012-09-11): 633 | * Initial public release. 634 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam 2 | RUN opam pin add -n github --dev 3 | RUN opam depext -ui github 4 | RUN opam install -j 2 -y -v github 5 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Permission to use, copy, modify, and distribute this software for any 2 | purpose with or without fee is hereby granted, provided that the above 3 | copyright notice and this permission notice appear in all copies. 4 | 5 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 6 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 7 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 8 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 9 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 10 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 11 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 12 | -------------------------------------------------------------------------------- /META.github.template: -------------------------------------------------------------------------------- 1 | # JBUILDER_GEN 2 | 3 | package "js" ( 4 | description = "Deprecated. Use github-jsoo directly" 5 | requires = "github-jsoo" 6 | ) 7 | 8 | package "unix" ( 9 | description = "Deprecated. Use github-unix directly" 10 | requires = "github-unix" 11 | ) -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | .PHONY: build clean test 3 | 4 | build: 5 | dune build @install @DEFAULT 6 | 7 | test: 8 | dune runtest 9 | 10 | install: 11 | dune install 12 | 13 | uninstall: 14 | dune uninstall 15 | 16 | clean: 17 | rm -rf _build *.install 18 | 19 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## ocaml-github: GitHub APIv3 OCaml Library 2 | 3 | [![OCaml-CI Build Status](https://img.shields.io/endpoint?url=https://ci.ocamllabs.io/badge/mirage/ocaml-github/master&logo=ocaml)](https://ci.ocamllabs.io/github/mirage/ocaml-github/) 4 | [![docs](https://img.shields.io/badge/doc-online-blue.svg)](https://mirage.github.io/ocaml-github/) 5 | 6 | This library provides an OCaml interface to the [GitHub 7 | APIv3](https://docs.github.com/rest/) (JSON). It is compatible with 8 | [MirageOS](https://mirage.io) and also compiles to pure JavaScript via 9 | [js_of_ocaml](http://ocsigen.org/js_of_ocaml). 10 | 11 | It is [not yet complete](#api-support-coverage) but 12 | [lib/github.atd](https://github.com/mirage/ocaml-github/blob/master/lib_data/github.atd) 13 | contains the data types that have been bound so far. 14 | 15 | There are several tests and examples in 16 | [lib_test](https://github.com/mirage/ocaml-github/tree/master/lib_test) 17 | for small bits of 18 | functionality. [jar](https://github.com/mirage/ocaml-github/tree/master/jar) 19 | contains utility programs that use the [git jar](#git-jar) facility for 20 | stored tokens. 21 | 22 | If you are interested in easily using this library to listen for GitHub 23 | web hook events, you should look at [dsheets/ocaml-github-hooks](https://github.com/dsheets/ocaml-github-hooks). 24 | 25 | ## Debugging 26 | 27 | Two environment variables will cause more debugging to be output: 28 | 29 | GITHUB_DEBUG=1 # API calls output to stderr 30 | COHTTP_DEBUG=1 # even more HTTP-level debugging 31 | 32 | If using the bindings from the toplevel, you can also set `Github.log_active` 33 | to `true` to get the same effect as setting the `GITHUB_DEBUG` environment 34 | variable. 35 | 36 | ## `git jar` 37 | 38 | Applications that use this library will need to save authorization 39 | tokens locally, and the `Github_cookie_jar` module in 40 | [unix](https://github.com/mirage/ocaml-github/tree/master/unix) helps 41 | handle this more naturally. It maps local application name to an 42 | authorization token so that the application can query the cookie jar at 43 | runtime and use the resulting token in Github API calls. 44 | 45 | The tokens are all stored in `$HOME/.github/jar/`, where `` is the 46 | local name of the application. 47 | 48 | A `git-jar` command will be installed to add, remove, and list the contents 49 | of this cookie jar. 50 | 51 | ```console 52 | $ git jar 53 | ``` 54 | 55 | ...will display the man page. 56 | 57 | 58 | ```console 59 | $ git jar make avsm rwo 60 | Enter Github password: ********** 61 | Enter 2FA code from 'app': 172217 62 | Github cookie jar: created /home/avsm/.github/jar/rwo 63 | Created token rwo (236241): 64 | ``` 65 | 66 | ```console 67 | $ git jar show avsm 68 | Enter Github password: ********** 69 | Enter 2FA code from 'app': 001221 70 | Cookie Name | ID | Application | Note 71 | ---------------------------------------------------------------------------------- 72 | rwo | 236241 | Real World OCaml (API) | 73 | | 340988 | Travis | 74 | ``` 75 | 76 | Your Github application can now use it via the `Github_cookie_jar` module: 77 | 78 | ```ocaml 79 | # #require "github.unix";; 80 | # Github_cookie_jar.(init () |> Lwt_main.run |> get ~name:"rwo");; 81 | - : Github_t.auth option = 82 | Some 83 | {Github_t.auth_scopes = [`Public_repo]; 84 | auth_token = ""; 85 | auth_app = 86 | {Github_t.app_name = "Real World OCaml"; 87 | app_url = "https://docs.github.com/rest/reference/oauth-authorizations"}; 88 | auth_url = "https://api.github.com/authorizations/236241"; 89 | auth_id = 236241; auth_note = Some "rwo"; auth_note_url = None} 90 | ``` 91 | 92 | ## Manipulate GitHub releases 93 | 94 | The [Releases](https://docs.github.com/rest/reference/repos#releases) API in 95 | GitHub cannot itself be synched via Git, so this command-line tool lets you 96 | specify a source user/repo and destination user/repo pair, and copies all the 97 | releases from one to the other. 98 | 99 | The `git-sync-releases` binary can copy all the releases from one 100 | repository to another for you. 101 | 102 | ``` 103 | $ git sync-releases mirage ocaml-uri avsm ocaml-uri 104 | ``` 105 | 106 | You can also associate binary files with any release, for example to 107 | include pregenerated build files. The `git upload-release` binary 108 | will do this for you. 109 | 110 | ``` 111 | $ git upload-release mirage ocaml-uri v1.4.0 release.tar.gz 112 | ``` 113 | 114 | ## API support coverage 115 | 116 | ### [Media Types](https://docs.github.com/rest/overview/media-types) 117 | 118 | *Supported*: application/vnd.github.v3+json 119 | 120 | *Not yet supported*: Other media types 121 | 122 | ### [OAuth](https://docs.github.com/developers/apps/authorizing-oauth-apps) 123 | *Supported*: 124 | 125 | * Web and non-Web flows with two-factor authentication 126 | * Basic Authorizations API 127 | 128 | *Not yet supported*: 129 | 130 | * [Check](https://docs.github.com/rest/reference/oauth-authorizations) (see [#83](https://github.com/mirage/ocaml-github/issues/83)) 131 | * [Reset](https://docs.github.com/rest/reference/oauth-authorizations) (see [#83](https://github.com/mirage/ocaml-github/issues/83)) 132 | * Fingerprint retrieval (see [#83](https://github.com/mirage/ocaml-github/issues/83)) 133 | * get-or-create, update, revoke 134 | * fingerprint endpoints 135 | 136 | ### [Activity](https://docs.github.com/rest/reference/activity) 137 | *Supported*: 138 | 139 | * All [Events](https://docs.github.com/rest/reference/activity#events) endpoints 140 | * Event types: commit comment, create, delete, deployment, deployment status, 141 | download, follow, fork, fork apply, gist, gollum, issue comment, 142 | issues, member, page build, public, pull request, pull request review 143 | comment, push, release, repository, status, team add, watch 144 | 145 | *Not yet supported*: 146 | 147 | * Event types: membership 148 | * [Feeds](https://docs.github.com/rest/reference/activity#feeds) 149 | * [Notifications](https://docs.github.com/rest/reference/activity#notifications) 150 | * [Starring](https://docs.github.com/rest/reference/activity#starring) 151 | * [Watching](https://docs.github.com/rest/reference/activity#watching) 152 | 153 | ### [Gists](https://docs.github.com/rest/reference/gists) 154 | *Supported*: 155 | 156 | * All endpoints 157 | 158 | *Not yet supported*: 159 | 160 | * Special media types 161 | * Truncation helpers 162 | 163 | ### [Git Data](https://docs.github.com/rest/reference/git) 164 | 165 | *Not yet supported*: everything (see 166 | [#40](https://github.com/mirage/ocaml-github/issues/40)) 167 | 168 | ### [Issues](https://docs.github.com/rest/reference/issues) 169 | *Supported*: 170 | 171 | * All basic endpoints 172 | * Basic comments endpoints 173 | * [Milestones](https://docs.github.com/rest/reference/issues#milestones) 174 | * [Labels](https://docs.github.com/rest/reference/issues#labels) 175 | * [Repository issue comments](https://docs.github.com/rest/reference/issues#list-issue-comments-for-a-repository) 176 | * [Get a single issue comment](https://docs.github.com/rest/reference/issues#get-an-issue-comment) 177 | * [Edit an issue comment](https://docs.github.com/rest/reference/issues#update-an-issue-comment) (see [#87](https://github.com/mirage/ocaml-github/issues/87)) 178 | * [Delete an issue comment](https://docs.github.com/rest/reference/issues#delete-an-issue-comment) 179 | * [Issue events](https://docs.github.com/rest/reference/issues#events) 180 | * [Timeline](https://docs.github.com/rest/reference/issues#timeline) 181 | 182 | *Not yet supported*: 183 | 184 | * Custom media types 185 | * [Assignees](https://docs.github.com/rest/reference/issues#assignees) 186 | 187 | ### Miscellaneous 188 | *Supported*: 189 | 190 | * [Rate limit](https://docs.github.com/rest/reference/rate-limit) 191 | * [Emojis](https://docs.github.com/rest/reference/emojis) 192 | 193 | *Not yet supported*: 194 | 195 | * [Gitignore](https://docs.github.com/rest/reference/gitignore) 196 | * [Markdown](https://docs.github.com/rest/reference/markdown) 197 | * [Meta](https://docs.github.com/rest/reference/meta) 198 | * [Licenses](https://docs.github.com/rest/reference/licenses) 199 | 200 | ### [Organizations](https://docs.github.com/rest/reference/orgs) 201 | *Supported*: 202 | 203 | * [List teams](https://docs.github.com/rest/reference/teams#list-teams) 204 | * [Get team](https://docs.github.com/rest/reference/teams#get-a-team-by-name) 205 | * [List team repos](https://docs.github.com/rest/reference/teams#list-team-repositories) 206 | * [List your organizations](https://docs.github.com/rest/reference/orgs#list-organizations-for-the-authenticated-user) 207 | * [List (public) user organizations](https://docs.github.com/rest/reference/orgs#list-organizations-for-a-user) 208 | * [Webhooks](https://docs.github.com/rest/reference/orgs#webhooks) 209 | 210 | *Not yet supported*: everything else 211 | 212 | ### [Pull Requests](https://docs.github.com/rest/reference/pulls) 213 | *Supported*: 214 | 215 | * All endpoints 216 | 217 | *Not yet supported*: 218 | 219 | * Link relations 220 | * Custom media types 221 | 222 | ### [Repositories](https://docs.github.com/rest/reference/repos) 223 | *Supported*: 224 | 225 | * [Create](https://docs.github.com/rest/reference/repos#create-a-repository-for-the-authenticated-user) 226 | * [List user 227 | repositories](https://docs.github.com/rest/reference/repos#list-repositories-for-a-user) 228 | * [Get](https://docs.github.com/rest/reference/repos#get-a-repository) 229 | * [Delete repository](https://docs.github.com/rest/reference/repos#delete-a-repository) 230 | * [List tags](https://docs.github.com/rest/reference/repos#list-repository-tags) 231 | * [List branches](https://docs.github.com/rest/reference/repos#list-branches) 232 | * [Get a single 233 | commit](https://docs.github.com/rest/reference/repos#get-a-commit) 234 | * [Deploy keys](https://docs.github.com/rest/reference/repos#deploy-keys) 235 | * [Forks](https://docs.github.com/rest/reference/repos#forks) 236 | * Most [Releases](https://docs.github.com/rest/reference/repos#releases) endpoints 237 | * [Create a 238 | status](https://docs.github.com/rest/reference/repos#create-a-commit-status) 239 | * [List statuses for a specific 240 | ref](https://docs.github.com/rest/reference/repos#list-commit-statuses-for-a-reference) 241 | * [Get the combined status for a specific 242 | ref](https://docs.github.com/rest/reference/repos#get-the-combined-status-for-a-specific-reference) 243 | * [List contributors](https://docs.github.com/rest/reference/repos#list-repository-contributors) 244 | * Most [Webhooks](https://docs.github.com/rest/reference/repos#webhooks) endpoints 245 | * [Ping a 246 | hook](https://docs.github.com/rest/reference/repos#ping-a-repository-webhook) 247 | * [Get contributors list with additions, deletions, and commit counts](https://docs.github.com/rest/reference/repos#get-all-contributor-commit-activity) 248 | * [Collaborators](https://docs.github.com/rest/reference/repos#collaborators) 249 | * [List organization 250 | repositories](https://docs.github.com/rest/reference/repos#list-organization-repositories) 251 | * [Get the last year of commit activity 252 | data](https://docs.github.com/rest/reference/repos#get-the-last-year-of-commit-activity) (see [#86](https://github.com/mirage/ocaml-github/issues/86)) 253 | * [Get the number of additions and deletions per week](https://docs.github.com/rest/reference/repos#get-the-weekly-commit-activity) (see [#86](https://github.com/mirage/ocaml-github/issues/86)) 254 | * [Get the weekly commit count for the repository owner and everyone else](https://docs.github.com/rest/reference/repos#get-the-weekly-commit-count) (see [#86](https://github.com/mirage/ocaml-github/issues/86)) 255 | * [Get the number of commits per hour in each day](https://docs.github.com/rest/reference/repos#get-the-hourly-commit-count-for-each-day) (see [#86](https://github.com/mirage/ocaml-github/issues/86)) 256 | * [Get the latest 257 | release](https://docs.github.com/rest/reference/repos#get-the-latest-release) 258 | * [List assets for a 259 | release](https://docs.github.com/rest/reference/repos#list-release-assets) 260 | * [Get a release by tag name](https://docs.github.com/rest/reference/repos#get-a-release-by-tag-name) 261 | * [Get a single release 262 | asset](https://docs.github.com/rest/reference/repos#get-a-release-asset) 263 | * [Delete a release 264 | asset](https://docs.github.com/rest/reference/repos#delete-a-release-asset) 265 | 266 | *Not yet supported*: 267 | 268 | * [List your 269 | repositories](https://docs.github.com/rest/reference/repos#list-repositories-for-the-authenticated-user) 270 | * [List all public 271 | repositories](https://docs.github.com/rest/reference/repos#list-public-repositories) 272 | * [Edit](https://docs.github.com/rest/reference/repos#update-a-repository) 273 | * [List 274 | languages](https://docs.github.com/rest/reference/repos#list-repository-languages) 275 | * [List teams](https://docs.github.com/rest/reference/repos#list-repository-teams) 276 | * [Get branch](https://docs.github.com/rest/reference/repos#get-a-branch) 277 | * [Commit comments](https://docs.github.com/rest/reference/repos#comments) 278 | * [List 279 | commits](https://docs.github.com/rest/reference/repos#list-commits) 280 | * [Compare two 281 | commits](https://docs.github.com/rest/reference/repos#compare-two-commits) 282 | * [Contents](https://docs.github.com/rest/reference/repos#contents) 283 | * [Deployments](https://docs.github.com/rest/reference/repos#deployments) 284 | * [Merging](https://docs.github.com/rest/reference/repos#merging) 285 | * [Pages](https://docs.github.com/rest/reference/repos#pages) 286 | * [Get the latest 287 | release](https://docs.github.com/rest/reference/repos#get-the-latest-release) 288 | * [Edit a release 289 | asset](https://docs.github.com/rest/reference/repos#update-a-release-asset) 290 | * [PubSubHubbub](https://docs.github.com/rest/reference/repos#pubsubhubbub) 291 | * [Receiving Webhooks 292 | helpers](https://docs.github.com/rest/reference/repos#receiving-webhooks) 293 | 294 | ### [Search](https://docs.github.com/rest/reference/search) 295 | *Supported*: 296 | 297 | * [Search 298 | repositories](https://docs.github.com/rest/reference/search#search-repositories) 299 | 300 | *Not yet supported*: 301 | 302 | * [Search code](https://docs.github.com/rest/reference/search#search-code) 303 | * [Search issues](https://docs.github.com/rest/reference/search#search-issues-and-pull-requests) 304 | * [Search users](https://docs.github.com/rest/reference/search#search-users) 305 | * [Text match media 306 | type](https://docs.github.com/rest/reference/search#text-match-metadata) 307 | 308 | ### [Users](https://docs.github.com/rest/reference/users) 309 | *Supported*: 310 | 311 | * [Get a single 312 | user](https://docs.github.com/rest/reference/users#get-a-user) 313 | * [Get the authenticated 314 | user](https://docs.github.com/rest/reference/users#get-the-authenticated-user) 315 | 316 | *Not yet supported*: 317 | 318 | * [Update the authenticated 319 | user](https://docs.github.com/rest/reference/users#update-the-authenticated-user) 320 | * [Get all users](https://docs.github.com/rest/reference/users#list-users) 321 | 322 | ### [Enterprise](https://docs.github.com/rest/reference/enterprise-admin) 323 | *Not yet supported*: everything 324 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | Library: 2 | 3 | * Can ATDgen map strings through functions 4 | (to get `Url.t` instead of a `string`, for example) 5 | 6 | Git-jar: 7 | 8 | * Add a `show [-r|-l]` to do only remote or local, so that 9 | Github connectivity isn't necessary just to query local cookies. 10 | 11 | * Factor out the common user/pass Args instead of repeating the code. 12 | -------------------------------------------------------------------------------- /appveyor.yml: -------------------------------------------------------------------------------- 1 | platform: 2 | - x86 3 | 4 | environment: 5 | FORK_USER: ocaml 6 | FORK_BRANCH: master 7 | CYG_ROOT: C:\cygwin64 8 | PACKAGE: github-unix 9 | PINS: github.dev:. github-unix.dev:. 10 | 11 | install: 12 | - ps: iex ((new-object net.webclient).DownloadString("https://raw.githubusercontent.com/$env:FORK_USER/ocaml-ci-scripts/$env:FORK_BRANCH/appveyor-install.ps1")) 13 | 14 | build_script: 15 | - call %CYG_ROOT%\bin\bash.exe -l %APPVEYOR_BUILD_FOLDER%\appveyor-opam.sh 16 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | (name github) 3 | 4 | (generate_opam_files true) 5 | (formatting disabled) 6 | 7 | (license MIT) 8 | (maintainers "Anil Madhavapeddy ") 9 | (authors "Anil Madhavapeddy" "David Sheets" "Andy Ray" 10 | "Jeff Hammerbacher" "Thomas Gazagnaire" "Rudi Grinberg" 11 | "Qi Li" "Jeremy Yallop" "Dave Tucker") 12 | (source (github mirage/ocaml-github)) 13 | (documentation "https://mirage.github.io/ocaml-github/") 14 | 15 | (package 16 | (name github) 17 | (tags (org:mirage org:xapi-project git)) 18 | (depends 19 | (ocaml (>= 4.08.0)) 20 | (uri (>= 1.9.0)) 21 | (cohttp (>= 4.0.0)) 22 | (lwt (>= 2.4.4)) 23 | (cohttp-lwt (>= 4.0.0)) 24 | (github-data (= :version)) 25 | (yojson (>= 1.7.0)) 26 | stringext) 27 | (synopsis "GitHub APIv3 OCaml library") 28 | (description "This library provides an OCaml interface to the 29 | [GitHub APIv3](https://docs.github.com/rest/) (JSON). 30 | 31 | It is compatible with [MirageOS](https://mirage.io) and also compiles to pure 32 | JavaScript via [js_of_ocaml](http://ocsigen.org/js_of_ocaml).")) 33 | 34 | (package 35 | (name github-jsoo) 36 | (tags (org:mirage org:xapi-project git)) 37 | (depends 38 | (ocaml (>= 4.08.0)) 39 | (github (= :version)) 40 | (cohttp (>= 4.0.0)) 41 | (cohttp-lwt-jsoo (>= 4.0.0)) 42 | (js_of_ocaml-lwt (>= 3.4.0))) 43 | (synopsis "GitHub APIv3 JavaScript library") 44 | (description "This library provides an OCaml interface to the [GitHub APIv3](https://docs.github.com/rest/) 45 | (JSON). This library installs the JavaScript version, which uses [js_of_ocaml](http://ocsigen.org/js_of_ocaml).")) 46 | 47 | (package 48 | (name github-unix) 49 | (tags (org:mirage org:xapi-project git)) 50 | (depends 51 | (ocaml (>= 4.08.0)) 52 | (github (= :version)) 53 | (cohttp (>= 4.0.0)) 54 | (cohttp-lwt-unix (>= 4.0.0)) 55 | stringext 56 | (cmdliner (>= 1.1.0)) 57 | base-unix 58 | lwt) 59 | (synopsis "GitHub APIv3 Unix library") 60 | (description "This library provides an OCaml interface to the [GitHub APIv3](https://docs.github.com/rest/) 61 | (JSON). This package installs the Unix (Lwt) version.")) 62 | 63 | (package 64 | (name github-data) 65 | (tags (org:mirage org:xapi-project git)) 66 | (depends 67 | (ocaml (>= 4.08.0)) 68 | (yojson (>= 1.7.0)) 69 | (atdgen (>= 2.0.0))) 70 | (conflicts (github (<> :version))) 71 | (synopsis "GitHub APIv3 data library") 72 | (description "This library provides an OCaml interface to the [GitHub APIv3](https://docs.github.com/rest/) 73 | (JSON). This package installs the data conversion library.")) 74 | -------------------------------------------------------------------------------- /gist/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (libraries cohttp-lwt-unix github_unix cmdliner passwd) 3 | (public_name git-gist) 4 | (package github-unix) 5 | (name gist)) 6 | -------------------------------------------------------------------------------- /gist/gist.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Andy Ray 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | (* Utility for working with gist files *) 19 | 20 | open Cmdliner 21 | open Printf 22 | open Lwt 23 | 24 | open Github_t 25 | module G = Github 26 | module Gist = Github.Gist 27 | module M = Github.Monad 28 | 29 | let gist_version = "0.1.0" 30 | 31 | let very_pretty_json s = Json.to_string (Yojson.Safe.from_string s :> Yojson.t) 32 | let quite_pretty_json s = Yojson.Safe.pretty_to_string (Yojson.Safe.from_string s) 33 | let pretty_json pretty = if pretty then very_pretty_json else quite_pretty_json 34 | 35 | exception Auth_token_not_found of string 36 | exception Gist_file_not_found of string 37 | 38 | (************************************************************************) 39 | (* Authorization *) 40 | 41 | (* for now, we look it up in the cookie jar. 42 | We could query github for it instead. *) 43 | let get_auth_token_from_jar auth_id = 44 | Github_cookie_jar.init () >>= fun jar -> 45 | Github_cookie_jar.(get jar ~name:auth_id) >>= function 46 | | Some x -> return x 47 | | None -> Lwt.fail (Auth_token_not_found "given id not in cookie jar") 48 | 49 | (* TODO factor out 2FA code *) 50 | let complete_2fa c = 51 | let rec try_again f = Github.(Monad.(f () >>~ function 52 | | Result auths -> return auths 53 | | Two_factor mode -> 54 | embed (Lwt_io.printf "Enter 2FA code from '%s': " mode) 55 | >>= fun () -> 56 | embed (Lwt_io.(read_line stdin)) 57 | >>= fun otp -> 58 | let otp = Some otp in 59 | try_again (c ?otp) 60 | )) in 61 | let otp = None in 62 | try_again (c ?otp) 63 | 64 | (* find a personal access token with either the given name, 65 | * or the first one to include Gist scope *) 66 | let get_personal_access_token_from_github user pass token_name = 67 | Passwd.get_if_unset ~prompt:"Enter Github password: " pass >>= fun pass -> 68 | M.run (complete_2fa (G.Token.get_all ~user ~pass)) >>= fun tokens -> 69 | try 70 | match token_name with 71 | | "" -> (* find token with gist scope *) 72 | return (List.find (fun a -> List.mem `Gist a.auth_scopes) tokens) 73 | | _ -> (* find given token *) 74 | return (List.find (fun a -> a.auth_app.app_name = token_name) tokens) 75 | with _ -> 76 | fail (Auth_token_not_found "couldn't find a matching token") 77 | 78 | let get_auth auth_id user pass token_name = 79 | match auth_id, user with 80 | | "", "" -> Lwt.fail (Auth_token_not_found "must specify username or jar token id") 81 | | _, "" -> get_auth_token_from_jar auth_id 82 | | "", _ -> get_personal_access_token_from_github user pass token_name 83 | | _ -> Lwt.fail (Auth_token_not_found "must specify either username or jar token id") 84 | 85 | let login auth_id user pass token_name json pretty = 86 | Lwt_main.run ( 87 | get_auth auth_id user pass token_name >>= fun code -> 88 | if json then 89 | Lwt_io. printf "%s\n" (pretty_json pretty (Github_j.string_of_auth code)) 90 | else 91 | return_unit 92 | ) 93 | 94 | (************************************************************************) 95 | (* List gists *) 96 | 97 | let describe_gist g = 98 | printf "%20s" g.gist_id; 99 | (match g.gist_description with 100 | | Some(d) when d <> "" -> printf " '%s'" d 101 | | _ -> ()); 102 | printf "\n" 103 | 104 | let list_your_gists auth_id user pass token_name json pretty = 105 | Lwt_main.run ( 106 | get_auth auth_id user pass token_name >>= fun code -> 107 | let token = G.Token.of_auth code in 108 | M.run (G.Stream.to_list (Gist.all ~token ())) >>= fun gists -> 109 | if json then Lwt_io.printf "%s" (pretty_json pretty (Github_j.string_of_gists gists)) 110 | else return (List.iter describe_gist gists) 111 | ) 112 | 113 | let list_user_gists auth_id user pass token_name json pretty username = 114 | Lwt_main.run ( 115 | get_auth auth_id user pass token_name >>= fun code -> 116 | let token = G.Token.of_auth code in 117 | M.run (G.Stream.to_list (Gist.for_user ~token ~user:username ())) 118 | >>= fun gists -> 119 | if json then Lwt_io.printf "%s" (pretty_json pretty (Github_j.string_of_gists gists)) 120 | else return (List.iter describe_gist gists) 121 | ) 122 | 123 | (************************************************************************) 124 | (* Post gists *) 125 | let post_gist auth_id user pass token_name _json _pretty new_gist_public new_gist_description files = 126 | Lwt_main.run ( 127 | get_auth auth_id user pass token_name >>= fun code -> 128 | let token = G.Token.of_auth code in 129 | (* get file contents *) 130 | let contents fname = 131 | Lwt_io.(with_file ~mode:input fname read) >>= fun new_gist_content -> 132 | Lwt.return (fname, {Github_t.new_gist_content}) 133 | in 134 | Lwt_list.map_s contents files >>= fun new_gist_files -> 135 | let gist = { 136 | Github_t.new_gist_files; 137 | new_gist_description; 138 | new_gist_public; 139 | } in 140 | M.(run (Gist.create ~token ~gist () >|= G.Response.value)) >>= fun gist -> 141 | return (describe_gist gist) 142 | ) 143 | 144 | (************************************************************************) 145 | (* gists file info *) 146 | 147 | let string_of_public = function true -> "public" | false -> "private" 148 | let string_of_size x = 149 | let rnd x y = (x + y - 1) / y in 150 | if x < 1024 then sprintf "%i B" x 151 | else if x < (1024*1024) then sprintf "%i KiB" (rnd x 1024) 152 | else if x < (1024*1024*1024) then sprintf "%i MiB" (rnd x (1024*1024)) 153 | else "> GiB!" 154 | let string_of_bool ?(t="true") ?(f="false") = 155 | function true -> t 156 | | false-> f 157 | let string_of_bool_opt ?(t="true") ?(f="false") = 158 | function Some true -> t 159 | | Some false | None -> f 160 | let string_of_opt = 161 | function Some x -> x 162 | | None -> "" 163 | 164 | let comma_sep x = 165 | List.fold_left 166 | (fun a x -> 167 | match a,x with 168 | | "","" -> "" 169 | | "",_ -> x 170 | | _,"" -> a 171 | | _ -> a ^ "," ^ x) 172 | "" (List.filter ((<>) "") x) 173 | 174 | let print_gist_file_info name file = 175 | let flags = comma_sep [ 176 | string_of_bool_opt ~t:"truncated" ~f:"" file.gist_file_truncated; 177 | file.gist_file_ty; 178 | string_of_opt file.gist_file_language; 179 | ] in 180 | Lwt_io.printf "%-40s %-8s %s\n" name (string_of_size file.gist_file_size) flags 181 | 182 | let gist_info auth_id user pass token_name json pretty gist_id = 183 | Lwt_main.run ( 184 | get_auth auth_id user pass token_name >>= fun code -> 185 | let token = G.Token.of_auth code in 186 | M.(run (Gist.get ~token ~id:gist_id () >|= G.Response.value)) 187 | >>= fun gist -> 188 | if json then 189 | Lwt_io. printf "%s\n" (pretty_json pretty (Github_j.string_of_gist gist)) 190 | else 191 | Lwt_list.iter_s 192 | (fun (name,file) -> print_gist_file_info name file) 193 | gist.gist_files 194 | ) 195 | 196 | let gist_file_info auth_id user pass token_name json pretty gist_id file = 197 | Lwt_main.run ( 198 | get_auth auth_id user pass token_name >>= fun code -> 199 | let token = G.Token.of_auth code in 200 | M.(run (Gist.get ~token ~id:gist_id () >|= G.Response.value)) 201 | >>= fun gist -> 202 | (try Lwt.return (List.assoc file gist.gist_files) 203 | with _ -> Lwt.fail (Gist_file_not_found file)) >>= 204 | fun file_data -> 205 | if json then 206 | Lwt_io. printf "%s\n" (pretty_json pretty (Github_j.string_of_gist_file file_data)) 207 | else begin 208 | print_gist_file_info file file_data >>= fun () -> 209 | Lwt_io.printf "url: %s\n" file_data.gist_file_raw_url 210 | end 211 | ) 212 | 213 | (************************************************************************) 214 | (* gists files *) 215 | 216 | let gist_get _auth_id _user _pass _token_name _json _pretty _gist_id _file_or_dir = 217 | () 218 | 219 | (************************************************************************) 220 | (* *) 221 | 222 | (************************************************************************) 223 | (* user interface *) 224 | 225 | let user = Arg.(value & opt string "" & info ["u";"username"] ~docv:"USERNAME" 226 | ~doc:"Authentication username.") 227 | 228 | let pass = Arg.(value & opt (some string) None & info ["p";"password"] 229 | ~docv:"PASSWORD" ~doc:"Authentication password.") 230 | 231 | let auth_id = Arg.(value & opt string "" & info ["a";"auth-id"] ~docv:"AUTH-ID" 232 | ~doc:"GitHub cookie jar token name.") 233 | 234 | let token_name = Arg.(value & opt string "" & info ["t";"token-name"] ~docv:"TOKEN-NAME" 235 | ~doc:"Personal authentication token name.") 236 | 237 | let json = Arg.(value & flag & info ["json"] ~docv:"JSON" 238 | ~doc:"Show JSON responses.") 239 | 240 | let pretty = Arg.(value & flag & info ["pretty"] ~docv:"PRETTY" 241 | ~doc:"Pretty print JSON responses.") 242 | 243 | let user_pos = Arg.(required & pos 0 (some string) None & info [] ~docv:"USERNAME" 244 | ~doc:"Github username.") 245 | 246 | let gist_id_pos = Arg.(required & pos 0 (some string) None & info [] ~docv:"GIST-ID" 247 | ~doc:"GIST id.") 248 | 249 | let file_pos = Arg.(required & pos 1 (some string) None & info [] ~docv:"FILENAME" 250 | ~doc:"File name.") 251 | 252 | let list_your_gists = 253 | let term = Term.(const list_your_gists $ auth_id $ user $ pass $ token_name $ json $ pretty) in 254 | let info = Cmd.info "list" ~doc:"list your GISTs" in 255 | Cmd.v info term 256 | 257 | let list_user_gists = 258 | let term = Term.(const list_user_gists $ auth_id $ user $ pass $ token_name $ json $ pretty $ user_pos ) in 259 | let info = Cmd.info "list-user" ~doc:"list users GISTs" in 260 | Cmd.v info term 261 | 262 | let post_new_gist = 263 | let public = Arg.(value & flag & info ["public"] ~docv:"PUBLIC GIST" 264 | ~doc:"Create a public gist (default is secret)") in 265 | let descr = Arg.(required & opt (some string) None & info ["d";"descr"] ~docv:"DESCRIPTION" 266 | ~doc:"Description of the Gist") in 267 | let files = Arg.(non_empty & pos_all file [] & info [] ~docv:"FILES") in 268 | let term = Term.(const post_gist $ 269 | auth_id $ user $ pass $ token_name $ json $ pretty $ public $ descr $ files) in 270 | let info = Cmd.info "create" ~doc:"create new gist" in 271 | Cmd.v info term 272 | 273 | let login = 274 | let term = Term.(const login $ 275 | auth_id $ user $ pass $ token_name $ json $ pretty) in 276 | let info = Cmd.info "login" ~doc:"show login token" in 277 | Cmd.v info term 278 | 279 | let gist_info = 280 | let term = Term.(const gist_info $ auth_id $ user $ pass $ token_name $ json $ pretty $ gist_id_pos) in 281 | let info = Cmd.info "info" ~doc:"display info about a given gist" in 282 | Cmd.v info term 283 | 284 | let gist_file_info = 285 | let term = Term.(const gist_file_info $ 286 | auth_id $ user $ pass $ token_name $ json $ pretty $ gist_id_pos $ file_pos) in 287 | let info = Cmd.info "file-info" ~doc:"display info about a file within gist" in 288 | Cmd.v info term 289 | 290 | let default_info = 291 | let doc = "manipulate Github GIST files from the command line" in 292 | let man = [ 293 | `S "DESCRIPTION"; 294 | `P "Read, write and otherwise manipulate Github GIST files from the command line. Github authentication is handled with tokens created with the $(b,git-jar) command line tool."; 295 | `S "AUTHORIZATION OPTIONS"; 296 | `P "An authorization token is required to access the Github API. You can generate and store \ 297 | a token using the $(b,git-jar) tool and retrieve it with $(b,--auth-id). Alternatively you can supply a username and password to retrieve a token from Github (specified with $(b,--token-id) or otherwise found automatically)."; 298 | `P "$(b,--username) specify Github username."; 299 | `P "$(b,--password) optionally specifies the Github password on the command-line. If it isn't present, then the password will be obtained interactively."; 300 | `P "$(b,--token-id) specify the Github token id."; 301 | `P "$(b,--auth-id) specify the $(b,git-jar) cookie id."; 302 | `S "COMMON OPTIONS"; 303 | `P "$(b,--help) will show more help for each of the sub-commands above."; 304 | `P "$(b,--json) Show JSON responses."; 305 | `P "$(b,--pretty) pretty print JSON responses."; 306 | `S "BUGS"; 307 | `P "Email bug reports to , or report them online at ." ] in 308 | Cmd.info "git-gist" ~version:gist_version ~doc ~man 309 | 310 | let () = 311 | let default = Term.(ret (const (`Help (`Pager, None)))) in 312 | let cmds = Cmd.group ~default default_info [list_your_gists; list_user_gists; login; gist_info; gist_file_info; post_new_gist] in 313 | exit @@ Cmd.eval cmds 314 | 315 | -------------------------------------------------------------------------------- /gist/json.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | open Easy_format 3 | 4 | let json_string_of_int = sprintf "\x1b[31m%i\x1b[m" 5 | let json_string_of_string = sprintf "\x1b[32m%s\x1b[m" 6 | let json_string_of_ident = sprintf "\x1b[33m%s\x1b[m:" 7 | 8 | let std_json_string_of_float = sprintf "\x1b[34m%f\x1b[m:" 9 | let json_string_of_float = sprintf "\x1b[34m%f\x1b[m:" 10 | 11 | let is_object_or_array x = 12 | match x with 13 | `List _ 14 | | `Assoc _ -> true 15 | | _ -> false 16 | 17 | let array = list 18 | let record = list 19 | let tuple = { list with 20 | space_after_opening = false; 21 | space_before_closing = false; 22 | align_closing = false } 23 | let variant = { list with 24 | space_before_closing = false; } 25 | 26 | let rec format std (x : Yojson.t) = 27 | match x with 28 | `Null -> Atom ("null", atom) 29 | | `Bool x -> Atom ((if x then "true" else "false"), atom) 30 | | `Int x -> Atom (json_string_of_int x, atom) 31 | | `Float x -> 32 | let s = 33 | if std then std_json_string_of_float x 34 | else json_string_of_float x 35 | in 36 | Atom (s, atom) 37 | | `String s -> Atom (json_string_of_string s, atom) 38 | | `Intlit s 39 | | `Floatlit s 40 | | `Stringlit s -> Atom (s, atom) 41 | | `List [] -> Atom ("[]", atom) 42 | | `List l -> List (("[", ",", "]", array), List.map (format std) l) 43 | | `Assoc [] -> Atom ("{}", atom) 44 | | `Assoc l -> List (("{", ",", "}", record), List.map (format_field std) l) 45 | | `Tuple l -> 46 | if std then 47 | format std (`List l) 48 | else 49 | if l = [] then 50 | Atom ("()", atom) 51 | else 52 | List (("(", ",", ")", tuple), List.map (format std) l) 53 | 54 | | `Variant (s, None) -> 55 | if std then 56 | format std (`String s) 57 | else 58 | Atom ("<" ^ json_string_of_string s ^ ">", atom) 59 | 60 | | `Variant (s, Some x) -> 61 | if std then 62 | format std (`List [ `String s; x ]) 63 | else 64 | let op = "<" ^ json_string_of_string s ^ ":" in 65 | List ((op, "", ">", variant), [format std x]) 66 | 67 | and format_field std (name, x) = 68 | (*let s = sprintf "%s:" (json_string_of_string name) in*) 69 | let s = json_string_of_ident name in 70 | Label ((Atom (s, atom), label), format std x) 71 | 72 | 73 | let format ?(std = false) x = 74 | if std && not (is_object_or_array x) then 75 | Yojson.json_error 76 | "Root is not an object or array as requested by the JSON standard" 77 | else 78 | format std (x :> Yojson.t) 79 | 80 | let to_string ?std x = 81 | Easy_format.Pretty.to_string (format ?std x) 82 | 83 | let to_channel ?std oc x = 84 | Easy_format.Pretty.to_channel oc (format ?std x) 85 | -------------------------------------------------------------------------------- /github-data.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "GitHub APIv3 data library" 4 | description: """ 5 | This library provides an OCaml interface to the [GitHub APIv3](https://docs.github.com/rest/) 6 | (JSON). This package installs the data conversion library.""" 7 | maintainer: ["Anil Madhavapeddy "] 8 | authors: [ 9 | "Anil Madhavapeddy" 10 | "David Sheets" 11 | "Andy Ray" 12 | "Jeff Hammerbacher" 13 | "Thomas Gazagnaire" 14 | "Rudi Grinberg" 15 | "Qi Li" 16 | "Jeremy Yallop" 17 | "Dave Tucker" 18 | ] 19 | license: "MIT" 20 | tags: ["org:mirage" "org:xapi-project" "git"] 21 | homepage: "https://github.com/mirage/ocaml-github" 22 | doc: "https://mirage.github.io/ocaml-github/" 23 | bug-reports: "https://github.com/mirage/ocaml-github/issues" 24 | depends: [ 25 | "dune" {>= "2.7"} 26 | "ocaml" {>= "4.08.0"} 27 | "yojson" {>= "1.7.0"} 28 | "atdgen" {>= "2.0.0"} 29 | "odoc" {with-doc} 30 | ] 31 | conflicts: [ 32 | "github" {!= version} 33 | ] 34 | build: [ 35 | ["dune" "subst"] {dev} 36 | [ 37 | "dune" 38 | "build" 39 | "-p" 40 | name 41 | "-j" 42 | jobs 43 | "@install" 44 | "@runtest" {with-test} 45 | "@doc" {with-doc} 46 | ] 47 | ] 48 | dev-repo: "git+https://github.com/mirage/ocaml-github.git" 49 | -------------------------------------------------------------------------------- /github-jsoo.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "GitHub APIv3 JavaScript library" 4 | description: """ 5 | This library provides an OCaml interface to the [GitHub APIv3](https://docs.github.com/rest/) 6 | (JSON). This library installs the JavaScript version, which uses [js_of_ocaml](http://ocsigen.org/js_of_ocaml).""" 7 | maintainer: ["Anil Madhavapeddy "] 8 | authors: [ 9 | "Anil Madhavapeddy" 10 | "David Sheets" 11 | "Andy Ray" 12 | "Jeff Hammerbacher" 13 | "Thomas Gazagnaire" 14 | "Rudi Grinberg" 15 | "Qi Li" 16 | "Jeremy Yallop" 17 | "Dave Tucker" 18 | ] 19 | license: "MIT" 20 | tags: ["org:mirage" "org:xapi-project" "git"] 21 | homepage: "https://github.com/mirage/ocaml-github" 22 | doc: "https://mirage.github.io/ocaml-github/" 23 | bug-reports: "https://github.com/mirage/ocaml-github/issues" 24 | depends: [ 25 | "dune" {>= "2.7"} 26 | "ocaml" {>= "4.08.0"} 27 | "github" {= version} 28 | "cohttp" {>= "4.0.0"} 29 | "cohttp-lwt-jsoo" {>= "4.0.0"} 30 | "js_of_ocaml-lwt" {>= "3.4.0"} 31 | "odoc" {with-doc} 32 | ] 33 | build: [ 34 | ["dune" "subst"] {dev} 35 | [ 36 | "dune" 37 | "build" 38 | "-p" 39 | name 40 | "-j" 41 | jobs 42 | "@install" 43 | "@runtest" {with-test} 44 | "@doc" {with-doc} 45 | ] 46 | ] 47 | dev-repo: "git+https://github.com/mirage/ocaml-github.git" 48 | -------------------------------------------------------------------------------- /github-unix.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "GitHub APIv3 Unix library" 4 | description: """ 5 | This library provides an OCaml interface to the [GitHub APIv3](https://docs.github.com/rest/) 6 | (JSON). This package installs the Unix (Lwt) version.""" 7 | maintainer: ["Anil Madhavapeddy "] 8 | authors: [ 9 | "Anil Madhavapeddy" 10 | "David Sheets" 11 | "Andy Ray" 12 | "Jeff Hammerbacher" 13 | "Thomas Gazagnaire" 14 | "Rudi Grinberg" 15 | "Qi Li" 16 | "Jeremy Yallop" 17 | "Dave Tucker" 18 | ] 19 | license: "MIT" 20 | tags: ["org:mirage" "org:xapi-project" "git"] 21 | homepage: "https://github.com/mirage/ocaml-github" 22 | doc: "https://mirage.github.io/ocaml-github/" 23 | bug-reports: "https://github.com/mirage/ocaml-github/issues" 24 | depends: [ 25 | "dune" {>= "2.7"} 26 | "ocaml" {>= "4.08.0"} 27 | "github" {= version} 28 | "cohttp" {>= "4.0.0"} 29 | "cohttp-lwt-unix" {>= "4.0.0"} 30 | "stringext" 31 | "cmdliner" {>= "1.1.0"} 32 | "base-unix" 33 | "lwt" 34 | "odoc" {with-doc} 35 | ] 36 | build: [ 37 | ["dune" "subst"] {dev} 38 | [ 39 | "dune" 40 | "build" 41 | "-p" 42 | name 43 | "-j" 44 | jobs 45 | "@install" 46 | "@runtest" {with-test} 47 | "@doc" {with-doc} 48 | ] 49 | ] 50 | dev-repo: "git+https://github.com/mirage/ocaml-github.git" 51 | -------------------------------------------------------------------------------- /github.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "GitHub APIv3 OCaml library" 4 | description: """ 5 | This library provides an OCaml interface to the 6 | [GitHub APIv3](https://docs.github.com/rest/) (JSON). 7 | 8 | It is compatible with [MirageOS](https://mirage.io) and also compiles to pure 9 | JavaScript via [js_of_ocaml](http://ocsigen.org/js_of_ocaml).""" 10 | maintainer: ["Anil Madhavapeddy "] 11 | authors: [ 12 | "Anil Madhavapeddy" 13 | "David Sheets" 14 | "Andy Ray" 15 | "Jeff Hammerbacher" 16 | "Thomas Gazagnaire" 17 | "Rudi Grinberg" 18 | "Qi Li" 19 | "Jeremy Yallop" 20 | "Dave Tucker" 21 | ] 22 | license: "MIT" 23 | tags: ["org:mirage" "org:xapi-project" "git"] 24 | homepage: "https://github.com/mirage/ocaml-github" 25 | doc: "https://mirage.github.io/ocaml-github/" 26 | bug-reports: "https://github.com/mirage/ocaml-github/issues" 27 | depends: [ 28 | "dune" {>= "2.7"} 29 | "ocaml" {>= "4.08.0"} 30 | "uri" {>= "1.9.0"} 31 | "cohttp" {>= "4.0.0"} 32 | "lwt" {>= "2.4.4"} 33 | "cohttp-lwt" {>= "4.0.0"} 34 | "github-data" {= version} 35 | "yojson" {>= "1.7.0"} 36 | "stringext" 37 | "odoc" {with-doc} 38 | ] 39 | build: [ 40 | ["dune" "subst"] {dev} 41 | [ 42 | "dune" 43 | "build" 44 | "-p" 45 | name 46 | "-j" 47 | jobs 48 | "@install" 49 | "@runtest" {with-test} 50 | "@doc" {with-doc} 51 | ] 52 | ] 53 | dev-repo: "git+https://github.com/mirage/ocaml-github.git" 54 | -------------------------------------------------------------------------------- /jar/create_release.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Anil Madhavapeddy 3 | * Markus Mottl 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | * 17 | *) 18 | 19 | open Lwt 20 | open Cmdliner 21 | 22 | let create_release ~token 23 | ~user ~repo ~tag ~release_name ~target_commitish ~body:new_release_body 24 | ~assets ~content_type ~prerelease ~draft = 25 | let open Github_t in 26 | let new_release = 27 | { 28 | new_release_tag_name = tag; 29 | new_release_target_commitish = target_commitish; 30 | new_release_name = release_name; 31 | new_release_body; 32 | new_release_draft = draft; 33 | new_release_prerelease = prerelease; 34 | } 35 | in 36 | Github.(Monad.(run ( 37 | Release.create ~token ~user ~repo ~release:new_release () >|= Response.value 38 | ))) >>= fun release -> 39 | let id = release.release_id in 40 | Lwt_list.iter_s (fun filename -> 41 | Lwt_io.file_length filename >|= Int64.to_int >>= fun len -> 42 | let body = Bytes.create len in 43 | Lwt_io.with_file ~mode:Lwt_io.input filename 44 | (fun ic -> Lwt_io.read_into_exactly ic body 0 len) 45 | >>= fun () -> 46 | let body = Bytes.to_string body in 47 | Github.(Monad.(run ( 48 | Release.upload_asset 49 | ~token ~user ~repo ~id ~filename ~content_type ~body () 50 | >|= Response.value 51 | ))) >>= fun () -> 52 | return_unit) assets 53 | 54 | let run token user repo tag release_name target_commitish body assets 55 | content_type prerelease draft = 56 | Lwt_main.run ( 57 | create_release ~token 58 | ~user ~repo ~tag ~release_name ~target_commitish ~body 59 | ~assets ~content_type ~prerelease ~draft) 60 | 61 | let cmd = 62 | let cookie = Jar_cli.cookie () in 63 | let user = 64 | let doc = "The user name on GitHub." in 65 | Arg.(required & pos 0 (some string) None & info [] ~docv:"USER" ~doc) 66 | in 67 | let repo = 68 | let doc = "The repository on GitHub." in 69 | Arg.(required & pos 1 (some string) None & info [] ~docv:"REPO" ~doc) 70 | in 71 | let tag = 72 | let doc = "The tag of the release on GitHub." in 73 | Arg.(required & pos 2 (some string) None & info [] ~docv:"TAG" ~doc) 74 | in 75 | let release_name = 76 | let doc = "The name of the release on GitHub." in 77 | Arg.(value & pos 3 (some string) None & info [] ~docv:"NAME" ~doc) 78 | in 79 | let target_commitish = 80 | let doc = 81 | "Optional SHA-1 commit hash or branch name associated with a tag." 82 | in 83 | let docv = "TARGET_COMMITISH" in 84 | Arg.(value & opt string "master" & info ["target_commitish"] ~docv ~doc) 85 | in 86 | let body = 87 | let doc = "Optional text describing the contents of the release." in 88 | Arg.(value & opt (some string) None & info ["body"] ~docv:"BODY" ~doc) 89 | in 90 | let assets = 91 | let doc = "Optional comma-separated list of assets (files) to upload." in 92 | Arg.(value & opt (list string) [] & info ["assets"] ~docv:"ASSETS" ~doc) 93 | in 94 | let content_type = 95 | let doc = "\ 96 | The MIME content-type of the assets. Defaults to \ 97 | $(i,application/octet-stream), but something more specific is recommended. \ 98 | Assets with mixed content types should be uploaded separately using \ 99 | the $(b,git-upload-release) command." 100 | in 101 | Arg.(value & opt string "application/octet-stream" & info ["content-type"] 102 | ~docv:"CONTENT_TYPE" ~doc) 103 | in 104 | let prerelease = 105 | let doc = "Optional prerelease flag (true or false)." in 106 | Arg.(value & opt bool false & info ["prerelease"] ~docv:"PRERELEASE" ~doc) 107 | in 108 | let draft = 109 | let doc = "Optional draft flag (true or false)." in 110 | Arg.(value & opt bool false & info ["draft"] ~docv:"DRAFT" ~doc) 111 | in 112 | let doc = "create a software release on GitHub" in 113 | let man = 114 | [ 115 | `S "BUGS"; 116 | `P "Email bug reports to ." 117 | ] 118 | in 119 | let term = Term.((const run $ cookie 120 | $ user $ repo $ tag $ release_name $ target_commitish 121 | $ body $ assets $ content_type $ prerelease $ draft)) in 122 | let info = Cmd.info "git-create-release" ~version:Jar_version.t ~doc ~man in 123 | Cmd.v info term 124 | 125 | let () = exit @@ Cmd.eval cmd 126 | -------------------------------------------------------------------------------- /jar/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (libraries cohttp-lwt-unix github_unix cmdliner passwd) 3 | (package github-unix) 4 | (public_names 5 | git-create-release 6 | git-sync-releases 7 | git-upload-release 8 | git-list-releases 9 | git-list-events 10 | git-list-issues 11 | git-jar 12 | git-search 13 | git-listen-events) 14 | (names 15 | create_release 16 | sync_releases 17 | upload_release 18 | list_releases 19 | list_events 20 | list_issues 21 | jar 22 | search 23 | listen_events)) 24 | -------------------------------------------------------------------------------- /jar/jar.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012 Anil Madhavapeddy 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | open Cmdliner 19 | open Printf 20 | open Lwt 21 | 22 | let prompt = "Enter Github password: " 23 | 24 | (* Cmdliner converter for Github scope lists *) 25 | let scope = 26 | let parse s = 27 | match Github.Scope.of_string s with 28 | |None -> `Error "unknown scope" 29 | |Some s -> `Ok s in 30 | let print f s = Format.pp_print_string f (Github.Scope.to_string s) in 31 | parse, print 32 | 33 | let complete_2fa c = 34 | let rec try_again f = Github.(Monad.(f () >>~ function 35 | | Result auths -> return auths 36 | | Two_factor mode -> 37 | embed (Lwt_io.printf "Enter 2FA code from '%s': " mode) 38 | >>= fun () -> 39 | embed (Lwt_io.(read_line stdin)) 40 | >>= fun otp -> 41 | let otp = Some otp in 42 | try_again (c ?otp) 43 | )) in 44 | let otp = None in 45 | try_again (c ?otp) 46 | 47 | (* Command definitions *) 48 | let list_auth user pass = 49 | let open Github_t in 50 | Lwt_main.run ( 51 | Github_cookie_jar.init () 52 | >>= fun jar -> 53 | Passwd.get_if_unset ~prompt pass 54 | >>= fun (pass : string) -> 55 | Github.(Monad.(run (complete_2fa (Token.get_all ~user ~pass)))) 56 | >>= fun auths -> 57 | Github_cookie_jar.get_all jar >>= fun local -> 58 | printf "%-13s | %-8s | %-40s | %-10s\n" "Cookie Name" "ID" "Application" "Note"; 59 | printf "%s\n" (String.make 80 '-'); 60 | List.iter (fun a -> 61 | (* Check if this id is local *) 62 | let id = a.auth_id in 63 | let localnames = List.fold_left (fun acc (n,a) -> 64 | if a.auth_id = id then n::acc else acc) [] local in 65 | let print_line name = 66 | Printf.printf "%13s | %-8Ld | %-40s | %-10s\n" 67 | (match name with None -> "" |Some n -> n) 68 | a.auth_id a.auth_app.app_name 69 | (match a.auth_note with None -> "" |Some b -> b) 70 | in 71 | match localnames with 72 | |[] -> print_line None 73 | |names -> List.iter (fun x -> print_line (Some x)) names 74 | ) auths; 75 | return () 76 | ) 77 | 78 | let list_local () = 79 | Lwt_main.run begin 80 | Github_cookie_jar.init () >>= fun jar -> 81 | Github_cookie_jar.get_all jar >|= fun local -> 82 | List.iter (fun (name, auth) -> 83 | let open Github_t in 84 | printf "%-13s | %-8s | %-40s | %-10s\n" 85 | "Cookie Name" "ID" "Application" "Note"; 86 | printf "%s\n" (String.make 80 '-'); 87 | printf "%13s | %-8Ld | %-40s | %-10s\n" 88 | name auth.auth_id auth.auth_app.app_name 89 | (match auth.auth_note with None -> "" | Some s -> s) 90 | ) local 91 | end 92 | 93 | let make_auth 94 | user pass name scopes note note_url client_id client_secret fingerprint = 95 | let open Github_t in 96 | let note = match note with None -> name | Some note -> note in 97 | Lwt_main.run ( 98 | Github_cookie_jar.init () 99 | >>= fun jar -> 100 | Passwd.get_if_unset ~prompt pass 101 | >>= fun pass -> 102 | Github.Monad.run 103 | (complete_2fa 104 | (Github.Token.create 105 | ~scopes ~note ?note_url ?client_id ?client_secret ?fingerprint 106 | ~user ~pass 107 | ) 108 | ) 109 | >>= fun auth -> 110 | Github_cookie_jar.save jar ~name ~auth 111 | >>= fun _jar -> 112 | Printf.printf "Created token %s (%Ld): %s\n" 113 | name auth.auth_id (Github.Token.(to_string (of_auth auth))); 114 | return () 115 | ) 116 | 117 | let revoke_auth user pass name_or_id = 118 | let open Github_t in 119 | Lwt_main.run ( 120 | Github_cookie_jar.init () 121 | >>= fun jar -> 122 | Github_cookie_jar.get jar ~name:name_or_id 123 | >>= (function 124 | | Some auth -> Lwt.return auth.auth_id 125 | | None -> 126 | (try Lwt.return (Int64.of_string name_or_id) 127 | with _ -> 128 | Printf.eprintf "unknown name or id %s\n" name_or_id; 129 | exit 1 130 | )) 131 | >>= fun id -> 132 | Passwd.get_if_unset ~prompt pass 133 | >>= fun pass -> 134 | Github.Monad.run (complete_2fa (Github.Token.delete ~user ~pass ~id)) 135 | >>= fun () -> 136 | Github_cookie_jar.get_all jar >>= fun local -> 137 | Lwt_list.fold_left_s (fun jar (name,a) -> 138 | if a.auth_id = id then 139 | Github_cookie_jar.delete jar ~name 140 | else return jar 141 | ) jar local >>= fun _ -> 142 | return_unit 143 | ) 144 | 145 | (* Command declarations for Cmdliner *) 146 | let user = Arg.(required & pos 0 (some string) None & info [] ~docv:"USERNAME" 147 | ~doc:"GitHub username.") 148 | let pass = Arg.( 149 | value & opt (some string) None & info ["p";"password"] ~docv:"PASSWORD" 150 | ~doc:"GitHub password. If not specified, this will be obtained interactively." 151 | ) 152 | let name_or_id = Arg.( 153 | required & pos 1 (some string) None & info [] ~docv:"TOKEN_NAME_OR_ID" 154 | ~doc:"Cookie name or numeric GitHub token id." 155 | ) 156 | 157 | let list_local_cmd = 158 | let term = Term.(const list_local $ const ()) in 159 | let info = Cmd.info "local" ~doc:"list local active GitHub authorization tokens" in 160 | Cmd.v info term 161 | 162 | let list_cmd = 163 | let term = Term.(const list_auth $ user $ pass) in 164 | let info = Cmd.info "show" 165 | ~doc:"list all active GitHub authorization tokens, including remote ones." in 166 | Cmd.v info term 167 | 168 | let make_cmd = 169 | let scopes = 170 | let scopes = Github.Scope.(String.concat ", " (List.map to_string all)) in 171 | let doc = Printf.sprintf "Comma delimited list of repository scopes. Can be: %s" scopes in 172 | Arg.(value & opt (list scope) [] & info ["s";"scopes"] ~docv:"SCOPES" ~doc) in 173 | let note = Arg.( 174 | value & opt (some string) None & info ["note"] ~docv:"NOTE" 175 | ~doc:"Informational note to record beside the authorization token" 176 | ) in 177 | let note_url = Arg.( 178 | value & opt (some string) None & info ["url"] ~docv:"URL" 179 | ~doc:"URL to record beside the authorization token" 180 | ) in 181 | let client_id = Arg.( 182 | value & opt (some string) None & info ["client-id"] ~docv:"CLIENT_ID" 183 | ~doc:"Optional oAuth client id to register this token with an application." 184 | ) in 185 | let client_secret = Arg.( 186 | value & opt (some string) None & info ["client-secret"] ~docv:"CLIENT_SECRET" 187 | ~doc:"Optional oAuth client secret to register this token with an application.") in 188 | let fingerprint = Arg.( 189 | value & opt (some string) None & info ["fingerprint"] 190 | ~docv:"FINGERPRINT" ~doc:"Unique token fingerprint" 191 | ) in 192 | let tname = Arg.( 193 | required & pos 1 (some string) None & info [] ~docv:"COOKIE" ~doc:"The local name for the authorization token that applications can look up.") in 194 | let term = Term.(const make_auth 195 | $ user $ pass $ tname 196 | $ scopes $ note $ note_url $ client_id $ client_secret $ fingerprint) in 197 | let info = Cmd.info "make" ~doc:"create a new GitHub authorization token" in 198 | Cmd.v info term 199 | 200 | let revoke_cmd = 201 | let term = Term.(const revoke_auth $ user $ pass $ name_or_id) in 202 | let info = Cmd.info "revoke" 203 | ~doc:"revoke a remote GitHub authorization token and remove it from the local cookie jar." in 204 | Cmd.v info term 205 | 206 | let cmds = 207 | let doc = "let local applications use GitHub authorization tokens" in 208 | let man = [ 209 | `S "DESCRIPTION"; 210 | `P "Applications that want to use GitHub will need to save authorization tokens locally, and $(b,git-jar) provides a CLI interface to manipulate them. GitHub authorization tokens are mapped onto a local $(i,name), and applictions can query that name at runtime to retrieve a token to use in GitHub API calls."; 211 | `P "All the tokens are stored in $(i,$HOME/.github/jar/), where $(i,) is the local name of the token."; 212 | `S "COMMON OPTIONS"; 213 | `P "$(b,--password) optionally specifies the GitHub password on the command-line. If it isn't present, then the password will be obtained interactively."; 214 | `P "$(b,--help) will show more help for each of the sub-commands above."; 215 | `S "BUGS"; 216 | `P "Email bug reports to , or report them online at ."] in 217 | let info = Cmd.info "git-jar" ~version:Jar_version.t ~doc ~man in 218 | let default = Term.(ret (const (`Help (`Pager, None)))) in 219 | Cmd.group ~default info [list_cmd; list_local_cmd; make_cmd; revoke_cmd] 220 | 221 | let () = 222 | try 223 | exit @@ Cmd.eval ~catch:false cmds 224 | with 225 | | Github.Message (_,m) -> 226 | eprintf "GitHub API error: %s\n" (Github.API.string_of_message m); 227 | exit 1 228 | -------------------------------------------------------------------------------- /jar/jar_cli.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 David Sheets 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | open Printf 19 | open Cmdliner 20 | 21 | let map f = Term.(app (const f)) 22 | 23 | let auth cookie = Lwt.( 24 | Lwt_main.run ( 25 | Github_cookie_jar.init () 26 | >>= fun jar -> 27 | Github_cookie_jar.get jar ~name:cookie 28 | >|= function 29 | | None -> 30 | eprintf "Missing cookie: use git-jar to create cookie `%s`.\n%!" cookie; 31 | exit 1 32 | | Some t -> Github.Token.of_string t.Github_t.auth_token 33 | ) 34 | ) 35 | 36 | let repos ?(doc_append="") () = 37 | let doc = "Repositories in user/repo format"^doc_append in 38 | Arg.(non_empty & pos_all string [] & info [] ~docv:"REPOS" ~doc) 39 | 40 | let cookie ?(doc_append="") () = 41 | let doc = "Authentication cookie"^doc_append in 42 | let env = Cmd.Env.info "GH_COOKIE" in 43 | map auth Arg.(value & opt string "infra" 44 | & info ~env ["c"] ~docv:"COOKIE" ~doc) 45 | -------------------------------------------------------------------------------- /jar/jar_cli.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 David Sheets 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | val repos : ?doc_append:string -> unit -> string list Cmdliner.Term.t 19 | val cookie : ?doc_append:string -> unit -> Github.Token.t Cmdliner.Term.t 20 | -------------------------------------------------------------------------------- /jar/jar_version.ml: -------------------------------------------------------------------------------- 1 | let t = "2.0.0" 2 | -------------------------------------------------------------------------------- /jar/list_events.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 David Sheets 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | open Lwt 19 | open Cmdliner 20 | open Printf 21 | 22 | let string_of_wiki_page_action = function 23 | | `Created -> "Created" 24 | | `Edited -> "Edited" 25 | | `Unknown cons -> "Unknown:"^cons 26 | 27 | let string_of_issue_comment_event_action = function 28 | | `Created -> "Created" 29 | | `Edited _ -> "Edited" 30 | | `Deleted -> "Deleted" 31 | | `Unknown (cons, _json) -> "Unknown:"^cons 32 | 33 | let string_of_issue user repo issue = Github_t.( 34 | sprintf "%s/%s#%d (%s)" user repo issue.issue_number issue.issue_title 35 | ) 36 | 37 | let string_of_issues_action = Github_j.string_of_issues_action 38 | 39 | let string_of_member_event_action = function 40 | | `Added -> "Added" 41 | | `Unknown cons -> "Unknown:"^cons 42 | 43 | let string_of_pull user repo number = sprintf "%s/%s#%d" user repo number 44 | 45 | let string_of_pull_request_action = Github_j.string_of_pull_request_action 46 | 47 | let string_of_pull_request_review_comment_action = function 48 | | `Created -> "Created" 49 | | `Edited _ -> "Edited" 50 | | `Deleted -> "Deleted" 51 | | `Unknown (cons, _json) -> "Unknown:"^cons 52 | 53 | let string_of_release_event_action = function 54 | | `Published -> "Published" 55 | | `Unknown cons -> "Unknown:"^cons 56 | 57 | let string_of_status_state = Github_j.string_of_status_state 58 | 59 | let string_of_watch_event_action = function 60 | | `Started -> "Started" 61 | | `Unknown cons -> "Unknown:"^cons 62 | 63 | let print_event event = 64 | let open Github_t in 65 | let user, repo = 66 | match Stringext.split ~max:2 ~on:'/' event.event_repo.repo_name with 67 | | user::repo::_ -> user, repo 68 | | [_] | [] -> failwith "nonsense repo name" 69 | in 70 | printf "#--> %s:" event.event_actor.user_login; 71 | (match event.event_payload with 72 | | `CommitComment { commit_comment_event_comment = comment } -> 73 | printf "CommitComment on %s/%s %s\n%!" 74 | user repo comment.commit_comment_commit_id 75 | | `Create { create_event_ref = `Repository; _ } -> 76 | printf "CreateEvent on repository %s/%s\n%!" user repo 77 | | `Create { create_event_ref = `Branch branch; _ } -> 78 | printf "CreateEvent on branch %s/%s %s\n%!" user repo branch 79 | | `Create { create_event_ref = `Tag tag; _ } -> 80 | printf "CreateEvent on tag %s/%s %s\n%!" user repo tag 81 | | `Delete { delete_event_ref = `Repository } -> 82 | printf "DeleteEvent on repository %s/%s\n%!" user repo 83 | | `Delete { delete_event_ref = `Branch branch } -> 84 | printf "DeleteEvent on branch %s/%s %s\n%!" user repo branch 85 | | `Delete { delete_event_ref = `Tag tag } -> 86 | printf "DeleteEvent on tag %s/%s %s\n%!" user repo tag 87 | | `Download -> printf "DownloadEvent deprecated\n%!" 88 | | `Follow -> printf "FollowEvent deprecated\n%!" 89 | | `Fork { fork_event_forkee = { repository_full_name; _ } } -> 90 | printf "ForkEvent on %s/%s to %s\n%!" user repo repository_full_name 91 | | `ForkApply -> printf "ForkApplyEvent deprecated\n%!" 92 | | `Gist -> printf "GistEvent deprecated\n%!" 93 | | `Gollum { gollum_event_pages } -> 94 | printf "GollumEvent on %s/%s: %s\n%!" user repo 95 | (String.concat ", " 96 | (List.map (fun { wiki_page_title; wiki_page_action; _ } -> 97 | (string_of_wiki_page_action wiki_page_action)^" "^wiki_page_title 98 | ) gollum_event_pages)) 99 | | `IssueComment { 100 | issue_comment_event_action; 101 | issue_comment_event_issue = issue; 102 | issue_comment_event_comment = comment; 103 | } -> 104 | printf "IssueCommentEvent %s on %s: %s\n%!" 105 | (string_of_issue_comment_event_action issue_comment_event_action) 106 | (string_of_issue user repo issue) comment.issue_comment_body 107 | | `Issues { issues_event_action = action; issues_event_issue = issue; _ } -> 108 | printf "IssuesEvent on %s: %s\n%!" 109 | (string_of_issue user repo issue) (string_of_issues_action action) 110 | | `Member { member_event_action; member_event_member = member } -> 111 | printf "MemberEvent %s on %s/%s: %s added\n%!" 112 | (string_of_member_event_action member_event_action) 113 | user repo member.linked_user_login 114 | | `Public -> 115 | printf "PublicEvent on %s/%s\n%!" user repo 116 | | `PullRequest { 117 | pull_request_event_action = action; 118 | pull_request_event_number; _ 119 | } -> 120 | printf "PullRequestEvent on %s: %s\n%!" 121 | (string_of_pull user repo pull_request_event_number) 122 | (string_of_pull_request_action action) 123 | | `PullRequestReviewComment { 124 | pull_request_review_comment_event_action = action; 125 | pull_request_review_comment_event_pull_request = pull; 126 | pull_request_review_comment_event_comment = comment; 127 | } -> 128 | printf "PullRequestReviewCommentEvent %s on %s: %s\n%!" 129 | (string_of_pull_request_review_comment_action action) 130 | (string_of_pull user repo pull.pull_number) 131 | comment.pull_request_review_comment_body 132 | | `Push { push_event_ref; push_event_size; _ } -> 133 | printf "PushEvent on %s/%s ref %s of %d commits\n%!" 134 | user repo push_event_ref push_event_size 135 | | `Release { release_event_action; release_event_release } -> 136 | printf "ReleaseEvent %s on %s/%s: %s\n%!" user repo 137 | (string_of_release_event_action release_event_action) 138 | release_event_release.release_tag_name 139 | | `Repository { 140 | repository_event_action; 141 | repository_event_repository = { 142 | repository_full_name; _ 143 | } 144 | } -> 145 | printf "RepositoryEvent %s on %s\n%!" 146 | (Github_j.string_of_repository_action repository_event_action) 147 | repository_full_name 148 | | `Status { status_event_state; status_event_sha; _ } -> 149 | printf "StatusEvent on %s/%s: %s %s\n%!" user repo status_event_sha 150 | (string_of_status_state status_event_state) 151 | | `Watch { watch_event_action } -> 152 | printf "WatchEvent %s on %s/%s\n%!" 153 | (string_of_watch_event_action watch_event_action) 154 | user repo 155 | | `Unknown (cons, _json) -> 156 | printf "UnknownEvent '%s'\n%!" cons 157 | ); 158 | return () 159 | 160 | let list_events token repos = 161 | let repos = List.map (fun r -> 162 | match Stringext.split ~max:2 ~on:'/' r with 163 | | [user;repo] -> (user,repo) 164 | | _ -> eprintf "Repositories must be in username/repo format"; exit 1 165 | ) repos in 166 | (* Get the events per repo *) 167 | begin 168 | Lwt_list.fold_left_s (fun a (user,repo) -> 169 | Github.(Monad.(run ( 170 | let events = Event.for_repo ~token ~user ~repo () in 171 | Stream.to_list events (* TODO: bound!??! *) 172 | ))) >>= fun r -> 173 | return (r @ a)) [] repos 174 | end >>= fun events -> 175 | Lwt_list.iter_s print_event events 176 | 177 | let cmd = 178 | let cookie = Jar_cli.cookie () in 179 | let repos = Jar_cli.repos ~doc_append:" to query for events" () in 180 | let doc = "list events on GitHub repositories" in 181 | let man = [ 182 | `S "BUGS"; 183 | `P "Email bug reports to ."; 184 | ] in 185 | let term = Term.((const (fun t r -> Lwt_main.run (list_events t r)) $ cookie $ repos)) in 186 | let info = Cmd.info "git-list-events" ~version:Jar_version.t ~doc ~man in 187 | Cmd.v info term 188 | 189 | let () = exit @@ Cmd.eval cmd 190 | -------------------------------------------------------------------------------- /jar/list_issues.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 David Sheets 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | open Cmdliner 19 | open Printf 20 | 21 | module T = Github_t 22 | 23 | let ask_github fn = Github.(Monad.run (fn ())) 24 | 25 | let string_of_labels labels = 26 | let names = List.map (fun { T.label_name; _ } -> label_name) labels in 27 | String.concat ", " names 28 | 29 | let print_issue user repo issue = 30 | let { 31 | T.issue_number; 32 | issue_title; 33 | issue_labels; 34 | issue_comments; 35 | issue_state; 36 | issue_created_at; 37 | issue_closed_at; 38 | _ 39 | } = issue in 40 | printf "%s/%s#%d %s\n" user repo issue_number issue_title; 41 | printf " Labels: %s\n" (string_of_labels issue_labels); 42 | printf " Comments: %d\n" issue_comments; 43 | (match issue_state with 44 | | `Open -> printf " Created at %s\n" issue_created_at 45 | | `Closed -> match issue_closed_at with 46 | | Some timestamp -> printf " Closed at %s\n" timestamp 47 | | None -> printf " Closed timestamp missing!" 48 | ) 49 | 50 | let list_issues token repos ~all ~closed ~prs ~issues = 51 | let repos = List.map (fun r -> 52 | match Stringext.split ~max:2 ~on:'/' r with 53 | | [user;repo] -> (user,repo) 54 | | _ -> eprintf "Repositories must be in username/repo format"; exit 1 55 | ) repos in 56 | (* Get the issues per repo *) 57 | Lwt_list.iter_s (fun (user,repo) -> 58 | let state = if all then `All else if closed then `Closed else `Open in 59 | Github.(Monad.(run ( 60 | let issues_s = Issue.for_repo ~token ~state ~user ~repo () in 61 | Stream.to_list issues_s (* TODO: bound?!?! *) 62 | >>= fun list -> return (List.iter (fun i -> match i with 63 | | { T.issue_pull_request = None; _ } when issues -> 64 | print_issue user repo i 65 | | { T.issue_pull_request = Some _; _ } when prs -> 66 | print_issue user repo i 67 | | _ -> () 68 | ) list)))) 69 | ) repos 70 | 71 | let cmd = 72 | let cookie = Jar_cli.cookie () in 73 | let repos = Jar_cli.repos ~doc_append:" to list issues and PRs" () in 74 | 75 | let doc = "show only closed issues" in 76 | let docv = "CLOSED" in 77 | let closed = Arg.(value & flag & info ["closed"] ~docv ~doc) in 78 | let doc = "show all issues" in 79 | let docv = "ALL" in 80 | let all = Arg.(value & flag & info ["all"] ~docv ~doc) in 81 | 82 | let doc = "show PRs" in 83 | let docv = "PRS" in 84 | let no_prs = Arg.(value & flag & info ["prs"] ~docv ~doc) in 85 | let doc = "show regular (non-PR) issues" in 86 | let docv = "ISSUES" in 87 | let no_issues = Arg.(value & flag & info ["issues"] ~docv ~doc) in 88 | 89 | let doc = "list issues on GitHub repositories (open only by default)" in 90 | let man = [ 91 | `S "BUGS"; 92 | `P "Email bug reports to ."; 93 | ] in 94 | let term = Term.((const (fun t r all closed prs_flag issues_flag -> 95 | let prs = prs_flag || (not issues_flag) in 96 | let issues = issues_flag || (not prs_flag) in 97 | Lwt_main.run (list_issues t r ~all ~closed ~prs ~issues) 98 | ) $ cookie $ repos $ all $ closed $ no_prs $ no_issues)) in 99 | let info = Cmd.info "git-list-issues" ~version:Jar_version.t ~doc ~man in 100 | Cmd.v info term 101 | 102 | let () = exit @@ Cmd.eval cmd 103 | -------------------------------------------------------------------------------- /jar/list_releases.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Anil Madhavapeddy 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | open Lwt 19 | open Cmdliner 20 | open Printf 21 | 22 | let parse_iso8601_from_github t = 23 | (* This parses just a subset of ISO8601 that GitHub returns: 24 | e.g. 2014-02-21T13:39:04Z *) 25 | Scanf.sscanf t "%4d-%2d-%2dT%2d:%2d:%2dZ" 26 | (fun tm_year tm_mon tm_mday tm_hour tm_min tm_sec -> 27 | (Unix.(mktime {tm_year=tm_year-1900; tm_mon=tm_mon-1; tm_mday; tm_hour; 28 | tm_min; tm_sec; tm_wday=0; tm_yday=0; tm_isdst=false}))) 29 | 30 | let release_to_markdown (user,repo,r) = 31 | let open Github_t in 32 | let (_,tm) = parse_iso8601_from_github r.release_created_at in 33 | let name = match r.release_name with Some name -> name | None -> "NULL" in 34 | printf "### %s-%s: %s\n\n" repo r.release_tag_name name; 35 | printf "Released on %4d-%02d-%02d as [%s](%s). See for full history.\n\n" 36 | (tm.Unix.tm_year+1900) (tm.Unix.tm_mon+1) tm.Unix.tm_mday r.release_tag_name r.release_html_url user repo; 37 | match r.release_body with 38 | | None -> printf "NULL\n\n"; return_unit 39 | | Some "" -> return_unit 40 | | Some body -> 41 | printf "%s\n\n" body; 42 | return () 43 | 44 | let releases_to_json rs = 45 | print_endline ( 46 | Github_j.string_of_release_repos ( 47 | List.map (fun (release_repo_user,release_repo_repo,release_repo_release) -> 48 | { Github_j.release_repo_user;release_repo_repo;release_repo_release } 49 | ) rs) 50 | ) 51 | 52 | let list_releases token repos json = 53 | let repos = List.map (fun r -> 54 | match Stringext.split ~max:2 ~on:'/' r with 55 | | [user;repo] -> (user,repo) 56 | | _ -> eprintf "Repositories must be in username/repo format (e.g. mirage/ocaml-cohttp\n"; exit 1 57 | ) repos in 58 | (* Get the releases per repo *) 59 | begin 60 | Lwt_list.fold_left_s (fun a (user,repo) -> 61 | Github.(Monad.(run ( 62 | let releases = Release.for_repo ~token ~user ~repo () in 63 | Stream.to_list releases 64 | ))) >>= fun r -> 65 | return ((List.map (fun r -> (user,repo,r)) r) @ a)) [] repos 66 | end >>= fun releases -> 67 | (* Sort them by tag creation date *) 68 | let rtime (_,_,r) = fst (parse_iso8601_from_github r.Github_t.release_created_at) in 69 | let releases = List.sort (fun b a -> compare (rtime a) (rtime b)) releases in 70 | match json with 71 | | false -> Lwt_list.iter_s release_to_markdown releases 72 | | true -> releases_to_json releases; return_unit 73 | 74 | let cmd = 75 | let cookie = Jar_cli.cookie () in 76 | let repos = Jar_cli.repos ~doc_append:" to scan for changelogs" () in 77 | let doc = "list releases on GitHub repositories" in 78 | let man = [ `S "BUGS"; `P "Email bug reports to .";] in 79 | let json = 80 | let doc = "Output in JSON format." in 81 | Arg.(value & flag & info ["json"] ~doc) in 82 | let term = Term.((const (fun t r j -> Lwt_main.run (list_releases t r j )) $ cookie $ repos $ json)) in 83 | let info = Cmd.info "git-list-releases" ~version:Jar_version.t ~doc ~man in 84 | Cmd.v info term 85 | 86 | let () = exit @@ Cmd.eval cmd 87 | -------------------------------------------------------------------------------- /jar/listen_events.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 David Sheets 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | open Lwt 19 | open Cmdliner 20 | open Printf 21 | 22 | let string_of_wiki_page_action = function 23 | | `Created -> "Created" 24 | | `Edited -> "Edited" 25 | | `Unknown cons -> "Unknown:"^cons 26 | 27 | let string_of_issue_comment_event_action = function 28 | | `Created -> "Created" 29 | | `Edited _ -> "Edited" 30 | | `Deleted -> "Deleted" 31 | | `Unknown (cons, _json) -> "Unknown:"^cons 32 | 33 | let string_of_issue user repo issue = Github_t.( 34 | sprintf "%s/%s#%d (%s)" user repo issue.issue_number issue.issue_title 35 | ) 36 | 37 | let string_of_issues_action = Github_j.string_of_issues_action 38 | 39 | let string_of_member_event_action = function 40 | | `Added -> "Added" 41 | | `Unknown cons -> "Unknown:"^cons 42 | 43 | let string_of_pull user repo number = sprintf "%s/%s#%d" user repo number 44 | 45 | let string_of_pull_request_action = Github_j.string_of_pull_request_action 46 | 47 | let string_of_pull_request_review_comment_action = function 48 | | `Created -> "Created" 49 | | `Edited _ -> "Edited" 50 | | `Deleted -> "Deleted" 51 | | `Unknown (cons, _json) -> "Unknown:"^cons 52 | 53 | let string_of_release_event_action = function 54 | | `Published -> "Published" 55 | | `Unknown cons -> "Unknown:"^cons 56 | 57 | let string_of_status_state = Github_j.string_of_status_state 58 | 59 | let string_of_watch_event_action = function 60 | | `Started -> "Started" 61 | | `Unknown cons -> "Unknown:"^cons 62 | 63 | let print_event event = 64 | let open Github_t in 65 | let user, repo = 66 | match Stringext.split ~max:2 ~on:'/' event.event_repo.repo_name with 67 | | user::repo::_ -> user, repo 68 | | [_] | [] -> failwith "nonsense repo name" 69 | in 70 | printf "#--> %s:" event.event_actor.user_login; 71 | (match event.event_payload with 72 | | `CommitComment { commit_comment_event_comment = comment } -> 73 | printf "CommitComment on %s/%s %s\n%!" 74 | user repo comment.commit_comment_commit_id 75 | | `Create { create_event_ref = `Repository; _ } -> 76 | printf "CreateEvent on repository %s/%s\n%!" user repo 77 | | `Create { create_event_ref = `Branch branch; _ } -> 78 | printf "CreateEvent on branch %s/%s %s\n%!" user repo branch 79 | | `Create { create_event_ref = `Tag tag; _ } -> 80 | printf "CreateEvent on tag %s/%s %s\n%!" user repo tag 81 | | `Delete { delete_event_ref = `Repository } -> 82 | printf "DeleteEvent on repository %s/%s\n%!" user repo 83 | | `Delete { delete_event_ref = `Branch branch } -> 84 | printf "DeleteEvent on branch %s/%s %s\n%!" user repo branch 85 | | `Delete { delete_event_ref = `Tag tag } -> 86 | printf "DeleteEvent on tag %s/%s %s\n%!" user repo tag 87 | | `Download -> printf "DownloadEvent deprecated\n%!" 88 | | `Follow -> printf "FollowEvent deprecated\n%!" 89 | | `Fork { fork_event_forkee = { repository_full_name; _ } } -> 90 | printf "ForkEvent on %s/%s to %s\n%!" user repo repository_full_name 91 | | `ForkApply -> printf "ForkApplyEvent deprecated\n%!" 92 | | `Gist -> printf "GistEvent deprecated\n%!" 93 | | `Gollum { gollum_event_pages } -> 94 | printf "GollumEvent on %s/%s: %s\n%!" user repo 95 | (String.concat ", " 96 | (List.map (fun { wiki_page_title; wiki_page_action; _ } -> 97 | (string_of_wiki_page_action wiki_page_action)^" "^wiki_page_title 98 | ) gollum_event_pages)) 99 | | `IssueComment { 100 | issue_comment_event_action; 101 | issue_comment_event_issue = issue; 102 | issue_comment_event_comment = comment; 103 | } -> 104 | printf "IssueCommentEvent %s on %s: %s\n%!" 105 | (string_of_issue_comment_event_action issue_comment_event_action) 106 | (string_of_issue user repo issue) comment.issue_comment_body 107 | | `Issues { issues_event_action = action; issues_event_issue = issue; _ } -> 108 | printf "IssuesEvent on %s: %s\n%!" 109 | (string_of_issue user repo issue) (string_of_issues_action action) 110 | | `Member { member_event_action; member_event_member = member } -> 111 | printf "MemberEvent %s on %s/%s: %s added\n%!" 112 | (string_of_member_event_action member_event_action) 113 | user repo member.linked_user_login 114 | | `Public -> 115 | printf "PublicEvent on %s/%s\n%!" user repo 116 | | `PullRequest { 117 | pull_request_event_action = action; 118 | pull_request_event_number; _ 119 | } -> 120 | printf "PullRequestEvent on %s: %s\n%!" 121 | (string_of_pull user repo pull_request_event_number) 122 | (string_of_pull_request_action action) 123 | | `PullRequestReviewComment { 124 | pull_request_review_comment_event_action = action; 125 | pull_request_review_comment_event_pull_request = pull; 126 | pull_request_review_comment_event_comment = comment; 127 | } -> 128 | printf "PullRequestReviewCommentEvent %s on %s: %s\n%!" 129 | (string_of_pull_request_review_comment_action action) 130 | (string_of_pull user repo pull.pull_number) 131 | comment.pull_request_review_comment_body 132 | | `Push { push_event_ref; push_event_size; _ } -> 133 | printf "PushEvent on %s/%s ref %s of %d commits\n%!" 134 | user repo push_event_ref push_event_size 135 | | `Release { release_event_action; release_event_release } -> 136 | printf "ReleaseEvent %s on %s/%s: %s\n%!" user repo 137 | (string_of_release_event_action release_event_action) 138 | release_event_release.release_tag_name 139 | | `Repository { 140 | repository_event_action; 141 | repository_event_repository = { 142 | repository_full_name; _ 143 | }; 144 | } -> 145 | printf "RepositoryEvent %s on %s\n%!" 146 | (Github_j.string_of_repository_action repository_event_action) 147 | repository_full_name 148 | | `Status { status_event_state; status_event_sha; _ } -> 149 | printf "StatusEvent on %s/%s: %s %s\n%!" user repo status_event_sha 150 | (string_of_status_state status_event_state) 151 | | `Watch { watch_event_action } -> 152 | printf "WatchEvent %s on %s/%s\n%!" 153 | (string_of_watch_event_action watch_event_action) 154 | user repo 155 | | `Unknown (cons, _json) -> 156 | printf "UnknownEvent '%s'\n%!" cons 157 | ); 158 | return () 159 | 160 | let listen ~token user repo s () = 161 | Lwt_io.printf "listening for events on %s/%s\n" user repo 162 | >>= fun () -> 163 | let rec loop s = Github.(Monad.( 164 | Stream.poll s 165 | >>= fun stream_opt -> 166 | API.get_rate_remaining ~token () 167 | >>= fun remaining -> 168 | let now = Unix.gettimeofday () in 169 | match stream_opt with 170 | | None -> 171 | embed 172 | (Lwt_io.printf "%f no new events on %s/%s (%d)\n" 173 | now user repo remaining 174 | ) 175 | >>= fun () -> loop s 176 | | Some s -> 177 | embed 178 | (Lwt_io.printf "%f new events on %s/%s (%d)\n" 179 | now user repo remaining 180 | ) 181 | >>= fun () -> loop s 182 | )) in 183 | Github.Monad.run (loop s) 184 | 185 | let listen_events token repos = 186 | let repos = List.map (fun r -> 187 | match Stringext.split ~max:2 ~on:'/' r with 188 | | [user;repo] -> (user,repo) 189 | | _ -> eprintf "Repositories must be in username/repo format"; exit 1 190 | ) repos in 191 | (* Get the events per repo *) 192 | Lwt_list.iter_s (fun (user,repo) -> Github.(Monad.(run ( 193 | let events = Event.for_repo ~token ~user ~repo () in 194 | Stream.next events 195 | >|= function 196 | | Some (_,s) -> async (listen ~token user repo s) 197 | | None -> assert false 198 | )))) repos >>= fun _events -> 199 | let forever, _wakener = Lwt.wait () in 200 | forever 201 | 202 | let cmd = 203 | let cookie = Jar_cli.cookie () in 204 | let repos = Jar_cli.repos ~doc_append:" to query for events" () in 205 | let doc = "listen to events on GitHub repositories" in 206 | let man = [ 207 | `S "BUGS"; 208 | `P "Email bug reports to ."; 209 | ] in 210 | let term = Term.((const (fun t r -> Lwt_main.run (listen_events t r)) $ cookie $ repos)) in 211 | let info = Cmd.info "git-listen-events" ~version:Jar_version.t ~doc ~man in 212 | Cmd.v info term 213 | 214 | let () = exit @@ Cmd.eval cmd 215 | -------------------------------------------------------------------------------- /jar/search.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 David Sheets 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | open Cmdliner 19 | 20 | module T = Github_t 21 | 22 | let help_sections = [ 23 | `S "BUGS"; 24 | `P "Email bug reports to ."; 25 | ] 26 | 27 | let print_repository ({ 28 | T.repository_full_name; 29 | repository_description; 30 | repository_stargazers_count; 31 | repository_language; 32 | repository_html_url; 33 | _ 34 | }) = 35 | let language = match repository_language with 36 | | None -> "" 37 | | Some lang -> " ("^lang^")" 38 | in 39 | Lwt_io.printf "%s%s [%d stars]\n<%s>\n%s\n\n" repository_full_name language 40 | repository_stargazers_count 41 | repository_html_url 42 | (match repository_description with None -> "" | Some d -> d) 43 | 44 | let search token ?language ?sort keywords = 45 | let basic_qs = [`In [`Name; `Description; `Readme]] in 46 | let qualifiers = match language with 47 | | None -> basic_qs 48 | | Some lang -> (`Language lang)::basic_qs 49 | in 50 | Github.(Monad.(run ( 51 | let results = Github.Search.repos ~token ?sort ~qualifiers ~keywords () in 52 | Stream.next results (* TODO: option for count? *) 53 | >>= function 54 | | Some ({ T.repository_search_items; 55 | repository_search_total_count; _ }, _) -> 56 | embed (Lwt_io.printf "%d results returned of %d total\n\n" 57 | (List.length repository_search_items) 58 | repository_search_total_count) 59 | >>= fun () -> 60 | embed (Lwt_list.iter_s print_repository repository_search_items) 61 | | None -> 62 | embed (Lwt_io.printf "No more results.\n\n") 63 | ))) 64 | 65 | let repo_cmd = 66 | let cookie = Jar_cli.cookie () in 67 | 68 | let doc = "sort by stars, forks, updated, or magic (default)" in 69 | let docv = "SORTBY" in 70 | let sort = Arg.(value & opt (enum [ 71 | "stars",Some `Stars; 72 | "forks",Some `Forks; 73 | "updated",Some `Updated; 74 | "magic",None; 75 | ]) None & info ["sort"] ~docv ~doc) in 76 | 77 | let doc = "language filter" in 78 | let docv = "LANGUAGE" in 79 | let language = Arg.( 80 | value & opt (some string) None & info ["language"] ~docv ~doc 81 | ) in 82 | 83 | let doc = "keywords" in 84 | let docv = "KEYWORDS" in 85 | let keywords = Arg.(value & pos_all string [] & info [] ~docv ~doc) in 86 | 87 | let doc = "search GitHub repositories" in 88 | let man = help_sections in 89 | let term = Term.((const (fun t language keywords sort -> 90 | Lwt_main.run (search t ?language ?sort keywords) 91 | ) $ cookie $ language $ keywords $ sort)) in 92 | let info = Cmd.info "repo" ~version:Jar_version.t ~doc ~man in 93 | Cmd.v info term 94 | 95 | let group = 96 | let doc = "search GitHub" in 97 | let man = [ 98 | `S "DESCRIPTION"; 99 | `P ("$(b, git search) searches GitHub for repositories, code, \ 100 | issues, or users."); 101 | ] @ help_sections in 102 | let no_cmd_err = `Error (true, "No search object type given.") in 103 | let default = Term.(ret (const no_cmd_err)) in 104 | let info = Cmd.info "git-search" ~doc ~man in 105 | Cmd.group ~default info [repo_cmd] 106 | 107 | let () = exit @@ Cmd.eval group 108 | -------------------------------------------------------------------------------- /jar/sync_releases.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Anil Madhavapeddy 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | open Lwt 19 | open Cmdliner 20 | open Printf 21 | 22 | let sync_releases token src_user src_repo dst_user dst_repo = 23 | Github.(Monad.(run ( 24 | let releases = Release.for_repo ~token ~user:src_user ~repo:src_repo () in 25 | Stream.to_list releases 26 | ))) >>= fun src -> 27 | (* TODO: unused?? *) 28 | Github.(Monad.(run ( 29 | let releases = Release.for_repo ~token ~user:dst_user ~repo:dst_repo () in 30 | Stream.to_list releases 31 | ))) >>= fun _dst -> 32 | Github.(Monad.(run ( 33 | let releases = Repo.tags ~token ~user:src_user ~repo:src_repo () in 34 | Stream.to_list releases 35 | ))) >>= fun src_tags -> 36 | let open Github_t in 37 | Lwt_list.iter_s (fun r -> 38 | let tag = List.find (fun x -> x.repo_tag_name = r.release_tag_name) src_tags in 39 | let _target = match r.release_target_commitish with 40 | | None -> "master" 41 | | Some t -> t 42 | in 43 | let sha = tag.repo_tag_commit.repo_commit_sha in 44 | let name = match r.release_name with Some name -> name | None -> "NULL" in 45 | printf "%s %s %s %b %b\n" 46 | r.release_tag_name 47 | sha 48 | name r.release_draft r.release_prerelease; 49 | let release = { 50 | new_release_tag_name=r.release_tag_name; 51 | new_release_target_commitish=sha; 52 | new_release_name=r.release_name; 53 | new_release_body=r.release_body; 54 | new_release_draft=r.release_draft; 55 | new_release_prerelease=r.release_prerelease; 56 | } in 57 | print_endline (Github_j.string_of_new_release release); 58 | Github.(Monad.(run ( 59 | Release.create ~token ~user:dst_user ~repo:dst_repo ~release () 60 | ))) >>= fun _r -> 61 | return_unit 62 | ) src 63 | 64 | let run token src_user src_repo dst_user dst_repo = 65 | Lwt_main.run (sync_releases token src_user src_repo dst_user dst_repo) 66 | 67 | let cmd = 68 | let cookie = Jar_cli.cookie () in 69 | let src_user = 70 | let doc = "The source user name on GitHub" in 71 | Arg.(required & pos 0 (some string) None & info [] ~docv:"SRC_USER" ~doc) 72 | in 73 | let src_repo = 74 | let doc = "The source repository on GitHub" in 75 | Arg.(required & pos 1 (some string) None & info [] ~docv:"SRC_REPO" ~doc) 76 | in 77 | let dst_user = 78 | let doc = "The destination user name on GitHub" in 79 | Arg.(required & pos 2 (some string) None & info [] ~docv:"DST_USER" ~doc) 80 | in 81 | let dst_repo = 82 | let doc = "The destination repository on GitHub" in 83 | Arg.(required & pos 3 (some string) None & info [] ~docv:"DST_REPO" ~doc) 84 | in 85 | let doc = "synchronize releases between GitHub repositories" in 86 | let man = [ `S "BUGS"; `P "Email bug reports to .";] in 87 | let term = Term.((const run $ cookie $ src_user $ src_repo $ dst_user $ dst_repo)) in 88 | let info = Cmd.info "git-sync-releases" ~version:Jar_version.t ~doc ~man in 89 | Cmd.v info term 90 | 91 | let () = exit @@ Cmd.eval cmd 92 | -------------------------------------------------------------------------------- /jar/upload_release.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Anil Madhavapeddy 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | open Lwt 19 | open Cmdliner 20 | open Printf 21 | 22 | let ask_github fn = Github.(Monad.run (fn ())) 23 | 24 | let upload_release token user repo tag content_type filename = 25 | let open Github_t in 26 | ask_github (Github.Release.get_by_tag_name ~token ~user ~repo ~tag) >|= Github.Response.value 27 | >>= fun r -> 28 | let id = r.release_id in 29 | print_endline (sprintf "uploading to release id %Ld" id); 30 | begin 31 | Lwt_io.file_length filename >|= Int64.to_int >>= fun len -> 32 | let buf = Bytes.create len in 33 | Lwt_io.with_file ~mode:Lwt_io.input filename 34 | (fun ic -> Lwt_io.read_into_exactly ic buf 0 len) 35 | >>= fun () -> return buf 36 | end >>= fun body -> 37 | let body = Bytes.to_string body in 38 | ask_github (Github.Release.upload_asset 39 | ~token ~user ~repo ~id ~filename ~content_type ~body) 40 | >>= fun _a -> 41 | return_unit 42 | 43 | let run token user repo tag content_type filename = 44 | Lwt_main.run (upload_release token user repo tag content_type filename) 45 | 46 | let cmd = 47 | let cookie = Jar_cli.cookie () in 48 | let user = 49 | let doc = "The user name on GitHub" in 50 | Arg.(required & pos 0 (some string) None & info [] ~docv:"USER" ~doc) 51 | in 52 | let repo = 53 | let doc = "The repository name on GitHub" in 54 | Arg.(required & pos 1 (some string) None & info [] ~docv:"REPO" ~doc) 55 | in 56 | let tag = 57 | let doc = "The release tag name on GitHub" in 58 | Arg.(required & pos 2 (some string) None & info [] ~docv:"TAG" ~doc) 59 | in 60 | let filename = 61 | let doc = "The filename to upload" in 62 | Arg.(required & pos 3 (some string) None & info [] ~docv:"FILENAME" ~doc) 63 | in 64 | let content_type = 65 | let doc = "The MIME content-type of the file. Defaults to application/octet-stream, but something more specific is recommended." in 66 | Arg.(value & pos 4 string "application/octet-stream" & info [] ~docv:"CONTENT_TYPE" ~doc) 67 | in 68 | let doc = "upload a release asset to a GitHub repository" in 69 | let man = [ `S "BUGS"; `P "Email bug reports to .";] in 70 | let term = Term.((const run $ cookie $ user $ repo $ tag $ content_type $ filename)) in 71 | let info = Cmd.info "git-upload-release" ~version:Jar_version.t ~doc ~man in 72 | Cmd.v info term 73 | 74 | let () = exit @@ Cmd.eval cmd 75 | -------------------------------------------------------------------------------- /js/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name github_jsoo) 3 | (public_name github-jsoo) 4 | (wrapped false) 5 | (libraries github js_of_ocaml-lwt cohttp-lwt-jsoo)) 6 | -------------------------------------------------------------------------------- /js/github.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Andy Ray 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | module Time = struct 19 | let now = Unix.gettimeofday 20 | let sleep = Js_of_ocaml_lwt.Lwt_js.sleep 21 | end 22 | 23 | module Env = struct 24 | let debug = false 25 | end 26 | 27 | module Github' = Github_core.Make(Env)(Time)(Cohttp_lwt_jsoo.Client) 28 | include Github' 29 | 30 | -------------------------------------------------------------------------------- /js/github.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Andy Ray 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | 19 | include Github_s.Github 20 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name github) 3 | (wrapped false) 4 | (modules_without_implementation github_s) 5 | (libraries cohttp uri cohttp-lwt yojson github-data)) 6 | -------------------------------------------------------------------------------- /lib/github_core.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012-2014 Anil Madhavapeddy 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | (** Portable functor to the GitHub API. 19 | 20 | The [Cohttp_lwt.Client] interface can be satisfied by a normal 21 | [Cohttp_lwt_unix.Client], but also by the JavaScript Cohttp 22 | client for use in a browser. *) 23 | 24 | module Make(Env: Github_s.Env)(Time: Github_s.Time)(CL : Cohttp_lwt.S.Client) 25 | : Github_s.Github 26 | -------------------------------------------------------------------------------- /lib_data/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name github-data) 3 | (name github_data) 4 | (wrapped false) 5 | (modules github_t github_j github_json) 6 | (libraries yojson atdgen)) 7 | 8 | (rule 9 | (targets github_t.ml github_t.mli) 10 | (action 11 | (run atdgen -t %{dep:github.atd}))) 12 | 13 | (rule 14 | (targets github_j.ml github_j.mli) 15 | (action 16 | (run atdgen -j -j-std %{dep:github.atd}))) 17 | -------------------------------------------------------------------------------- /lib_data/github_json.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Adapters used by atdgen to turn Github's representation of variants 3 | into an ATD-compatible representation. 4 | *) 5 | module Adapter = struct 6 | module Ref = 7 | Atdgen_runtime.Json_adapter.Type_and_value_fields.Make (struct 8 | let type_field_name = "ref_type" 9 | let value_field_name = "ref" 10 | let known_tags = None 11 | end) 12 | 13 | module Payload = 14 | Atdgen_runtime.Json_adapter.Type_and_value_fields.Make (struct 15 | let type_field_name = "type" 16 | let value_field_name = "payload" 17 | let known_tags = None 18 | end) 19 | 20 | module Issue_comment_event = 21 | Atdgen_runtime.Json_adapter.Type_and_value_fields.Make (struct 22 | let type_field_name = "action" 23 | let value_field_name = "changes" 24 | let known_tags = 25 | Some (["created"; "edited"; "deleted"], "Unknown") 26 | end) 27 | 28 | module Issues_event = 29 | Atdgen_runtime.Json_adapter.Type_and_value_fields.Make (struct 30 | let type_field_name = "action" 31 | let value_field_name = "changes" 32 | let known_tags = 33 | Some ( 34 | [ 35 | "assigned"; 36 | "unassigned"; 37 | "labeled"; 38 | "unlabeled"; 39 | "opened"; 40 | "edited"; 41 | "closed"; 42 | "reopened"; 43 | ], 44 | "Unknown" 45 | ) 46 | end) 47 | 48 | module Pull_request_event = 49 | Atdgen_runtime.Json_adapter.Type_and_value_fields.Make (struct 50 | let type_field_name = "action" 51 | let value_field_name = "changes" 52 | let known_tags = 53 | Some ( 54 | [ 55 | "assigned"; 56 | "unassigned"; 57 | "labeled"; 58 | "unlabeled"; 59 | "opened"; 60 | "edited"; 61 | "closed"; 62 | "reopened"; 63 | "synchronize"; 64 | ], 65 | "Unknown" 66 | ) 67 | end) 68 | 69 | module Pull_request_review_comment_event = 70 | Atdgen_runtime.Json_adapter.Type_and_value_fields.Make (struct 71 | let type_field_name = "action" 72 | let value_field_name = "changes" 73 | let known_tags = 74 | Some (["created"; "edited"; "deleted"], "Unknown") 75 | end) 76 | 77 | module Event = 78 | Atdgen_runtime.Json_adapter.Type_and_value_fields.Make (struct 79 | let type_field_name = "type" 80 | let value_field_name = "payload" 81 | let known_tags = 82 | Some ( 83 | [ 84 | "CommitCommentEvent"; 85 | "CreateEvent"; 86 | "DeleteEvent"; 87 | "DownloadEvent"; 88 | "FollowEvent"; 89 | "ForkEvent"; 90 | "ForkApplyEvent"; 91 | "GistEvent"; 92 | "GollumEvent"; 93 | "IssueCommentEvent"; 94 | "IssuesEvent"; 95 | "MemberEvent"; 96 | "PublicEvent"; 97 | "PullRequestEvent"; 98 | "PullRequestReviewCommentEvent"; 99 | "PushEvent"; 100 | "ReleaseEvent"; 101 | "RepositoryEvent"; 102 | "StatusEvent"; 103 | "WatchEvent"; 104 | ], 105 | "Unknown" 106 | ) 107 | end) 108 | 109 | module Hook = 110 | Atdgen_runtime.Json_adapter.Type_and_value_fields.Make (struct 111 | let type_field_name = "name" 112 | let value_field_name = "config" 113 | let known_tags = Some (["web"], "Unknown") 114 | end) 115 | end 116 | 117 | -------------------------------------------------------------------------------- /lib_test/checks.ml: -------------------------------------------------------------------------------- 1 | open Cmdliner 2 | 3 | let token = Config.access_token 4 | 5 | let list_check_runs_for_ref owner repo sha () = 6 | Lwt_main.run begin 7 | let open Github in 8 | let open Monad in 9 | run ( 10 | Check.list_check_runs_for_ref ~token ~owner ~repo ~sha () 11 | >>~ fun check -> 12 | (List.iter (fun x -> Printf.printf "check_run_name %s check_run_id %Ld\n" x.Github_j.check_run_name x.Github_j.check_run_id) check.Github_j.check_runs); 13 | return () 14 | ) 15 | end 16 | 17 | let get_check_run owner repo check_run_id () = 18 | Lwt_main.run begin 19 | let open Github in 20 | let open Monad in 21 | run ( 22 | Check.get_check_run ~token ~owner ~repo ~check_run_id () 23 | >>~ fun check_run -> 24 | Printf.printf "check_run_name %s check_run_id %s\n" check_run.Github_j.check_run_name (Github_j.string_of_check_status check_run.Github_j.check_run_status); 25 | return () 26 | ) 27 | end 28 | 29 | module CommandLine = struct 30 | let repo = 31 | let doc = "Repository" in 32 | Arg.(required 33 | & opt (some string) None 34 | & info ["r"; "repository"] ~docv:"REPOSITORY" ~doc) 35 | 36 | let owner = 37 | let doc = "Owner" in 38 | Arg.(required 39 | & opt (some string) None 40 | & info ["o"; "owner"] ~docv:"OWNER" ~doc) 41 | 42 | let sha = 43 | let doc = "Git SHA" in 44 | Arg.(required 45 | & opt (some string) None 46 | & info ["s"; "sha"] ~docv:"GIT_SHA" ~doc) 47 | 48 | let check_run_id = 49 | let doc = "Check Run Id" in 50 | Arg.(required 51 | & opt (some string) None 52 | & info ["c"; "check_run_id"] ~docv:"CHECK_RUN_ID" ~doc) 53 | 54 | let list_cmd = 55 | let term = Term.(const list_check_runs_for_ref $ owner $ repo $ sha $ const ()) in 56 | let info = Cmd.info "list" ~doc:"List Check Runs for a git sha" in 57 | Cmd.v info term 58 | 59 | let get_check_run = 60 | let term = Term.(const get_check_run $ owner $ repo $ check_run_id $ const ()) in 61 | let info = Cmd.info "get-check" ~doc:"Get a Check Run for check run id" in 62 | Cmd.v info term 63 | 64 | let cmds = 65 | let default = Term.(ret (const (`Help (`Pager, None)))) in 66 | let default_info = Cmd.info "checks" ~version:"0.1" ~doc:"Github Checks API." in 67 | Cmd.group ~default default_info [get_check_run; list_cmd] 68 | end 69 | 70 | let cmdliner = 71 | exit @@ Cmd.eval CommandLine.cmds 72 | -------------------------------------------------------------------------------- /lib_test/config.ml.in: -------------------------------------------------------------------------------- 1 | (* Information from https://github.com/settings/applications *) 2 | let client_id = "" 3 | let client_secret = "" 4 | 5 | (* Use lib_test/get_token with these Github credentials set to 6 | obtain an oAuth token *) 7 | let user = "" 8 | let pass = "" 9 | 10 | (* Put in the valid oAuth token here for the post-auth tests, 11 | * such as lib_test/create_issue *) 12 | let access_token = Github.Token.of_string "" 13 | -------------------------------------------------------------------------------- /lib_test/contributors.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | open Github_t 3 | 4 | let user = "ocaml" 5 | let repo = "opam-repository" 6 | 7 | let get_auth_token_from_jar auth_id = Lwt.( 8 | Github_cookie_jar.init () >>= fun jar -> 9 | Github_cookie_jar.(get ~name:auth_id jar) >>= function 10 | | Some x -> return x 11 | | None -> Lwt.fail (Failure ("id '"^auth_id^"' not in cookie jar")) 12 | ) 13 | 14 | let last_seen = 15 | List.fold_left 16 | (fun last { Github_t.repo_contribution_week_w = w; 17 | repo_contribution_week_a = a; 18 | repo_contribution_week_d = d; 19 | repo_contribution_week_c = c; 20 | } -> 21 | let active = a <> 0 || d <> 0 || c <> 0 in 22 | match last with 23 | | None -> if active then Some w else last 24 | | Some last_week when w > last_week -> if active then Some w else last 25 | | Some _ -> last 26 | ) None 27 | 28 | let month_of_time_opt = function 29 | | None -> "never" 30 | | Some time -> 31 | input_line (Unix.open_process_in (sprintf "date -r %d +%%Y-%%m" time)) 32 | 33 | let space_after s = String.init (20 - String.length s) (fun _ -> ' ') 34 | 35 | let t = Github.(Monad.(run ( 36 | embed (get_auth_token_from_jar "test") 37 | >>= fun auth -> 38 | let token = Token.of_auth auth in 39 | let contributors = Repo.contributors ~token ~user ~repo () in 40 | Stream.to_list contributors 41 | >>= fun contributors -> 42 | let table = Hashtbl.create 256 in 43 | List.iter (fun c -> 44 | Hashtbl.replace table c.contributor_login c.contributor_contributions 45 | ) contributors; 46 | let contributor_stats = Stats.contributors ~token ~user ~repo () in 47 | Stream.to_list contributor_stats 48 | >|= List.rev 49 | >>= function 50 | | [] -> 51 | eprintf "No contributors found OR data not yet computed and cached."; 52 | return () 53 | | stats -> 54 | printf "login%s:\ttotal commits in %s/%s\t:\tlast month of contribution\n" 55 | (space_after "login") user repo; 56 | List.iter (fun c -> 57 | match c.repo_contributor_stats_author with 58 | | Some author -> 59 | let user = author.user_login in 60 | let from_table = 61 | try string_of_int (Hashtbl.find table user) 62 | with Not_found -> "?" 63 | in 64 | let commits = 65 | sprintf "%d (%s)" c.repo_contributor_stats_total from_table 66 | in 67 | printf "%s%s:\t%s%s:\t%s\n" 68 | user 69 | (space_after user) 70 | commits 71 | (space_after commits) 72 | (month_of_time_opt (last_seen c.repo_contributor_stats_weeks)); 73 | Hashtbl.remove table user 74 | | None -> () 75 | ) stats; 76 | let remaining = Hashtbl.fold (fun k v l -> (k, v)::l) table [] in 77 | let remaining = List.sort (fun (_,x) (_,y) -> compare y x) remaining in 78 | List.iter (fun (k, v) -> 79 | let commits = sprintf "! (%d)" v in 80 | printf "%s%s:\t%s%s:\t?\n" 81 | k (space_after k) 82 | commits (space_after commits) 83 | ) remaining; 84 | return () 85 | ))) 86 | 87 | ;; 88 | 89 | try Lwt_main.run t 90 | with Github.Message (_, message) -> 91 | eprintf "GitHub API error: %s\n" (Github.API.string_of_message message); 92 | exit 1 93 | -------------------------------------------------------------------------------- /lib_test/create_hook.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 David Sheets 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | open Printf 19 | 20 | let token = Config.access_token 21 | let user = "ocamlot" 22 | let repo = "opam-repository" 23 | 24 | let print_hooks label = Github_t.(Github.(Stream.iter (fun hook -> 25 | eprintf "%s %s hook %Ld created on %s %b detecting %s\n%!" 26 | label 27 | (match hook.hook_config with 28 | | `Web _ -> "web" 29 | | `Unknown (cons, _) -> cons 30 | ) 31 | hook.hook_id 32 | hook.hook_created_at 33 | hook.hook_active 34 | (List.fold_left (fun s ev -> s^(Github_j.string_of_event_type ev)^" ") 35 | "" hook.hook_events); 36 | Monad.return () 37 | ))) 38 | 39 | let make_web_hook_config url secret = Github_t.({ 40 | web_hook_config_url=url; 41 | web_hook_config_content_type=Some "json"; 42 | web_hook_config_insecure_ssl=false; 43 | web_hook_config_secret=secret; 44 | }) 45 | 46 | let make_hook url events = Github_t.({ 47 | new_hook_config=`Web (make_web_hook_config url None); 48 | new_hook_events=events; 49 | new_hook_active=true; 50 | }) 51 | 52 | let get_hooks = Github.Repo.Hook.for_repo ~token ~user ~repo () 53 | 54 | let t = Github.(Monad.(run Github_t.( 55 | API.set_user_agent "create_hook" 56 | >>= fun () -> 57 | print_hooks "Present:" get_hooks 58 | >>= fun () -> 59 | let hook = make_hook "http://example.com/" [`Push; `PullRequest; `Status] in 60 | Repo.Hook.create ~token ~user ~repo ~hook () 61 | >>~ fun hook_a -> print_hooks "Created:" (Stream.of_list [hook_a]) 62 | >>= fun () -> 63 | let hook = make_hook "http://example.org/" 64 | [`CommitComment; `IssueComment; `PullRequestReviewComment] in 65 | Repo.Hook.create ~token ~user ~repo ~hook () 66 | >>~ fun hook_b -> print_hooks "Created:" (Stream.of_list [hook_b]) 67 | >>= fun () -> 68 | Repo.Hook.get ~token ~user ~repo ~id:hook_b.hook_id () 69 | >>~ fun hook -> print_hooks "Just:" (Stream.of_list [hook]) 70 | >>= fun () -> 71 | Repo.Hook.update ~token ~user ~repo ~id:hook.hook_id ~hook:{ 72 | update_hook_config=`Web (make_web_hook_config "http://example.net/" None); 73 | update_hook_events=Some (`Watch::hook.hook_events); 74 | update_hook_active=false; 75 | } () 76 | >>~ fun hook -> print_hooks "Updated:" (Stream.of_list [hook]) 77 | >>= fun () -> 78 | API.set_user_agent "lib_test/create_hook.ml" 79 | >>= fun () -> 80 | print_hooks "Retrieved:" get_hooks 81 | >>= fun () -> 82 | Repo.Hook.delete ~token ~user ~repo ~id:hook.hook_id () 83 | >>~ fun () -> print_hooks "Deleted:" (Stream.of_list [hook]) 84 | >>= fun () -> 85 | print_hooks "Retrieved:" get_hooks 86 | >>= fun () -> 87 | Repo.Hook.delete ~token ~user ~repo ~id:hook_a.hook_id () 88 | >>~ fun () -> print_hooks "Deleted:" (Stream.of_list [hook_a]) 89 | >>= fun () -> 90 | print_hooks "Present:" get_hooks 91 | ))) 92 | 93 | ;; 94 | 95 | Lwt_main.run t 96 | -------------------------------------------------------------------------------- /lib_test/create_issue.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012 Anil Madhavapeddy 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | open Lwt 19 | open Printf 20 | 21 | let token = Config.access_token 22 | 23 | let t = 24 | let issue = { 25 | Github_t.new_issue_title="ocaml-github regression test"; 26 | new_issue_body=Some "ocaml-github body"; 27 | new_issue_assignee=Some "avsm"; 28 | new_issue_milestone=None; 29 | new_issue_labels=[]; 30 | } in 31 | 32 | Github.(Monad.(run ( 33 | Issue.create ~token ~user:"avsm" ~repo:"ocaml-github" ~issue () 34 | >|= Response.value 35 | ))) >>= fun issue -> 36 | eprintf "created issue number %d\n%!" (issue.Github_t.issue_number); 37 | return () 38 | 39 | let _ = Lwt_main.run t 40 | -------------------------------------------------------------------------------- /lib_test/create_milestone.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012 Anil Madhavapeddy 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | open Lwt 19 | open Printf 20 | 21 | let token = Config.access_token 22 | 23 | let t = 24 | let milestone = { 25 | Github_t.new_milestone_title="ocaml-github regression milestone"; 26 | new_milestone_state=`Open; 27 | new_milestone_description=Some "new milestone description"; 28 | new_milestone_due_on=None; 29 | } in 30 | 31 | Github.(Monad.(run ( 32 | Milestone.create ~token ~user:"avsm" ~repo:"ocaml-github" ~milestone () 33 | >|= Response.value 34 | ))) >>= fun milestone -> 35 | 36 | eprintf "created milestone number %d\n%!" (milestone.Github_t.milestone_number); 37 | Lwt_unix.sleep 5.0 >>= fun () -> 38 | let num = milestone.Github_t.milestone_number in 39 | eprintf "about to update milestone\n"; 40 | let milestone = { 41 | Github_t.update_milestone_title=Some "ocaml-github updated title"; 42 | update_milestone_state=None; 43 | update_milestone_description=Some "about to delete this"; 44 | update_milestone_due_on=None; 45 | } in 46 | 47 | Github.(Monad.(run ( 48 | Milestone.update ~token ~user:"avsm" ~repo:"ocaml-github" ~milestone ~num () 49 | >|= Response.value 50 | ))) >>= fun _milestone -> 51 | eprintf "updated, sleeping\n"; 52 | Lwt_unix.sleep 5.0 >>= fun () -> 53 | Github.(Monad.(run ( 54 | Milestone.delete ~token ~user:"avsm" ~repo:"ocaml-github" ~num () 55 | >|= Response.value 56 | ))) 57 | 58 | let _ = Lwt_main.run t 59 | -------------------------------------------------------------------------------- /lib_test/create_pull.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 David Sheets 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | open Lwt 19 | open Printf 20 | 21 | let token = Config.access_token 22 | let user = "dsheets" 23 | let repo = "opam-repository" 24 | 25 | let t = 26 | let issue = { 27 | Github_t.new_issue_title="ocaml-github regression test issue"; 28 | new_issue_body=Some "ocaml-github body"; 29 | new_issue_assignee=Some "dsheets"; 30 | new_issue_milestone=None; 31 | new_issue_labels=[]; 32 | } in 33 | 34 | Github.(Monad.(run ( 35 | Issue.create ~token ~user ~repo ~issue () >|= Response.value 36 | ))) >>= fun issue -> 37 | eprintf "created issue number %d\n%!" (issue.Github_t.issue_number); 38 | 39 | let pull_issue = Github_t.({ 40 | new_pull_issue_issue=issue.issue_number; 41 | new_pull_issue_head="ocamlot:master"; 42 | new_pull_issue_base="master"; 43 | }) in 44 | 45 | Github.(Monad.(run ( 46 | Pull.create_from_issue ~token ~user ~repo ~pull_issue () 47 | >|= Response.value 48 | ))) >>= fun pull -> 49 | let num = pull.Github_t.pull_number in 50 | eprintf "created pull request number %d from issue %d\n%!" num issue.Github_t.issue_number; 51 | 52 | let update_pull = Github_t.({ 53 | update_pull_title=Some "ocaml-github regression test pull request"; 54 | update_pull_body=Some "ocaml-github pull request body"; 55 | update_pull_state=None; 56 | update_pull_base=None; 57 | }) in 58 | 59 | Github.(Monad.(run ( 60 | Pull.update ~token ~user ~repo ~update_pull ~num () 61 | >|= Response.value 62 | ))) >>= fun pull -> 63 | eprintf "updated pull request number %d with title \"%s\"\n%!" num pull.Github_t.pull_title; 64 | 65 | Github.(Monad.(run ( 66 | Pull.is_merged ~token ~user ~repo ~num () 67 | >|= Response.value 68 | ))) >>= fun merged_flag -> 69 | eprintf "is pull request number %d merged? %b\n%!" num merged_flag; 70 | 71 | return () 72 | 73 | let _ = Lwt_main.run t 74 | -------------------------------------------------------------------------------- /lib_test/create_statuses.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | let token = Config.access_token 4 | 5 | let print_statuses sl = 6 | List.iter (fun s -> 7 | let open Github_t in 8 | eprintf "status %Ld: %s %s %s %s %s\n%!" 9 | s.status_id 10 | (Github_j.string_of_status_state s.status_state) 11 | (match s.status_target_url with None -> "\"\"" | Some x -> x) 12 | (match s.status_description with None -> "\"\"" | Some x -> x) 13 | s.status_created_at 14 | s.status_url 15 | ) sl 16 | 17 | let t = 18 | let user = "dsheets" in 19 | let repo = "opam-repository" in 20 | let sha_a = "85e86c0260dd230b6bd37c17056f8282011baf51" in 21 | let _sha_b = "4e89aa7f781c6f094d17079ecb6ca875327eddb8" in 22 | Github.(Monad.(run ( 23 | let status = Github_t.({ 24 | new_status_state=`Error; 25 | new_status_target_url=Some ("http://example.com/commit/#"^sha_a); 26 | new_status_description=Some "error error on the wall"; 27 | new_status_context=Some "test tube"; 28 | }) in 29 | Status.create ~token ~user ~repo ~sha:sha_a ~status () 30 | >>= fun _status -> 31 | Stream.to_list (Status.for_ref ~token ~user ~repo ~git_ref:sha_a ()) 32 | >>= fun statuses -> 33 | print_statuses statuses; 34 | let status = Github_t.({ 35 | new_status_state=`Pending; 36 | new_status_target_url=Some ("http://example.com/commit/#"^sha_a); 37 | new_status_description=Some "append be pend see pend depend"; 38 | new_status_context=Some "test tube"; 39 | }) in 40 | Status.create ~token ~user ~repo ~sha:sha_a ~status () 41 | >>= fun _ -> 42 | Stream.to_list (Status.for_ref ~token ~user ~repo ~git_ref:sha_a ()) 43 | >>= fun statuses -> 44 | print_statuses statuses; 45 | return () 46 | ))) 47 | ;; 48 | Lwt_main.run t 49 | -------------------------------------------------------------------------------- /lib_test/current_user.ml: -------------------------------------------------------------------------------- 1 | let token = Config.access_token 2 | 3 | let user = 4 | Lwt_main.run ( 5 | Github.(Monad.(run ( 6 | User.current_info ~token () >|= Response.value 7 | ))) 8 | ) 9 | 10 | let _ = 11 | Printf.printf "current user: %s\n" (Github_j.string_of_user_info user) 12 | -------------------------------------------------------------------------------- /lib_test/current_user_orgs.ml: -------------------------------------------------------------------------------- 1 | open Github_t 2 | 3 | let token = Config.access_token 4 | 5 | let t = Github.(Monad.(run ( 6 | let orgs = Organization.current_user_orgs ~token () in 7 | Stream.next orgs 8 | >>= function 9 | | None -> Printf.eprintf "no orgs for current user\n"; exit 1 10 | | Some (first_org, _) -> 11 | Printf.eprintf "org %Ld: %s\n%!" first_org.org_id first_org.org_login; 12 | assert (first_org.org_ty = `Org); 13 | return () 14 | ))) 15 | 16 | ;; 17 | 18 | Lwt_main.run t 19 | -------------------------------------------------------------------------------- /lib_test/delete_all_hooks.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013 David Sheets 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | * 16 | *) 17 | 18 | open Printf 19 | 20 | let token = Config.access_token 21 | let user = "ocamlot" 22 | let repo = "opam-repository" 23 | 24 | let get_hooks = Github.Repo.Hook.for_repo ~user ~repo () 25 | 26 | let t = Github.(Monad.(run Github_t.( 27 | API.set_user_agent "delete_all_hooks" 28 | >>= fun () -> API.set_token token 29 | >>= fun () -> Stream.to_list get_hooks 30 | >>= fun hooks -> 31 | printf "Present: %d hooks\n" (List.length hooks); 32 | List.fold_left (fun m h -> 33 | m >>= fun () -> 34 | Repo.Hook.delete ~user ~repo ~id:h.hook_id () 35 | >|= Response.value 36 | ) (return ()) hooks 37 | >>= fun () -> Stream.to_list get_hooks 38 | >>= fun hooks -> 39 | printf "Present: %d hooks\n" (List.length hooks); 40 | return () 41 | ))) 42 | 43 | let _ = Lwt_main.run t 44 | -------------------------------------------------------------------------------- /lib_test/deploy_keys.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | open Printf 3 | 4 | let token = Config.access_token 5 | 6 | let print_deploy_keys m = 7 | List.iter (fun m -> 8 | let open Github_t in 9 | eprintf "title %Ld: %s (%s)\n%!" 10 | m.deploy_key_id m.deploy_key_title m.deploy_key_key 11 | ) m; 12 | eprintf "--\n%!" 13 | 14 | let t = 15 | let k = Github.Deploy_key.for_repo ~token ~user:"mirage" ~repo:"mirage-www-deployment" in 16 | Github.(Monad.run (Stream.to_list (k ()))) >|= print_deploy_keys 17 | 18 | let _ = Lwt_main.run t 19 | -------------------------------------------------------------------------------- /lib_test/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (libraries cohttp-lwt-unix github_unix atdgen stringext cmdliner) 3 | (names 4 | checks 5 | contributors 6 | current_user 7 | current_user_orgs 8 | get_token 9 | issues 10 | labels 11 | milestones 12 | organization_repos 13 | organizations 14 | pulls 15 | releases 16 | repo_info 17 | repo_stats 18 | rwo 19 | tags 20 | user_type)) 21 | 22 | (rule (copy config.ml.in config.ml)) 23 | 24 | (alias 25 | (name DEFAULT) 26 | (deps 27 | checks.exe 28 | contributors.exe 29 | current_user.exe 30 | current_user_orgs.exe 31 | get_token.exe 32 | issues.exe 33 | labels.exe 34 | milestones.exe 35 | organization_repos.exe 36 | organizations.exe 37 | pulls.exe 38 | releases.exe 39 | repo_info.exe 40 | repo_stats.exe 41 | rwo.exe 42 | tags.exe 43 | user_type.exe)) 44 | -------------------------------------------------------------------------------- /lib_test/formac.ml: -------------------------------------------------------------------------------- 1 | 2 | let token = Config.access_token 3 | let user = "docker" 4 | let repo = "for-mac" 5 | let num = 1131 6 | 7 | let t = 8 | let open Github in 9 | let open Monad in 10 | run ( 11 | let issue_events = Issue.events ~token ~user ~repo ~num () in 12 | Stream.to_list issue_events >>= fun _ -> 13 | return () 14 | ) 15 | 16 | ;; 17 | Lwt_main.run t 18 | -------------------------------------------------------------------------------- /lib_test/get_token.ml: -------------------------------------------------------------------------------- 1 | let t = Github.(Monad.(run ( 2 | let note = "get_token via ocaml-github" in 3 | Token.create ~user:Config.user ~pass:Config.pass ~note () 4 | >>~ function 5 | | Result auth -> 6 | let token = Token.of_auth auth in 7 | prerr_endline (Token.to_string token); 8 | return () 9 | | Two_factor _ -> fail (Failure "get_token doesn't support 2fa, yet") 10 | ))) 11 | 12 | ;; 13 | 14 | Lwt_main.run t 15 | -------------------------------------------------------------------------------- /lib_test/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | Github API Javascript Test 6 | 11 | 12 | 13 | 14 | 15 | 16 |

Fetch a GIST

17 | 18 |

gist id: 19 |

20 | 21 | 

22 | 
23 | 
List repositories

24 | 
25 | 
username:  
26 |               

27 | 
28 | 

29 | 
30 | 
31 | 
32 | 
33 | 


--------------------------------------------------------------------------------
/lib_test/issues.ml:
--------------------------------------------------------------------------------
 1 | open Printf
 2 | 
 3 | let token = Config.access_token
 4 | let user = "ocaml"
 5 | let repo = "opam"
 6 | 
 7 | let t =
 8 |   let open Github in
 9 |   let open Monad in
10 |   let open Github_t in
11 |   run (
12 |     let issues = Issue.for_repo ~token ~user ~repo () in
13 |     Stream.iter (fun issue ->
14 |       let num = issue.issue_number in
15 |       eprintf "issue %d: %s\n%!" num issue.issue_title;
16 |       let issue_comments = Issue.comments ~token ~user ~repo ~num () in
17 |       Stream.to_list issue_comments
18 |       >>= fun comments ->
19 |       List.iter (fun c ->
20 |         eprintf "  > %Ld: %s\n" c.issue_comment_id c.issue_comment_body
21 |       ) comments;
22 |       return ()
23 |     ) issues
24 |   )
25 | 
26 | ;;
27 | Lwt_main.run t
28 | 


--------------------------------------------------------------------------------
/lib_test/labels.ml:
--------------------------------------------------------------------------------
 1 | open Printf
 2 | 
 3 | let token = Config.access_token
 4 | let user = "ocaml"
 5 | let repo = "opam"
 6 | 
 7 | let t =
 8 |   let open Github in
 9 |   let open Monad in
10 |   let open Github_t in
11 |   run (
12 |     let labels = Label.for_repo ~token ~user ~repo () in
13 |     printf "labels for %s/%s\n\n" user repo;
14 |     Stream.iter (fun label ->
15 |       let name = label.label_name in
16 |       printf "%s\n" name;
17 |       return ()
18 |     ) labels
19 |   )
20 | 
21 | ;;
22 | Lwt_main.run t
23 | 


--------------------------------------------------------------------------------
/lib_test/milestones.ml:
--------------------------------------------------------------------------------
 1 | open Printf
 2 | 
 3 | let token = Config.access_token
 4 | 
 5 | let print_milestones m =
 6 |   List.iter (fun m ->
 7 |     let open Github_t in
 8 |     eprintf "milestone %d: %s (%s)\n%!" m.milestone_number m.milestone_title m.milestone_created_at
 9 |   ) m;
10 |   eprintf "--\n%!"
11 |  
12 | let t = Github.(Monad.(run (
13 |   let opro_milestones = Milestone.for_repo ~user:"ocaml" ~repo:"opam" in
14 |   let milestones = opro_milestones ~state:`Closed () in
15 |   Stream.to_list milestones
16 |   >|= print_milestones >>= fun () ->
17 |   let milestones = opro_milestones ~state:`Closed ~direction:`Asc () in
18 |   Stream.to_list milestones
19 |   >|= print_milestones >>= fun () ->
20 |   let milestones = Milestone.for_repo
21 |       ~sort:`Completeness ~direction:`Asc ~user:"mxcl" ~repo:"homebrew" ()
22 |   in Stream.to_list milestones
23 |   >|= print_milestones >>= fun () ->
24 |   let milestones = Milestone.for_repo
25 |       ~sort:`Completeness ~direction:`Desc ~user:"mxcl" ~repo:"homebrew" ()
26 |   in Stream.to_list milestones
27 |   >|= print_milestones >>= fun () ->
28 |   let user = "mxcl" in
29 |   let repo = "homebrew" in
30 |   API.set_token token >>= fun () ->
31 |   let milestones = Milestone.for_repo
32 |       ~sort:`Completeness ~direction:`Desc ~user ~repo ()
33 |   in Stream.iter (fun { Github_t.milestone_number = num; _ } ->
34 |     Milestone.get ~user ~repo ~num ()
35 |     >>~ fun { Github_t.milestone_title; _ } ->
36 |     eprintf "Inside monad: milestone %d: %s\n" num milestone_title;
37 |     return ()
38 |   ) milestones
39 | )))
40 | 
41 | ;;
42 | 
43 | Lwt_main.run t
44 | 


--------------------------------------------------------------------------------
/lib_test/organization_repos.ml:
--------------------------------------------------------------------------------
 1 | open Github_t
 2 | 
 3 | let token = Config.access_token
 4 | 
 5 | let org = "mirage"
 6 | 
 7 | let t = Github.(Monad.(run (
 8 |     let orgs = Organization.repositories ~token ~org () in
 9 |     Stream.to_list orgs >>= function
10 |     | [] -> Printf.eprintf "no repos for organisation\n"; exit 1
11 |     | x ->
12 |        List.iter (function repo ->
13 |                     Printf.eprintf "org %Ld: %s\n%!" repo.repository_id repo.repository_name) x;
14 |        return ())))
15 | ;;
16 | 
17 | Lwt_main.run t
18 | 


--------------------------------------------------------------------------------
/lib_test/organizations.ml:
--------------------------------------------------------------------------------
 1 | open Printf
 2 | open Github_t
 3 | 
 4 | let token = Config.access_token
 5 | 
 6 | let org = "mirage"
 7 | 
 8 | let t = Github.(Monad.(run (
 9 |   let get_teams = Organization.teams ~token:token ~org in
10 |   Stream.next (get_teams ())
11 |   >>= function
12 |   | None -> eprintf "no teams for %s\n" org; exit 1
13 |   | Some (first_team,_) ->
14 |   let get_first_team = Team.info ~token:token ~id:first_team.team_id in
15 |   get_first_team () >>~ fun team ->
16 |   eprintf "team %Ld: %s (%s)\n%!"
17 |     team.team_info_id team.team_info_name team.team_info_url;
18 |   let get_team_repos =
19 |     Team.repositories ~token:token ~id:team.team_info_id
20 |   in
21 |   Stream.next (get_team_repos ())
22 |   >>= function
23 |   | None -> eprintf "no repos for %s\n" team.team_info_name; exit 1
24 |   | Some (first_repo,_) ->
25 |   eprintf "repo %Ld: %s\n%!" first_repo.repository_id first_repo.repository_name;
26 |   return ()
27 | )))
28 | 
29 | ;;
30 | 
31 | Lwt_main.run t
32 | 


--------------------------------------------------------------------------------
/lib_test/parse_events.ml:
--------------------------------------------------------------------------------
  1 | (*
  2 |  * Copyright (c) 2015 David Sheets 
  3 |  *
  4 |  * Permission to use, copy, modify, and distribute this software for any
  5 |  * purpose with or without fee is hereby granted, provided that the above
  6 |  * copyright notice and this permission notice appear in all copies.
  7 |  *
  8 |  * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
  9 |  * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 10 |  * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 11 |  * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 12 |  * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 13 |  * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 14 |  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 15 |  *
 16 |  *)
 17 | 
 18 | open Lwt
 19 | open Printf
 20 | 
 21 | module Http = Cohttp_lwt_unix
 22 | 
 23 | type hour = {
 24 |   year : int;
 25 |   month : int;
 26 |   day : int;
 27 |   hour : int;
 28 | }
 29 | 
 30 | let archive_base = Uri.of_string "http://data.githubarchive.org/"
 31 | 
 32 | let download_hour_file file_name =
 33 |   let gz_name = file_name^".gz" in
 34 |   let uri = Uri.(resolve "" archive_base (of_string gz_name)) in
 35 |   let uri_s = Uri.to_string uri in
 36 |   Http.Client.call `GET uri
 37 |   >>= fun (resp, body) ->
 38 |   let open Cohttp in
 39 |   let status = Response.status resp in
 40 |   let status_s = Code.string_of_status status in
 41 |   if not (Code.is_success (Code.code_of_status status))
 42 |   then fail (Failure (sprintf "Retrieving %s got status %s" uri_s status_s))
 43 |   else Lwt_io.(with_file ~mode:output gz_name (fun oc ->
 44 |     Lwt_stream.iter_s (write oc) (Cohttp_lwt.Body.to_stream body)
 45 |   )) >>= fun () ->
 46 |     let gunzip = sprintf "gunzip %s" gz_name in
 47 |     Lwt_unix.system gunzip
 48 |     >>= Unix.(function
 49 |       | WEXITED 0 -> return file_name
 50 |       | _ -> fail (Failure (gunzip^" failed"))
 51 |     )
 52 | 
 53 | let save_hour ({ year; month; day; hour }) =
 54 |   (* so close for lexicographic sort... but they still managed to break it *)
 55 |   let file_name = sprintf "%d-%02d-%02d-%d.json"
 56 |       year month day hour
 57 |   in
 58 |   catch
 59 |     (fun () ->
 60 |        Lwt_unix.(access file_name [R_OK])
 61 |        >>= fun () -> return file_name
 62 |     )
 63 |     (fun _ -> download_hour_file file_name)
 64 | 
 65 | let parse_events file_name ic =
 66 |   let event_ss = Lwt_io.read_lines ic in
 67 |   Lwt_stream.fold_s (fun event_s (k,t) ->
 68 |     catch
 69 |       (fun () ->
 70 |          let t0 = Unix.gettimeofday () in
 71 |          ignore (Github_j.event_of_string event_s);
 72 |          let t1 = Unix.gettimeofday () in
 73 |          return (k + 1,t +. t1 -. t0)
 74 |       )
 75 |       (function
 76 |         | Yojson.Json_error msg ->
 77 |           Lwt_io.eprintf "%s\n\nParse failure in %s on event %d:\n%s\n"
 78 |             event_s file_name k msg
 79 |           >>= fun () ->
 80 |           exit 1
 81 |         | exn -> fail exn
 82 |       )
 83 |   ) event_ss (1,0.)
 84 | 
 85 | let parse_hours ~clean hours =
 86 |   Lwt_list.iter_s (fun hour ->
 87 |     save_hour hour
 88 |     >>= fun hour_file ->
 89 |     Lwt_io.(with_file ~mode:input hour_file (parse_events hour_file))
 90 |     >>= fun (k,t) ->
 91 |     let eps = (float_of_int k) /. t in
 92 |     Lwt_io.print (sprintf "Parsed %d events from %s successfully (%f e/s)\n"
 93 |                     k hour_file eps)
 94 |     >>= fun () ->
 95 |     if clean then Lwt_unix.unlink hour_file else return_unit
 96 |   ) hours
 97 | 
 98 | let day_of_hour hour =
 99 |   let rec next_hour acc = function
100 |     | 24 -> acc
101 |     | k -> next_hour ({ hour with hour = k }::acc) (k+1)
102 |   in
103 |   next_hour [] 0
104 | 
105 | let parse_cmd year month day hour ~clean =
106 |   let hours = match hour with
107 |     | None  -> day_of_hour { year; month; day; hour=0 }
108 |     | Some hour -> [{ year; month; day; hour }]
109 |   in
110 |   parse_hours ~clean hours
111 | 
112 | open Cmdliner
113 | 
114 | let cmd =
115 |   let doc = "the year to query" in
116 |   let docv = "YEAR" in
117 |   let year = Arg.(required & pos 0 (some int) None & info [] ~docv ~doc) in
118 |   let doc = "the 1-indexed month to query" in
119 |   let docv = "MONTH" in
120 |   let month = Arg.(required & pos 1 (some int) None & info [] ~docv ~doc) in
121 |   let doc = "the 1-indexed day to query" in
122 |   let docv = "DAY" in
123 |   let day = Arg.(required & pos 2 (some int) None & info [] ~docv ~doc) in
124 |   let doc = "the 0-indexed hour to query" in
125 |   let docv = "HOUR" in
126 |   let hour = Arg.(value & pos 3 (some int) None & info [] ~docv ~doc) in
127 |   let doc = "clean downloaded files after use" in
128 |   let docv = "CLEAN" in
129 |   let clean = Arg.(value & flag & info ["clean"] ~docv ~doc) in
130 |   let doc = "attempt to parse GitHub Archive events" in
131 |   let man = [
132 |     `S "BUGS";
133 |     `P "Email bug reports to .";
134 |   ] in
135 |   let term = Term.(const (fun y m d h clean -> Lwt_main.run (parse_cmd y m d h ~clean))
136 |          $ year $ month $ day $ hour $ clean) in
137 |   let info = Cmd.info "parse_events" ~doc ~man in
138 |   Cmd.v info term
139 | 
140 | let () = exit @@ Cmd.eval cmd
141 | 


--------------------------------------------------------------------------------
/lib_test/pulls.ml:
--------------------------------------------------------------------------------
 1 | open Printf
 2 | 
 3 | let token = Config.access_token
 4 | 
 5 | let print_pulls pl = Github.(Monad.(
 6 |   Stream.iter (fun p ->
 7 |     let open Github_t in
 8 |     eprintf "pull request %d: %s (%s)\n%!"
 9 |       p.pull_number p.pull_title p.pull_created_at;
10 |     return ()
11 |   ) pl
12 |   >>= fun () ->
13 |   eprintf "--\n%!";
14 |   return ()
15 | ))
16 |  
17 | let t = Github.(Monad.(run (
18 |   let user = "ocaml" in
19 |   let repo = "opam" in
20 |   let opam_repo_pulls = Pull.for_repo ~user ~repo in
21 |   return (opam_repo_pulls ~state:`Open ()) >>= print_pulls >>= fun () ->
22 |   return (opam_repo_pulls ~state:`Closed ()) >>= print_pulls >>= fun () ->
23 |   return (opam_repo_pulls ())
24 |   >>= Stream.iter (fun hd ->
25 |     Pull.get ~token ~user ~repo ~num:hd.Github_t.pull_number ()
26 |     >>~ fun p ->
27 |     eprintf "Inside monad: pull %d: %s\n%!"
28 |       p.Github_t.pull_number p.Github_t.pull_title;
29 |     return (Pull.commits ~token ~user ~repo ~num:hd.Github_t.pull_number ())
30 |     >>= Stream.iter (fun commit ->
31 |       eprintf "    %s\n" commit.Github_t.commit_sha; return ()
32 |     )
33 |     >>= fun () ->
34 |     eprintf "---------\n%!";
35 |     return (Pull.files ~token ~user ~repo ~num:hd.Github_t.pull_number ())
36 |     >>= Stream.iter (fun file ->
37 |       eprintf "    %s\n" file.Github_t.file_filename; return ()
38 |     )
39 |   )
40 | )))
41 | 
42 | ;;
43 | 
44 | Lwt_main.run t
45 | 


--------------------------------------------------------------------------------
/lib_test/releases.ml:
--------------------------------------------------------------------------------
 1 | open Printf
 2 | 
 3 | let token = Config.access_token
 4 | 
 5 | let name_of_release = Github_t.(function
 6 |   | { release_name=Some name ;_} -> name
 7 |   | { release_name=None      ;_} -> "NULL"
 8 | )
 9 | 
10 | let latest_release m =
11 |   let open Github_t in
12 |   let name = name_of_release m in
13 |   eprintf "latest release %Ld: %s (%s)\n%!" m.release_id name m.release_created_at;
14 |   eprintf "--\n%!";
15 |   ()
16 | 
17 | let print_releases m = Github.(Monad.(
18 |   Stream.iter (fun m ->
19 |       let open Github_t in
20 |       let name = name_of_release m in
21 |       eprintf "release %Ld: %s (%s)\n%!" m.release_id name m.release_created_at;
22 |       return ()
23 |   ) m
24 |   >>= fun () ->
25 |   eprintf "--\n%!";
26 |   return ()
27 | ))
28 | 
29 | let print_release_assets m =
30 |   let open Github_t in
31 |   List.iter (fun x -> eprintf "asset %Ld %s\n%!" x.release_asset_id x.release_asset_url) m;
32 |   eprintf "--\n%!";
33 |   ()
34 | 
35 | let t = Github.(Monad.(run (
36 |   return (Release.for_repo ~user:"mirage" ~repo:"ocaml-github" ())
37 |   >>= print_releases >>= fun () ->
38 |   (Release.get_latest ~user:"mirage" ~repo:"ocaml-github" () >|= Response.value >>= fun x ->
39 |    latest_release x;
40 |    return x
41 |   )
42 |   >>= fun a ->
43 |   (Release.list_assets ~user:"mirage" ~repo:"ocaml-github" ~id:a.Github_t.release_id ()
44 |    >|= Response.value
45 |    >|= print_release_assets)
46 |   >>= fun _ ->
47 |   return (Release.for_repo ~user:"mirage" ~repo:"mirage" ())
48 |   >>= print_releases
49 | )))
50 | 
51 | ;;
52 | 
53 | Lwt_main.run t
54 | 


--------------------------------------------------------------------------------
/lib_test/repo_info.ml:
--------------------------------------------------------------------------------
 1 | open Printf
 2 | open Github_t
 3 | 
 4 | let token = Config.access_token
 5 | 
 6 | let opam_first_commit = "3656b4d1b03a8ae356cf82f7052f1976df8787be"
 7 | 
 8 | let t =
 9 |   let open Github in
10 |   let open Monad in
11 |   run (
12 |     Repo.info ~token ~user:"ocaml" ~repo:"opam" ()
13 |     >>~ fun info ->
14 |     let descr = match info.repository_description with
15 |       | Some descr -> descr
16 |       | None -> ""
17 |     in
18 |     eprintf "repo %s\n" descr;
19 |     begin match info.repository_permissions with
20 |       | Some permissions ->
21 |         eprintf "permissions admin(%B) push(%B) pull(%B)\n"
22 |           permissions.repository_permissions_admin
23 |           permissions.repository_permissions_push
24 |           permissions.repository_permissions_pull
25 |       | None -> ()
26 |     end;
27 |     let branches = Repo.branches ~token ~user:"ocaml" ~repo:"opam" () in
28 |     Stream.to_list branches
29 |     >>= fun branches ->
30 |     List.iter (fun b ->
31 |       eprintf "branch %s %s\n"
32 |         b.repo_branch_name
33 |         b.repo_branch_commit.repo_commit_sha
34 |       ) branches;
35 |     Repo.get_commit ~token ~user:"ocaml" ~repo:"opam" ~sha:opam_first_commit ()
36 |     >>~ fun commit ->
37 |     eprintf
38 |       "opam first commit author date: %s\n"
39 |       commit.commit_git.git_commit_author.info_date;
40 |     eprintf
41 |       "opam first commit committer date: %s\n"
42 |       commit.commit_git.git_commit_author.info_date;
43 |     return ()
44 |   )
45 | 
46 | ;;
47 | Lwt_main.run t
48 | 


--------------------------------------------------------------------------------
/lib_test/repo_stats.ml:
--------------------------------------------------------------------------------
 1 | open Lwt
 2 | open Printf
 3 | 
 4 | let token = Config.access_token
 5 | let user = "mirage"
 6 | let repo = "ocaml-github"
 7 | 
 8 | let t =
 9 |   let open Github in
10 | 
11 |   let pp_sep fmt () = Format.fprintf fmt "; " in
12 | 
13 |   let print_yearly_stats stats =
14 |     Format.printf "Yearly commit activity.@.";
15 | 
16 |     List.iter (fun x ->
17 |         Format.printf "{ days: [ %a ]"
18 |           (Format.pp_print_list ~pp_sep Format.pp_print_int) x.Github_t.commit_activity_days;
19 |         Format.printf ", total: %i, week: %i }@." x.Github_t.commit_activity_total x.Github_t.commit_activity_week) stats in
20 | 
21 |   let print_weekly_activity stats =
22 |     let week x = Format.printf " [ %a ]@." (Format.pp_print_list ~pp_sep Format.pp_print_int) x in
23 | 
24 |     Format.printf "Testing weekly commit activity.@.";
25 |     List.iter (fun x -> week x) stats in
26 | 
27 |   let print_weekly_count weekly_count =
28 |     Format.printf "Testing weekly commit count.@.";
29 |     Format.printf " all: [ %a ]@."
30 |       (Format.pp_print_list ~pp_sep Format.pp_print_int)
31 |       weekly_count.Github_t.participation_all;
32 |     Format.printf " owner: [ %a ]@."
33 |       (Format.pp_print_list ~pp_sep Format.pp_print_int)
34 |       weekly_count.Github_t.participation_owner in
35 | 
36 |   let print_hourly_stats stats =
37 |     let week x = Format.printf " [ %a ]@." (Format.pp_print_list ~pp_sep Format.pp_print_int) x in
38 | 
39 |     Format.printf "Testing hourly commit activity.@.";
40 |     List.iter (fun x -> week x) stats in
41 | 
42 |   Monad.(run (
43 |              let frequency = Stats.yearly_commit_activity ~token ~user ~repo () in
44 |              Stream.to_list frequency
45 |   )) >>= function
46 |   | [] -> printf "No yearly stats found OR data not yet computed and cached."; return ()
47 |   | yearly_stats -> print_yearly_stats yearly_stats;
48 | 
49 |   Monad.(run (
50 |     let frequency = Stats.weekly_commit_activity ~token ~user ~repo () in
51 |     Stream.to_list frequency)) >>= function
52 |   | [] -> printf "No contributors found OR data not yet computed and cached."; return ()
53 |   | stats -> print_weekly_activity stats;
54 | 
55 |   Monad.(run (Stats.weekly_commit_count ~token ~user ~repo () >|= Response.value)) >>= fun weekly_count ->
56 |     print_weekly_count weekly_count;
57 | 
58 |   Monad.(run (
59 |     let frequency = Stats.hourly_commit_count ~token ~user ~repo () in
60 |     Stream.to_list frequency )) >>= function
61 |     | [] -> printf "No punch cards found OR data not yet computed and cached."; return ()
62 |     | stats -> print_hourly_stats stats;
63 | 
64 |   return ()
65 | ;;
66 | 
67 | try Lwt_main.run t
68 | with Github.Message (_, message) ->
69 |   eprintf "GitHub API error: %s\n" (Github.API.string_of_message message);
70 |   exit 1
71 | 


--------------------------------------------------------------------------------
/lib_test/rwo.ml:
--------------------------------------------------------------------------------
  1 | (*
  2 |  * Copyright (c) 2012 Anil Madhavapeddy 
  3 |  *
  4 |  * Permission to use, copy, modify, and distribute this software for any
  5 |  * purpose with or without fee is hereby granted, provided that the above
  6 |  * copyright notice and this permission notice appear in all copies.
  7 |  *
  8 |  * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
  9 |  * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 10 |  * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 11 |  * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 12 |  * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 13 |  * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 14 |  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 15 |  *
 16 |  *)
 17 | 
 18 | open Lwt
 19 | open Printf
 20 | open Cohttp
 21 | open Cohttp_lwt_unix
 22 | open Config
 23 | 
 24 | let scopes = [`Public_repo]
 25 | let step1_link = Github.URI.authorize ~state:"TODO" ~scopes ~client_id ()
 26 | 
 27 | module Resp = struct
 28 |   let wrap_html s =
 29 |     sprintf "%s" s
 30 | 
 31 |   (* respond with an error *)
 32 |   let not_found _req err =
 33 |     let status = `Not_found in
 34 |     let headers = Header.of_list [ "Cache-control", "no-cache" ] in
 35 |     let body = sprintf "
Error
%s
" err in
 36 |     Server.respond_string ~headers ~status ~body ()
 37 | 
 38 |   (* internal error *)
 39 |   let internal_error err =
 40 |     let status = `Internal_server_error in
 41 |     let headers = Header.of_list [ "Cache-control", "no-cache" ] in
 42 |     let body = sprintf "
Internal Server Error
%s
" err in
 43 |     Server.respond_string ~headers ~status ~body
 44 | 
 45 |   (* dynamic response *)
 46 |   let dyn _req body =
 47 |     let status = `OK in
 48 |     Server.respond_string ~body ~status ()
 49 | 
 50 |   (* index page *)
 51 |   let index req =
 52 |     let body = wrap_html (sprintf "step1" (Uri.to_string step1_link)) in
 53 |     dyn req body
 54 | 
 55 |   (* dispatch non-file URLs *)
 56 |   let dispatch req =
 57 |     function
 58 |     | ["";""]
 59 |     | ["";"index.html"]  ->
 60 |         index req
 61 |     | ["";"step2"] -> begin
 62 |         let uri = Request.uri req in
 63 |         let code =
 64 |           match Uri.get_query_param uri "code" with
 65 |           | Some hd -> hd
 66 |           | None -> "" in
 67 |         Lwt.catch (
 68 |           fun () ->
 69 |           Github.Token.of_code ~client_id ~client_secret ~code () >>= function
 70 |           | None -> internal_error "no token in response" ()
 71 |           | Some token ->
 72 |             dyn req (wrap_html ("ok: token is " ^ (Github.Token.to_string token))))
 73 |           (function
 74 |           | Failure e -> dyn req (wrap_html ("err: " ^ e))
 75 |           | e -> Lwt.fail e)
 76 |     end
 77 |     | _ ->
 78 |         not_found req "dispatch"
 79 | end
 80 | 
 81 | (* main callback function *)
 82 | let callback _conn_id req _body =
 83 |   let uri = Request.uri req in
 84 |   let path = Uri.path uri in
 85 |   printf "%s %s [%s]\n%!" (Code.string_of_method (Request.meth req)) path
 86 |     (String.concat "," (List.map (fun (h,v) -> sprintf "%s=%s" h (String.concat "," v)) (Uri.query uri)));
 87 |   (* normalize path to strip out ../. and such *)
 88 |   let path_elem = Stringext.(split ~on:'/' (Uri.path uri)) in
 89 |   List.iter (fun p -> printf "> %s\n%!" p) path_elem;
 90 |   Resp.dispatch req path_elem
 91 | 
 92 | let server_t =
 93 |   let port = 8080 in
 94 |   let conn_closed _conn_id = () in
 95 |   let spec = Cohttp_lwt_unix.Server.make ~callback ~conn_closed () in
 96 |   let ctx = Cohttp_lwt_unix.Net.init () in
 97 |   let mode = `TCP (`Port port) in
 98 |   Cohttp_lwt_unix.Server.create ~ctx ~mode spec
 99 | 
100 | let _ =
101 |   Lwt_main.run server_t
102 | 


--------------------------------------------------------------------------------
/lib_test/tags.ml:
--------------------------------------------------------------------------------
 1 | open Lwt
 2 | open Printf
 3 | 
 4 | let get_auth_token_from_jar auth_id =
 5 |   Github_cookie_jar.init ()
 6 |   >>= fun jar ->
 7 |   Github_cookie_jar.get jar ~name:auth_id
 8 |   >>= function
 9 |   | Some auth -> return auth
10 |   | None -> Lwt.fail (Failure ("id '"^auth_id^"' not in cookie jar"))
11 | 
12 | let get_tags_and_times ~user ~repo =
13 |   let stream = Github.Repo.get_tags_and_times ~user ~repo () in
14 |   Github.Stream.iter (fun (k,v) ->
15 |     eprintf "%s %s\n" k v;
16 |     Github.Monad.return ()
17 |   ) stream
18 | 
19 | ;;
20 | Lwt_main.run Github.Monad.(run (
21 |   embed (get_auth_token_from_jar "test")
22 |   >>= fun auth ->
23 |   Github.(API.set_token (Token.of_auth auth))
24 |   >>= fun () ->
25 |   get_tags_and_times ~user:"dsheets" ~repo:"axtls"
26 |   >>= fun () ->
27 |   get_tags_and_times ~user:"ocaml" ~repo:"opam"
28 |   >>= fun () ->
29 |   get_tags_and_times ~user:"mirage" ~repo:"ocaml-cstruct"
30 | ))
31 | 


--------------------------------------------------------------------------------
/lib_test/user_type.ml:
--------------------------------------------------------------------------------
 1 | let token = Config.access_token
 2 | 
 3 | let test_current_user =
 4 |   (* Test if the current user, associated with the access token, is correctly
 5 |      flagged as [`User]. *)
 6 |   let current_user =
 7 |     Lwt_main.run begin
 8 |       Github.(Monad.(run (User.current_info ~token () >|= Response.value)))
 9 |     end
10 |   in
11 |   assert (current_user.Github_t.user_info_ty = `User);
12 |   Format.printf "Check current user: OK.@."
13 | 
14 | let test_current_user_first_org =
15 |   (* Test if the current user, associated with the access token, first
16 |      organization in the list is correctly flagged as [`Org]. *)
17 |   let org =
18 |     Lwt_main.run begin
19 |       Github.(Monad.(run begin
20 |           let orgs = Organization.current_user_orgs ~token () in
21 |           Stream.next orgs >>= function
22 |           | None ->
23 |             Printf.eprintf "No organizations for the current user.\n";
24 |             exit 1
25 |           | Some (first_org, _) ->
26 |             return first_org
27 |         end))
28 |     end
29 |   in
30 |   assert (org.Github_t.org_ty = `Org);
31 |   Format.printf "Check current user first org: OK.@."
32 | 
33 | let test_ocaml_organization =
34 |   (* Test if the OCaml organization (using the [/user/...] API) is correctly
35 |      flagged as [`Org]. *)
36 |   let ocaml_user =
37 |     Lwt_main.run begin
38 |       Github.(Monad.(run begin
39 |           User.info ~token ~user:"ocaml" () >|= Response.value
40 |         end))
41 |     end
42 |   in
43 |   assert (ocaml_user.Github_t.user_info_ty = `Org);
44 |   Format.printf "Check OCaml org: OK.@."
45 | 
46 | let test_ocaml_repository =
47 |   (* Test if the owner of the [opam] repository (using the [/repos/...] APIS) is
48 |      correctly flag as [`Org]. *)
49 |   let opam_repository =
50 |     Lwt_main.run begin
51 |       Github.(Monad.(run begin
52 |           Repo.info ~token ~user:"ocaml" ~repo:"opam" () >|= Response.value
53 |         end))
54 |     end
55 |   in
56 |   assert Github_t.(opam_repository.repository_owner.user_ty = `Org);
57 |   Format.printf "Check OCaml repo: OK.@."
58 | 


--------------------------------------------------------------------------------
/passwd/dune:
--------------------------------------------------------------------------------
1 | (library
2 |  (name passwd)
3 |  (libraries lwt lwt.unix))
4 | 


--------------------------------------------------------------------------------
/passwd/passwd.ml:
--------------------------------------------------------------------------------
 1 | let get ~prompt =
 2 |   let open Lwt in
 3 |   let open Lwt_unix in
 4 |   tcgetattr stdin >>= fun term_io ->
 5 |   tcsetattr stdin TCSANOW { term_io with c_echo = false } >>= fun () ->
 6 |   Lwt_io.print prompt >>= fun () ->
 7 |   Lwt_io.read_line Lwt_io.stdin >>= fun input ->
 8 |   tcsetattr stdin TCSANOW term_io >|= fun () ->
 9 |   input
10 | 
11 | let get_if_unset ~prompt = function
12 |   | None -> get ~prompt
13 |   | Some p -> Lwt.return p
14 | 


--------------------------------------------------------------------------------
/passwd/passwd.mli:
--------------------------------------------------------------------------------
1 | val get : prompt:string -> string Lwt.t
2 | 
3 | val get_if_unset : prompt:string -> string option -> string Lwt.t
4 | 


--------------------------------------------------------------------------------
/unix/dune:
--------------------------------------------------------------------------------
1 | (library
2 |  (name github_unix)
3 |   (public_name github-unix)
4 |   (wrapped false)
5 |   (libraries lwt.unix cohttp-lwt-unix github bytes))
6 | 


--------------------------------------------------------------------------------
/unix/github.ml:
--------------------------------------------------------------------------------
 1 | (*
 2 |  * Copyright (c) 2012-2014 Anil Madhavapeddy 
 3 |  *
 4 |  * Permission to use, copy, modify, and distribute this software for any
 5 |  * purpose with or without fee is hereby granted, provided that the above
 6 |  * copyright notice and this permission notice appear in all copies.
 7 |  *
 8 |  * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 9 |  * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
10 |  * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
11 |  * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
12 |  * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
13 |  * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
14 |  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
15 |  *
16 |  *)
17 | 
18 | module Time = struct
19 |   let now = Unix.gettimeofday
20 |   let sleep = Lwt_unix.sleep
21 | end
22 | 
23 | module Env = struct
24 |   let debug = try Unix.getenv "GITHUB_DEBUG" <> "0" with _ -> false
25 | end
26 | 
27 | include Github_core.Make(Env)(Time)(Cohttp_lwt_unix.Client)
28 | 


--------------------------------------------------------------------------------
/unix/github.mli:
--------------------------------------------------------------------------------
1 | include Github_s.Github
2 | 
3 | 


--------------------------------------------------------------------------------
/unix/github_cookie_jar.ml:
--------------------------------------------------------------------------------
  1 | (*
  2 |  * Copyright (c) 2012 Anil Madhavapeddy 
  3 |  * Copyright (c) 2013 David Sheets 
  4 |  *
  5 |  * Permission to use, copy, modify, and distribute this software for any
  6 |  * purpose with or without fee is hereby granted, provided that the above
  7 |  * copyright notice and this permission notice appear in all copies.
  8 |  *
  9 |  * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 10 |  * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 11 |  * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 12 |  * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 13 |  * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 14 |  * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 15 |  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 16 |  *
 17 |  *)
 18 | open Printf
 19 | open Lwt
 20 | 
 21 | type t = { jar_path : string }
 22 | 
 23 | exception InvalidName of string
 24 | 
 25 | let invalid_names = Re.(List.map compile [
 26 |   seq [bos; str "."];
 27 |   str "../";
 28 |   seq [bos; str Filename.dir_sep];
 29 |   seq [str Filename.dir_sep; eos];
 30 | ])
 31 | 
 32 | let jar_path { jar_path } = jar_path
 33 | 
 34 | let file_kind_match path ~reg ~dir ~other = Lwt_unix.(
 35 |   stat path
 36 |   >>= fun { st_kind; _ } -> match st_kind with
 37 |     | S_REG -> reg ()
 38 |     | S_DIR -> dir ()
 39 |     | S_CHR | S_BLK | S_LNK | S_FIFO | S_SOCK -> other ()
 40 | )
 41 | 
 42 | let rec mkdir_p dir =
 43 |   match Sys.file_exists dir with
 44 |     | true -> return ()
 45 |     | false ->
 46 |         mkdir_p (Filename.dirname dir)
 47 |         >>= fun () -> Lwt_unix.mkdir dir 0o700
 48 | 
 49 | let rec init ?jar_path () =
 50 |   let jar_path = match jar_path with
 51 |     | None ->
 52 |         let home = try Sys.getenv "HOME" with Not_found -> "." in
 53 |         let basedir = Filename.concat home ".github" in
 54 |         Filename.concat basedir "jar"
 55 |     | Some jar_path -> jar_path
 56 |   in
 57 |   match Sys.file_exists jar_path with
 58 |     | true -> return { jar_path }
 59 |     | false ->
 60 |         printf "Github cookie jar: initialized %s\n" jar_path;
 61 |         mkdir_p jar_path
 62 |         >>= init ~jar_path
 63 | 
 64 | (* Save an authentication token to disk, under the [name]
 65 |  * file in the jar *)
 66 | let save ({ jar_path } as jar) ~name ~auth =
 67 |   (if List.exists (fun re -> Re.execp re name) invalid_names then
 68 |      fail (InvalidName name)
 69 |    else
 70 |      return ()
 71 |   ) >>= fun () ->
 72 |   let rec backup_path ?(dirok=false) name =
 73 |     let fullname = Filename.concat jar_path name in
 74 |     let backup () =
 75 |       let open Unix in
 76 |       let tm = gmtime (gettimeofday ()) in
 77 |       let backfname = sprintf "%s.%.4d%.2d%.2d.%2d%2d%2d.bak"
 78 |         name (1900 + tm.tm_year) (1 + tm.tm_mon) tm.tm_mday
 79 |         tm.tm_hour tm.tm_min tm.tm_sec in
 80 |       let fullback = Filename.concat jar_path backfname in
 81 |       printf "Github cookie jar: backing up\n%s -> %s\n" fullname fullback;
 82 |       Lwt_unix.rename fullname fullback
 83 |     in
 84 |     catch (fun () ->
 85 |       file_kind_match fullname
 86 |         ~reg:backup
 87 |         ~dir:(if dirok then return else backup)
 88 |         ~other:backup
 89 |     ) (function
 90 |       | Unix.Unix_error (Unix.ENOENT, _, _)
 91 |       | Unix.Unix_error (Unix.ENOTDIR, _, _) ->
 92 |         begin match Filename.dirname name with
 93 |         | "." -> return ()
 94 |         | parent -> backup_path ~dirok:true parent
 95 |         end
 96 |       | exn -> fail exn
 97 |     )
 98 |   in
 99 |   backup_path name
100 |   >>= fun () ->
101 |   let fullname = Filename.concat jar_path name in
102 |   mkdir_p (Filename.dirname fullname)
103 |   >>= fun () ->
104 |   let auth_fd = Unix.(openfile fullname [O_CREAT; O_TRUNC; O_WRONLY] 0o600) in
105 |   let auth_oc = Unix.out_channel_of_descr auth_fd in
106 |   fprintf auth_oc "%s" (Github_j.string_of_auth auth);
107 |   close_out auth_oc;
108 |   printf "Github cookie jar: created %s\n" fullname;
109 |   return jar
110 | 
111 | (* Delete an authentication token from disk, given the [name] in the jar *)
112 | let delete jar ~name =
113 |   if List.exists (fun re -> Re.execp re name) invalid_names then
114 |     fail (InvalidName name)
115 |   else
116 |     Lwt_unix.unlink (Filename.concat jar.jar_path name)
117 |     >>= fun () ->
118 |     return jar
119 | 
120 | (* Read a JSON auth file in and parse it *)
121 | let read_auth_file { jar_path } name =
122 |   let fname = Filename.concat jar_path name in
123 |   let { Unix.st_perm; _ } = Unix.stat fname in
124 |   let safe_perm = 0o7770 land st_perm in
125 |   begin if safe_perm <> st_perm
126 |     then Unix.chmod fname safe_perm
127 |   end;
128 |   Lwt_io.with_file ~mode:Lwt_io.input fname
129 |     (fun ic ->
130 |        Lwt_stream.fold_s (fun b a -> return (a^b)) (Lwt_io.read_lines ic) ""
131 |        >>= fun buf ->
132 |        return (Github_j.auth_of_string buf)
133 |     )
134 | 
135 | (* Retrieve all the cookies *)
136 | let get_all ({ jar_path } as jar) =
137 |   let rec traverse dir =
138 |     let base = Filename.concat jar_path dir in
139 |     let files = Lwt_unix.files_of_directory base in
140 |     Lwt_stream.fold_s (fun b a ->
141 |       if b = "." || b = ".." then return a else begin
142 |         let path = Filename.concat base b in
143 |         let ident = Filename.concat dir b in
144 |         file_kind_match path
145 |           ~reg:(fun () ->
146 |             read_auth_file jar ident
147 |             >>= fun auth ->
148 |             return ((ident,auth)::a))
149 |           ~dir:(fun () ->
150 |             traverse ident
151 |             >>= fun sub ->
152 |             return (sub@a))
153 |           ~other:(fun () -> return a)
154 |     end
155 |     ) files []
156 |   in traverse ""
157 | 
158 | (* Get one cookie by name *)
159 | let get jar ~name =
160 |   catch (fun () ->
161 |     read_auth_file jar name
162 |     >>= fun auth ->
163 |     return (Some auth)
164 |   ) (fun _ -> return_none)
165 | 


--------------------------------------------------------------------------------
/unix/github_cookie_jar.mli:
--------------------------------------------------------------------------------
 1 | (*
 2 |  * Copyright (c) 2012 Anil Madhavapeddy 
 3 |  * Copyright (c) 2013 David Sheets 
 4 |  *
 5 |  * Permission to use, copy, modify, and distribute this software for any
 6 |  * purpose with or without fee is hereby granted, provided that the above
 7 |  * copyright notice and this permission notice appear in all copies.
 8 |  *
 9 |  * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
10 |  * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
11 |  * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
12 |  * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
13 |  * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
14 |  * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
15 |  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
16 |  *
17 |  *)
18 | 
19 | type t
20 | 
21 | val init : ?jar_path:string -> unit -> t Lwt.t
22 | val save : t -> name:string -> auth:Github_t.auth -> t Lwt.t
23 | val delete : t -> name:string -> t Lwt.t
24 | val get_all : t -> (string * Github_t.auth) list Lwt.t
25 | val get : t -> name:string -> Github_t.auth option Lwt.t
26 | 
27 | val jar_path : t -> string
28 | 


--------------------------------------------------------------------------------