blob: 65b80eaae85de2d8aac33a646430f976a55e23a3 (
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
| UNDEFINED of int
type mime_type = M.t
type response = status * mime_type * string
val make_request : url:string -> request
val int_to_status : int -> status
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
| UNDEFINED of int
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 -> INPUT
| 20 -> SUCCESS
| 21 -> SUCCESS_EOCSS
| 30 -> REDIR_TEMP
| 31 -> REDIR_PERM
| 40 -> TEMP_FAIL
| 41 -> SERVER_UNAVAILABLE
| 42 -> CGI_ERROR
| 43 -> PROXY_ERROR
| 44 -> SLOW_DOWN
| 50 -> PERM_FAIL
| 51 -> NOT_FOUND
| 52 -> GONE
| 53 -> PROXY_REQ_REFUSED
| 54 -> BAD_REQ
| 60 -> CLIENT_CERT_REQUIRED
| 61 -> TRANSIENT_CERT_REQUESTED
| 62 -> AUTHORISED_CERT_REQUIRED
| 63 -> CERT_NOT_ACCEPTED
| 64 -> FUTURE_CERT_REJECTED
| 65 -> EXPIRED_CERT_REJECTED
| n -> UNDEFINED n
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 -> Ok (int_to_status n)
| 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
|
