blob: 86be96585a760f3a4ead5cd265dade1c419f7e4d (
plain) (
blame)
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
|
module type GEMINI_TRANSACTION =
sig
type request
module M : MimeType.MIME_TYPE
type status =
| INPUT
| SUCCESS
| SUCCESS_EOCSS
| REDIR_TEMP
| REDIR_PERM
| TEMP_FAIL
| SERVER_UNAVAILABLE
| CGI_ERROR
| PROXY_ERROR
| SLOW_DOWN
| PERM_FAIL
| NOT_FOUND
| GONE
| PROXY_REQ_REFUSED
| BAD_REQ
| CLIENT_CERT_REQUIRED
| TRANSIENT_CERT_REQUESTED
| AUTHORISED_CERT_REQUIRED
| CERT_NOT_ACCEPTED
| FUTURE_CERT_REJECTED
| EXPIRED_CERT_REJECTED
type mime_type = M.t
type response = status * mime_type * string
val make_request : url:string -> request
val int_to_status : int -> status option
val transaction : request -> (response, string) result Lwt.t
end
module GeminiTransaction (M : MimeType.MIME_TYPE) : GEMINI_TRANSACTION
with module M = M =
struct
exception InvalidRequest
type request = { host : string; port : int; url : string; }
module M = M
type mime_type = M.t
type status =
| INPUT
| SUCCESS
| SUCCESS_EOCSS
| REDIR_TEMP
| REDIR_PERM
| TEMP_FAIL
| SERVER_UNAVAILABLE
| CGI_ERROR
| PROXY_ERROR
| SLOW_DOWN
| PERM_FAIL
| NOT_FOUND
| GONE
| PROXY_REQ_REFUSED
| BAD_REQ
| CLIENT_CERT_REQUIRED
| TRANSIENT_CERT_REQUESTED
| AUTHORISED_CERT_REQUIRED
| CERT_NOT_ACCEPTED
| FUTURE_CERT_REJECTED
| EXPIRED_CERT_REJECTED
type response = status * mime_type * string
let make_request ~url:r =
let url = Uri.of_string r in
let () = match Uri.scheme url with
| Some "gemini" -> ()
| _ -> raise InvalidRequest in
let host = match Uri.host url with
| Some h -> h
| _ -> raise InvalidRequest in
let port = match Uri.port url with
| Some p -> p
| _ -> 1965 in
{ host = host; port = port; url = r; }
let int_to_status = function
| 10 -> Some INPUT
| 20 -> Some SUCCESS
| 21 -> Some SUCCESS_EOCSS
| 30 -> Some REDIR_TEMP
| 31 -> Some REDIR_PERM
| 40 -> Some TEMP_FAIL
| 41 -> Some SERVER_UNAVAILABLE
| 42 -> Some CGI_ERROR
| 43 -> Some PROXY_ERROR
| 44 -> Some SLOW_DOWN
| 50 -> Some PERM_FAIL
| 51 -> Some NOT_FOUND
| 52 -> Some GONE
| 53 -> Some PROXY_REQ_REFUSED
| 54 -> Some BAD_REQ
| 60 -> Some CLIENT_CERT_REQUIRED
| 61 -> Some TRANSIENT_CERT_REQUESTED
| 62 -> Some AUTHORISED_CERT_REQUIRED
| 63 -> Some CERT_NOT_ACCEPTED
| 64 -> Some FUTURE_CERT_REJECTED
| 65 -> Some EXPIRED_CERT_REJECTED
| _ -> None
let status_parser : (status, string) result Angstrom.t =
let open Angstrom in
let status_of_string s =
match int_of_string_opt s with
| Some n -> (match int_to_status n with
| Some s -> Ok s
| None -> Error ("Invalid status: " ^ s))
| None -> Error ("Invalid status: " ^ s) in
lift status_of_string (take 2) <?> "status"
let transaction r =
let open Angstrom in
let open ParseCommon.ParseCommon in
let open Angstrom_lwt_unix in
let authenticator ~host:_ _ = Ok None in
let parser =
lift3 (fun status_result -> fun m -> fun r ->
Result.bind status_result (fun status -> Ok (status, M.from_string m, r)))
status_parser
(char ' ' *> take_till_cr)
(take_while (fun _ -> true) <* end_of_input)
<?> "transaction" in
let%lwt (ic, oc) = Tls_lwt.connect_ext
Tls.Config.(client ~authenticator ~ciphers:Ciphers.default ())
(r.host, r.port) in
let%lwt () = Lwt_io.write oc r.url in
let%lwt (_, parsed) = parse parser ic in
Lwt.return (Result.join parsed)
end
|
