summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--gemini/geminiTransaction.ml262
-rw-r--r--gemini/geminiTransaction.mli37
2 files changed, 215 insertions, 84 deletions
diff --git a/gemini/geminiTransaction.ml b/gemini/geminiTransaction.ml
index 65b80ea..3cd9bde 100644
--- a/gemini/geminiTransaction.ml
+++ b/gemini/geminiTransaction.ml
@@ -2,19 +2,23 @@ module type GEMINI_TRANSACTION =
sig
type request
+ module T : TlsUtils.TLS_UTILS
+
module M : MimeType.MIME_TYPE
+ type mime_type = M.t
+
type status =
| INPUT
- | SUCCESS
+ | SUCCESS of mime_type
| SUCCESS_EOCSS
- | REDIR_TEMP
- | REDIR_PERM
+ | REDIR_TEMP of string
+ | REDIR_PERM of string
| TEMP_FAIL
| SERVER_UNAVAILABLE
| CGI_ERROR
| PROXY_ERROR
- | SLOW_DOWN
+ | SLOW_DOWN of int
| PERM_FAIL
| NOT_FOUND
| GONE
@@ -26,25 +30,37 @@ sig
| CERT_NOT_ACCEPTED
| FUTURE_CERT_REJECTED
| EXPIRED_CERT_REJECTED
- | UNDEFINED of int
- type mime_type = M.t
+ type response = status * string
+
+ val make_request : ?authenticator:T.authenticator
+ -> ?max_redirects:int -> string -> (request, string) Base.Result.t
- type response = status * mime_type * string
+ val update_request : ?authenticator:T.authenticator
+ -> ?max_redirects:int -> ?url:string
+ -> request -> (request, string) Base.Result.t
- val make_request : url:string -> request
+ val status_of_string : string -> (status, string) Base.Result.t
- val int_to_status : int -> status
+ val int_of_status : status -> int
- val transaction : request -> (response, string) result Lwt.t
+ val name_of_status : status -> string
+
+ val string_of_status : status -> string
+
+ val transaction : request -> (response, string) Base.Result.t Lwt.t
+
+ val session : request -> (response, string) Base.Result.t Lwt.t
end
-module GeminiTransaction (M : MimeType.MIME_TYPE) : GEMINI_TRANSACTION
- with module M = M =
+module GeminiTransaction (M : MimeType.MIME_TYPE) (T : TlsUtils.TLS_UTILS)
+ : GEMINI_TRANSACTION with module M = M and module T = T =
struct
- exception InvalidRequest
+ module T = T
- type request = { host : string; port : int; url : string; }
+ type request = { url : Uri.t;
+ authenticator : T.authenticator;
+ max_redirects : int; }
module M = M
@@ -52,15 +68,15 @@ struct
type status =
| INPUT
- | SUCCESS
+ | SUCCESS of mime_type
| SUCCESS_EOCSS
- | REDIR_TEMP
- | REDIR_PERM
+ | REDIR_TEMP of string
+ | REDIR_PERM of string
| TEMP_FAIL
| SERVER_UNAVAILABLE
| CGI_ERROR
| PROXY_ERROR
- | SLOW_DOWN
+ | SLOW_DOWN of int
| PERM_FAIL
| NOT_FOUND
| GONE
@@ -72,71 +88,171 @@ struct
| CERT_NOT_ACCEPTED
| FUTURE_CERT_REJECTED
| EXPIRED_CERT_REJECTED
- | UNDEFINED of int
- type response = status * mime_type * string
+ type response = status * string
- let make_request ~url:r =
+ let url_of_string 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 Base.Result.Monad_infix in
+ (match Uri.scheme url with
+ | Some "gemini" -> Ok ()
+ | _ -> Error "We only support gemini") >>= (fun () ->
+ match Uri.host url with
+ | Some _ -> Ok ()
+ | _ -> Error "No host in url?") >>= (fun () ->
+ match Uri.port url with
+ | Some _ -> Ok url
+ | None -> Ok (Uri.with_port url (Some 1965)))
+
+ let make_request ?(authenticator=T.null_auth)
+ ?(max_redirects=5) url =
+ let open Base.Result.Monad_infix in
+ url_of_string url >>= (fun url ->
+ Ok { url; authenticator; max_redirects; })
+
+ let update_request ?authenticator ?max_redirects ?url req =
+ let open Base in
+ let url_result = match url with
+ | Some url -> url_of_string url
+ | None -> Ok req.url in
+ Result.bind url_result ~f:(fun url ->
+ Ok { authenticator = Option.value authenticator ~default:req.authenticator;
+ max_redirects = Option.value max_redirects ~default:req.max_redirects;
+ url; })
+
+ let int_of_status = function
+ | INPUT -> 10
+ | SUCCESS _ -> 20
+ | SUCCESS_EOCSS -> 21
+ | REDIR_TEMP _ -> 30
+ | REDIR_PERM _ -> 31
+ | TEMP_FAIL -> 40
+ | SERVER_UNAVAILABLE -> 41
+ | CGI_ERROR -> 42
+ | PROXY_ERROR -> 43
+ | SLOW_DOWN _ -> 44
+ | PERM_FAIL -> 50
+ | NOT_FOUND -> 51
+ | GONE -> 52
+ | PROXY_REQ_REFUSED -> 53
+ | BAD_REQ -> 54
+ | CLIENT_CERT_REQUIRED -> 60
+ | TRANSIENT_CERT_REQUESTED -> 61
+ | AUTHORISED_CERT_REQUIRED -> 62
+ | CERT_NOT_ACCEPTED -> 63
+ | FUTURE_CERT_REJECTED -> 64
+ | EXPIRED_CERT_REJECTED -> 65
+
+ let name_of_status = function
+ | INPUT -> "10 INPUT"
+ | SUCCESS _ -> "20 SUCCESS"
+ | SUCCESS_EOCSS -> "21 SUCCESS - END OF CLIENT CERTIFICATE SESSION"
+ | REDIR_TEMP _ -> "30 REDIRECT - TEMPORARY"
+ | REDIR_PERM _ -> "31 REDIRECT - PERMANENT"
+ | TEMP_FAIL -> "40 TEMPORARY FAILURE"
+ | SERVER_UNAVAILABLE -> "41 SERVER UNAVAILABLE"
+ | CGI_ERROR -> "42 CGI ERROR"
+ | PROXY_ERROR -> "43 PROXY ERROR"
+ | SLOW_DOWN _ -> "44 SLOW DOWN"
+ | PERM_FAIL -> "50 PERMANENT FAILURE"
+ | NOT_FOUND -> "51 NOT FOUND"
+ | GONE -> "52 GONE"
+ | PROXY_REQ_REFUSED -> "53 PROXY REQUEST REFUSED"
+ | BAD_REQ -> "59 BAD REQUEST"
+ | CLIENT_CERT_REQUIRED -> "60 CLIENT CERTIFICATE REQUIRED"
+ | TRANSIENT_CERT_REQUESTED -> "61 TRANSIENT CERTIFICATE REQUESTED"
+ | AUTHORISED_CERT_REQUIRED -> "62 AUTHORISED CERTIFICATE REQUIRED"
+ | CERT_NOT_ACCEPTED -> "63 CERTIFICATE NOT ACCEPTED"
+ | FUTURE_CERT_REJECTED -> "64 FUTURE CERTIFICATE REJECTED"
+ | EXPIRED_CERT_REJECTED -> "65 EXPIRED CERTIFICATE REJECTED"
+
+ let string_of_status = function
+ | INPUT -> "10 "
+ | SUCCESS m -> "20 " ^ (M.to_canonical m)
+ | SUCCESS_EOCSS -> "21 "
+ | REDIR_TEMP u -> "30 " ^ u
+ | REDIR_PERM u -> "31 " ^ u
+ | TEMP_FAIL -> "40 "
+ | SERVER_UNAVAILABLE -> "41 "
+ | CGI_ERROR -> "42 "
+ | PROXY_ERROR -> "43 "
+ | SLOW_DOWN n -> "44 " ^ (string_of_int n)
+ | PERM_FAIL -> "50 "
+ | NOT_FOUND -> "51 "
+ | GONE -> "52 "
+ | PROXY_REQ_REFUSED -> "53 "
+ | BAD_REQ -> "59 "
+ | CLIENT_CERT_REQUIRED -> "60 "
+ | TRANSIENT_CERT_REQUESTED -> "61 "
+ | AUTHORISED_CERT_REQUIRED -> "62 "
+ | CERT_NOT_ACCEPTED -> "63 "
+ | FUTURE_CERT_REJECTED -> "64 "
+ | EXPIRED_CERT_REJECTED -> "65 "
+
+ let status_parser : status 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 open ParseCommon.ParseCommon in
+ (string "10 " *> return INPUT)
+ <|> lift (fun m -> SUCCESS (M.from_string m)) (string "20 " *> take_till_cr)
+ <|> (string "21 " *> return SUCCESS_EOCSS)
+ <|> lift (fun u -> REDIR_TEMP u) (string "30 " *> take_till_cr)
+ <|> lift (fun u -> REDIR_PERM u) (string "31 " *> take_till_cr)
+ <|> (string "40 " *> return TEMP_FAIL)
+ <|> (string "41 " *> return SERVER_UNAVAILABLE)
+ <|> (string "42 " *> return CGI_ERROR)
+ <|> (string "43 " *> return PROXY_ERROR)
+ <|> lift (fun n -> SLOW_DOWN (int_of_string n)) (string "44 " *> take_till_cr)
+ <|> (string "50 " *> return PERM_FAIL)
+ <|> (string "51 " *> return NOT_FOUND)
+ <|> (string "52 " *> return GONE)
+ <|> (string "53 " *> return PROXY_REQ_REFUSED)
+ <|> (string "59 " *> return BAD_REQ)
+ <|> (string "60 " *> return CLIENT_CERT_REQUIRED)
+ <|> (string "61 " *> return TRANSIENT_CERT_REQUESTED)
+ <|> (string "62 " *> return AUTHORISED_CERT_REQUIRED)
+ <|> (string "63 " *> return CERT_NOT_ACCEPTED)
+ <|> (string "64 " *> return FUTURE_CERT_REJECTED)
+ <|> (string "65 " *> return EXPIRED_CERT_REJECTED)
+ <|> fail "Invalid status"
+ <?> "status"
+
+ let status_of_string = Angstrom.parse_string ~consume:All status_parser
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)))
+ lift2 (fun status -> fun r ->
+ Ok (status, 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)
+ let host = Base.Option.value_exn (Uri.host r.url)
+ ~message:"URL with no host?" in
+ let port = Base.Option.value_exn (Uri.port r.url)
+ ~message:"URL with no port?" in
+ let%lwt authenticator = r.authenticator in
+ try%lwt
+ let%lwt (ic, oc) = Tls_lwt.connect_ext
+ Tls.Config.(client ~peer_name:host ~authenticator
+ ~ciphers:Ciphers.supported ()) (host, port) in
+ let%lwt () = Lwt_io.write oc (Uri.to_string r.url ^ "\r\n") in
+ let%lwt (_, parsed) = parse parser ic in
+ Lwt.return (Result.join parsed)
+ with | Tls_lwt.Tls_alert alert -> Lwt.return (Error (Tls.Packet.alert_type_to_string alert))
+
+ let rec session req =
+ match%lwt transaction req with
+ | Ok (SUCCESS m, r) -> Lwt.return (Ok (SUCCESS m, r))
+ | Ok (REDIR_TEMP url, _)
+ | Ok (REDIR_PERM url, _) ->
+ if req.max_redirects > 1 then
+ match update_request ~url
+ ~max_redirects:(req.max_redirects - 1) req with
+ | Ok req -> session req
+ | Error m -> Lwt.return (Error m)
+ else
+ Lwt.return (Error "Too many redirects")
+ | Ok x -> Lwt.return (Ok x)
+ | Base.Error m -> Lwt.return (Error m)
end
diff --git a/gemini/geminiTransaction.mli b/gemini/geminiTransaction.mli
index b31d9e0..ecd7349 100644
--- a/gemini/geminiTransaction.mli
+++ b/gemini/geminiTransaction.mli
@@ -2,19 +2,23 @@ module type GEMINI_TRANSACTION =
sig
type request
+ module T : TlsUtils.TLS_UTILS
+
module M : MimeType.MIME_TYPE
+ type mime_type = M.t
+
type status =
| INPUT
- | SUCCESS
+ | SUCCESS of mime_type
| SUCCESS_EOCSS
- | REDIR_TEMP
- | REDIR_PERM
+ | REDIR_TEMP of string
+ | REDIR_PERM of string
| TEMP_FAIL
| SERVER_UNAVAILABLE
| CGI_ERROR
| PROXY_ERROR
- | SLOW_DOWN
+ | SLOW_DOWN of int
| PERM_FAIL
| NOT_FOUND
| GONE
@@ -26,17 +30,28 @@ sig
| CERT_NOT_ACCEPTED
| FUTURE_CERT_REJECTED
| EXPIRED_CERT_REJECTED
- | UNDEFINED of int
- type mime_type = M.t
+ type response = status * string
+
+ val make_request : ?authenticator:T.authenticator
+ -> ?max_redirects:int -> string -> (request, string) Base.Result.t
+
+ val update_request : ?authenticator:T.authenticator
+ -> ?max_redirects:int -> ?url:string
+ -> request -> (request, string) Base.Result.t
+
+ val status_of_string : string -> (status, string) Base.Result.t
+
+ val int_of_status : status -> int
- type response = status * mime_type * string
+ val name_of_status : status -> string
- val make_request : url:string -> request
+ val string_of_status : status -> string
- val int_to_status : int -> status
+ val transaction : request -> (response, string) Base.Result.t Lwt.t
- val transaction : request -> (response, string) result Lwt.t
+ val session : request -> (response, string) Base.Result.t Lwt.t
end
-module GeminiTransaction (M : MimeType.MIME_TYPE) : GEMINI_TRANSACTION with module M = M
+module GeminiTransaction (M : MimeType.MIME_TYPE) (T : TlsUtils.TLS_UTILS)
+ : GEMINI_TRANSACTION with module M = M and module T = T
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-26 18:54:32 +0000