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
181
182
183
184
185
186
187
188
189
190
open Lwt.Infix
type profile =
{ id: string [@ocf Ocf.Wrapper.string, "me"] ;
cert: (string * string) option [@ocf Ocf.Wrapper.(option (pair string string)), None] ;
certificates: string option [@ocf Ocf.Wrapper.(option string), None] ;
cache: string option [@ocf Ocf.Wrapper.(option string), None] ;
debug: bool [@ocf Ocf.Wrapper.bool, false] ;
} [@@ocf];;
let usage = Printf.sprintf "Usage: %s [options] [args]\nwhere options are:" Sys.argv.(0)
let ldp_http_curl profile =
let dbg =
if profile.debug then
Lwt_io.write_line Lwt_io.stderr
else
(fun _ -> Lwt.return_unit)
in
Ldp_curl.make ?cache_dir:profile.cache ?cert:profile.cert ~dbg ()
let ldp_http_tls profile =
let dbg =
if profile.debug then
Lwt_io.write_line Lwt_io.stderr
else
(fun _ -> Lwt.return_unit)
in
Ldp_tls.make ?cache_dir:profile.cache ?cert:profile.cert ~dbg ()
let profiles = Ocf.list profile_wrapper []
let map_filename ?(dir=Sys.getcwd()) fn =
if Filename.is_implicit fn then
Filename.concat dir fn
else
if Filename.is_relative fn then
Filename.concat (Sys.getcwd()) fn
else
fn
let find_profile id =
let rc_dir =
Filename.concat
(try Sys.getenv "HOME"
with _ -> "/")
".solid"
in
let rc_file = Filename.concat rc_dir "profiles.json" in
Ocf.from_file (Ocf.as_group profiles) rc_file ;
let map_opt f = function
| None -> None
| Some s -> Some (f s)
in
try
let p = List.find (fun p -> p.id = id) (Ocf.get profiles) in
{ p with
cert = map_opt (fun (s1, s2) ->
map_filename ~dir:rc_dir s1, map_filename ~dir:rc_dir s2)
p.cert ;
certificates = map_opt (map_filename ~dir:rc_dir) p.certificates ;
cache = map_opt (map_filename ~dir:rc_dir) p.cache ;
}
with Not_found -> failwith (Printf.sprintf "No profile %S" id)
let parse ?(options=[]) ?(usage=usage) () =
let profile = ref default_profile in
let curl = ref false in
let identity id = profile := (find_profile id) in
let privkey s =
match !profile.cert with
None -> profile := { !profile with cert = Some ("", map_filename s) }
| Some (t,_) ->
profile := { !profile with cert = Some (t, map_filename s) }
in
let cert s =
match !profile.cert with
None -> profile := { !profile with cert = Some (map_filename s, "") }
| Some (_,t) ->
profile := { !profile with cert = Some (map_filename s, t) }
in
let certificates s =
profile := { !profile with certificates = Some (map_filename s) }
in
let cache s = profile := { !profile with cache = Some (map_filename s) } in
let nocache s = profile := { !profile with cache = None } in
let debug s = profile := { !profile with debug = true } in
let nodebug s = profile := { !profile with debug = false } in
let base_options =
[ "-p", Arg.String identity,
"id use profile with corresponding id" ;
"--privkey", Arg.String privkey,
Printf.sprintf " <file> read private client key from <file>" ;
"--cert", Arg.String cert,
Printf.sprintf " <file> read client certificate from pem <file>" ;
"--certificates", Arg.String certificates,
" <dir> use certificates in <dir> to authenticate server";
"--curl", Arg.Set curl,
" use curl instead of cohttp+tls to connect" ;
"--cache", Arg.String cache,
" <dir> use <dir> as cache directory" ;
"--nocache", Arg.Unit nocache,
" <dir> do not use cache" ;
"--debug", Arg.Unit debug,
" debug mode on" ;
"--nodebug", Arg.Unit nodebug,
" debug mode off" ;
]
in
let args = ref [] in
Arg.parse (base_options @ options) (fun s -> args := s :: !args) usage ;
let%lwt http =
if !curl then
ldp_http_curl !profile
else
ldp_http_tls !profile
in
Lwt.return (List.rev !args, http)
let print_alert where alert =
let msg = Printf.sprintf "TLS ALERT (%s): %s"
where (Tls.Packet.alert_type_to_string alert)
in
Lwt_io.(write_line stderr msg)
let print_fail where fail =
let msg = Printf.sprintf "TLS FAIL (%s): %s"
where (Tls.Engine.string_of_failure fail)
in
Lwt_io.(write_line stderr msg)
let main ?options ?usage f =
try
let main =
try%lwt
let%lwt (args, http) = parse ?options ?usage () in
f args http
with
| Ldp.Types.Error e ->
Lwt_io.(write_line stderr (Ldp.Types.string_of_error e))
| Tls_lwt.Tls_alert alert ->
print_alert "remote end" alert >>= fun () -> exit 1
| Tls_lwt.Tls_failure alert ->
print_fail "our end" alert >>= fun () -> exit 1
in
Lwt_main.run main
with e ->
let msg =
match e with
| Unix.Unix_error (e,s1,s2) ->
Printf.sprintf "%s: %s %s" s1 (Unix.error_message e) s2
| Failure s | Sys_error s -> s
| _ -> Printexc.to_string e
in
prerr_endline msg;
exit 1