1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
open Lwt.Infix
open Cohttp_lwt_unix
type github_prompt =
| No_Prompt
| Select_Account
| Other of string
let github_prompt_of_yojson = function
| `String "no_prompt" -> Ok No_Prompt
| `String "select_account" -> Ok Select_Account
| `String str -> Ok (Other str)
| _ -> Error "expected `String for pkce_style"
let github_prompt_to_yojson = function
| No_Prompt -> `String "no_prompt"
| Select_Account -> `String "select_account"
| Other str -> `String str
type github_oauth_config = {
client_id: string;
client_secret: string;
redirect_uri: Json_uri.t;
scope: string list;
login: string option;
allow_signup: bool option;
prompt: github_prompt;
} [@@deriving yojson]
type token_response = {
access_token: string;
scope: (string option [@default None]);
token_type: string;
} [@@deriving yojson]
type token_error_code =
| Incorrect_Client_Credentials
| Invalid_Request
| Invalid_Client
| Invalid_Grant
| Unauthorized_Client
| Unsupported_Grant_Type
| Invalid_Scope
| Invalid_Token
let token_error_code_to_yojson = function
| Incorrect_Client_Credentials -> `String "incorrect_client_credentials"
| Invalid_Request -> `String "invalid_request"
| Invalid_Client -> `String "invalid_client"
| Invalid_Grant -> `String "invalid_grant"
| Unauthorized_Client -> `String "unauthorized_client"
| Unsupported_Grant_Type -> `String "unsupported_grant_type"
| Invalid_Scope -> `String "invalid_scope"
| Invalid_Token -> `String "invalid_token"
let token_error_code_of_yojson = function
| `String "incorrect_client_credentials" -> Ok Incorrect_Client_Credentials
| `String "invalid_request" -> Ok Invalid_Request
| `String "invalid_client" -> Ok Invalid_Client
| `String "invalid_grant" -> Ok Invalid_Grant
| `String "unauthorized_client" -> Ok Unauthorized_Client
| `String "unsupported_grant_type" -> Ok Unsupported_Grant_Type
| `String "invalid_scope" -> Ok Invalid_Scope
| `String "invalid_token" -> Ok Invalid_Token
| `String _ -> Ok Invalid_Request
| _ -> Error "expected string for error code"
type token_error = {
error: token_error_code;
error_description: string;
error_uri: (Json_uri.t option [@default None]);
} [@@deriving yojson]
type config =
| GithubOauthConfig of github_oauth_config
[@@deriving yojson]
module DefaultInMemoryStorage = struct
type value = config
let ttl = 3600.0
end
module type GITHUB_CLIENT =
sig
val get_authorization_url : config:config -> ((Uri.t * string), string) result
val exchange_code_for_token : string -> string -> (token_response, string) result Lwt.t
end
module GitHubClient (Storage : Storage.STORAGE_UNIT with type value = config) : GITHUB_CLIENT = struct
let get_authorization_url ~config =
match config with
| GithubOauthConfig gh_config -> begin
let state = Utils.generate_state () in
let params = [
("client_id", gh_config.client_id);
("redirect_uri", Json_uri.to_string gh_config.redirect_uri);
("scope", String.concat " " gh_config.scope);
("state", state);
] @ (
match gh_config.login with
| Some login_value -> [ ("login", login_value) ]
| None -> []
) @ (
match gh_config.allow_signup with
| Some true -> [ ("allow_signup", "true") ]
| Some false -> [ ("allow_signup", "false") ]
| None -> []
) @ (
match gh_config.prompt with
| Select_Account -> [ ("prompt", "select_account") ]
| Other prompt_value -> [ ("prompt", prompt_value) ]
| No_Prompt -> []
) in
Storage.update state config;
let url = Uri.add_query_params' (Uri.of_string "https://github.com/login/oauth/authorize") params in
Ok (url, state)
end
let exchange_code_for_token state code =
match Storage.get state with
| Some ((stored_config), _expires) -> begin
Storage.remove state;
match stored_config with
| GithubOauthConfig config -> begin
let params = [
("client_id", config.client_id);
("client_secret", config.client_secret);
("code", code);
("redirect_uri", Json_uri.to_string config.redirect_uri);
] in
let body = Utils.form_encode params in
Client.post ~body (Uri.of_string "https://github.com/login/oauth/access_token")
>>= fun (_, body) -> Cohttp_lwt.Body.to_string body
>>= fun body_str ->
let decoded = Utils.form_decode body_str in
let token_val = Hashtbl.find_opt decoded "access_token" in
let scope_val = Hashtbl.find_opt decoded "scope" in
let token_type_val = Option.value ~default:"" (Hashtbl.find_opt decoded "token_type") in
let error_val = Hashtbl.find_opt decoded "error" in
let error_desc_val = Option.value ~default:"" (Hashtbl.find_opt decoded "error_description") in
let error_uri_val = Option.value ~default:"" (Hashtbl.find_opt decoded "error_uri") in
match error_val, token_val with
| Some err, None -> begin
print_endline "Error:";
print_endline err;
print_endline error_desc_val;
print_endline error_uri_val;
Lwt.return (Error err)
end
| None, Some token -> begin
Lwt.return (Ok { access_token = token ; scope = scope_val ; token_type = token_type_val })
end
| Some err, Some token -> begin
print_endline "Both an error and a token were received and this is very strange";
print_endline "Error:";
print_endline err;
print_endline error_desc_val;
print_endline error_uri_val;
Lwt.return (Ok { access_token = token ; scope = scope_val ; token_type = token_type_val })
end
| None, None -> begin
print_endline "No error was returned, but also no token. Suspicious.";
Lwt.return (Error "No token received")
end
end
end
| None -> Lwt.return (Error "State value did not match a known session")
end