Owntracks location tracking with MQTT and HTTPS (recorder) support
fmt
+897
-666
+1
-1
bin/dune
+1
-1
bin/dune
+378
-195
bin/main.ml
+378
-195
bin/main.ml
···
46
46
devices : device list;
47
47
}
48
48
49
-
let empty_owntracks = {
50
-
topic = None;
51
-
default_device = None;
52
-
recorder = empty_recorder;
53
-
devices = [];
54
-
}
49
+
let empty_owntracks =
50
+
{
51
+
topic = None;
52
+
default_device = None;
53
+
recorder = empty_recorder;
54
+
devices = [];
55
+
}
55
56
56
57
let owntracks_codec : owntracks Tomlt.t =
57
58
Tomlt.(
58
59
Table.(
59
60
obj (fun topic default_device recorder devices ->
60
-
{ topic; default_device;
61
+
{
62
+
topic;
63
+
default_device;
61
64
recorder = Option.value ~default:empty_recorder recorder;
62
-
devices = Option.value ~default:[] devices })
65
+
devices = Option.value ~default:[] devices;
66
+
})
63
67
|> opt_mem "topic" string ~enc:(fun c -> c.topic)
64
68
|> opt_mem "default_device" string ~enc:(fun c -> c.default_device)
65
-
|> opt_mem "recorder" recorder_codec
66
-
~enc:(fun c -> if c.recorder = empty_recorder then None else Some c.recorder)
67
-
|> opt_mem "devices" (list device_codec)
68
-
~enc:(fun c -> match c.devices with [] -> None | ds -> Some ds)
69
+
|> opt_mem "recorder" recorder_codec ~enc:(fun c ->
70
+
if c.recorder = empty_recorder then None else Some c.recorder)
71
+
|> opt_mem "devices" (list device_codec) ~enc:(fun c ->
72
+
match c.devices with [] -> None | ds -> Some ds)
69
73
|> finish))
70
74
71
75
type t = {
···
88
92
{
89
93
owntracks = Option.value ~default:empty_owntracks owntracks;
90
94
mqtt =
91
-
Option.value ~default:Mqtte_cmd.Config_file.empty_mqtt_config mqtt;
95
+
Option.value ~default:Mqtte_cmd.Config_file.empty_mqtt_config
96
+
mqtt;
92
97
pool =
93
-
Option.value ~default:Mqtte_cmd.Config_file.empty_pool_config pool;
98
+
Option.value ~default:Mqtte_cmd.Config_file.empty_pool_config
99
+
pool;
94
100
})
95
-
|> opt_mem "owntracks" owntracks_codec
96
-
~enc:(fun c ->
97
-
if c.owntracks = empty_owntracks then None else Some c.owntracks)
98
-
|> opt_mem "mqtt" Mqtte_cmd.Config_file.mqtt_codec
99
-
~enc:(fun c ->
100
-
if c.mqtt = Mqtte_cmd.Config_file.empty_mqtt_config then None
101
-
else Some c.mqtt)
102
-
|> opt_mem "pool" Mqtte_cmd.Config_file.pool_codec
103
-
~enc:(fun c ->
104
-
if c.pool = Mqtte_cmd.Config_file.empty_pool_config then None
105
-
else Some c.pool)
101
+
|> opt_mem "owntracks" owntracks_codec ~enc:(fun c ->
102
+
if c.owntracks = empty_owntracks then None else Some c.owntracks)
103
+
|> opt_mem "mqtt" Mqtte_cmd.Config_file.mqtt_codec ~enc:(fun c ->
104
+
if c.mqtt = Mqtte_cmd.Config_file.empty_mqtt_config then None
105
+
else Some c.mqtt)
106
+
|> opt_mem "pool" Mqtte_cmd.Config_file.pool_codec ~enc:(fun c ->
107
+
if c.pool = Mqtte_cmd.Config_file.empty_pool_config then None
108
+
else Some c.pool)
106
109
|> finish))
107
110
108
111
let load xdg =
109
-
match Xdge.find_config_file xdg "owntracks.toml" with
110
-
| Some path ->
111
-
(try Some (Tomlt_eio.decode_file_exn codec path)
112
-
with exn ->
113
-
Logs.warn (fun m ->
114
-
m "Failed to parse owntracks.toml: %s" (Printexc.to_string exn));
115
-
None)
112
+
match Xdge.config_file xdg "owntracks.toml" with
113
+
| Some path -> (
114
+
try Some (Tomlt_eio.decode_file_exn codec path)
115
+
with exn ->
116
+
Logs.warn (fun m ->
117
+
m "Failed to parse owntracks.toml: %s" (Printexc.to_string exn));
118
+
None)
116
119
| None -> None
117
120
118
121
let resolve_device_name config device_id =
···
121
124
config.owntracks.devices
122
125
|> Option.value ~default:device_id
123
126
124
-
let to_mqtt_config t : Mqtte_cmd.Config_file.t = { mqtt = t.mqtt; pool = t.pool }
127
+
let to_mqtt_config t : Mqtte_cmd.Config_file.t =
128
+
{ mqtt = t.mqtt; pool = t.pool }
125
129
126
130
let default_toml =
127
131
{|# OwnTracks Configuration
···
162
166
| Ok ot_msg -> (
163
167
match Owntracks.Mqtt.message ot_msg with
164
168
| Owntracks.Message.Location loc ->
165
-
let user = Option.value ~default:"unknown" (Owntracks.Mqtt.user ot_msg) in
166
-
let device = Option.value ~default:"unknown" (Owntracks.Mqtt.device ot_msg) in
169
+
let user =
170
+
Option.value ~default:"unknown" (Owntracks.Mqtt.user ot_msg)
171
+
in
172
+
let device =
173
+
Option.value ~default:"unknown" (Owntracks.Mqtt.device ot_msg)
174
+
in
167
175
let device_name = Config.resolve_device_name config device in
168
176
Format.printf "@[<v 0>-------------------------------------------@,";
169
177
Format.printf " Device: %s" device_name;
170
178
if device_name <> device then Format.printf " (%s)" device;
171
179
Format.printf "@, User: %s@," user;
172
-
Format.printf " Time: %s@," (Owntracks.Location.format_timestamp (Owntracks.Location.tst loc));
173
-
Format.printf " Location: %.6f, %.6f@," (Owntracks.Location.lat loc) (Owntracks.Location.lon loc);
174
-
Option.iter (fun v -> Format.printf " Altitude: %.1f m@," v) (Owntracks.Location.alt loc);
175
-
Option.iter (fun v -> Format.printf " Accuracy: +/- %.0f m@," v) (Owntracks.Location.acc loc);
176
-
Option.iter (fun v -> Format.printf " Speed: %.1f km/h@," v) (Owntracks.Location.vel loc);
177
-
Option.iter (fun v -> Format.printf " Battery: %d%%@," v) (Owntracks.Location.batt loc);
180
+
Format.printf " Time: %s@,"
181
+
(Owntracks.Location.format_timestamp (Owntracks.Location.tst loc));
182
+
Format.printf " Location: %.6f, %.6f@,"
183
+
(Owntracks.Location.lat loc)
184
+
(Owntracks.Location.lon loc);
185
+
Option.iter
186
+
(fun v -> Format.printf " Altitude: %.1f m@," v)
187
+
(Owntracks.Location.alt loc);
188
+
Option.iter
189
+
(fun v -> Format.printf " Accuracy: +/- %.0f m@," v)
190
+
(Owntracks.Location.acc loc);
191
+
Option.iter
192
+
(fun v -> Format.printf " Speed: %.1f km/h@," v)
193
+
(Owntracks.Location.vel loc);
194
+
Option.iter
195
+
(fun v -> Format.printf " Battery: %d%%@," v)
196
+
(Owntracks.Location.batt loc);
178
197
Format.printf "-------------------------------------------@]@."
179
198
| Owntracks.Message.Transition tr ->
180
-
let device = Option.value ~default:"unknown" (Owntracks.Mqtt.device ot_msg) in
199
+
let device =
200
+
Option.value ~default:"unknown" (Owntracks.Mqtt.device ot_msg)
201
+
in
181
202
let device_name = Config.resolve_device_name config device in
182
203
Format.printf "[%s] %s region: %s@." device_name
183
204
(String.uppercase_ascii (Owntracks.Transition.event tr))
···
188
209
(** {1 Commands} *)
189
210
190
211
let listen_cmd ~fs =
191
-
let xdg = Xdge.create fs app_name in
212
+
let xdg = Xdge.v fs app_name in
192
213
let config = Config.load xdg |> Option.value ~default:Config.empty in
193
214
let mqtt_config = Config.to_mqtt_config config in
194
215
···
203
224
match topic with
204
225
| Some t -> t
205
226
| None ->
206
-
Option.value ~default:Owntracks.Mqtt.default_topic config.owntracks.topic
227
+
Option.value ~default:Owntracks.Mqtt.default_topic
228
+
config.owntracks.topic
207
229
in
208
230
209
231
Logs.info (fun m -> m "OwnTracks Location Listener");
···
222
244
let clock = Eio.Stdenv.clock env in
223
245
224
246
let pool =
225
-
Mqtte_cmd.create_pool ~sw ~net ~clock ~tls:conn.tls ~insecure:conn.insecure
226
-
~pool_config:mqtt.pool_config ()
247
+
Mqtte_cmd.create_pool ~sw ~net ~clock ~tls:conn.tls
248
+
~insecure:conn.insecure ~pool_config:mqtt.pool_config ()
227
249
in
228
250
let endpoint = Mqtte_cmd.endpoint conn in
229
251
···
248
270
let topic =
249
271
let doc = "MQTT topic (supports wildcards). Default: owntracks/#" in
250
272
let env = Cmd.Env.info "OWNTRACKS_TOPIC" ~doc in
251
-
Arg.(value & opt (some string) None & info [ "t"; "topic" ] ~docv:"TOPIC" ~doc ~env)
273
+
Arg.(
274
+
value
275
+
& opt (some string) None
276
+
& info [ "t"; "topic" ] ~docv:"TOPIC" ~doc ~env)
252
277
in
253
278
let term =
254
279
Term.(
···
272
297
let devices_cmd ~fs:_ =
273
298
let run () =
274
299
Eio_main.run @@ fun env ->
275
-
let xdg = Xdge.create (Eio.Stdenv.fs env) app_name in
300
+
let xdg = Xdge.v (Eio.Stdenv.fs env) app_name in
276
301
(match Config.load xdg with
277
302
| Some config when config.owntracks.devices <> [] ->
278
303
Format.printf "Configured devices:@.@.";
···
282
307
config.owntracks.default_device = Some d.id
283
308
|| config.owntracks.default_device = Some d.name
284
309
in
285
-
Format.printf " %s%s@. ID: %s@."
286
-
d.name
310
+
Format.printf " %s%s@. ID: %s@." d.name
287
311
(if is_default then " (default)" else "")
288
312
d.id)
289
313
config.owntracks.devices
···
307
331
308
332
(** Decode string list, trying results wrapper first then plain array. *)
309
333
let decode_string_list body =
310
-
match Jsont_bytesrw.decode_string Owntracks.Recorder.string_list_results_jsont body with
334
+
match
335
+
Jsont_bytesrw.decode_string Owntracks.Recorder.string_list_results_jsont
336
+
body
337
+
with
311
338
| Ok items -> items
312
-
| Error _ ->
313
-
match Jsont_bytesrw.decode_string Owntracks.Recorder.string_list_jsont body with
339
+
| Error _ -> (
340
+
match
341
+
Jsont_bytesrw.decode_string Owntracks.Recorder.string_list_jsont body
342
+
with
314
343
| Ok items -> items
315
-
| Error _ -> []
344
+
| Error _ -> [])
316
345
317
346
(** Decode locations, trying array first then data wrapper. *)
318
347
let decode_locations body =
319
-
match Jsont_bytesrw.decode_string Owntracks.Recorder.locations_jsont body with
348
+
match
349
+
Jsont_bytesrw.decode_string Owntracks.Recorder.locations_jsont body
350
+
with
320
351
| Ok locs -> locs
321
-
| Error _ ->
322
-
match Jsont_bytesrw.decode_string Owntracks.Recorder.locations_data_jsont body with
352
+
| Error _ -> (
353
+
match
354
+
Jsont_bytesrw.decode_string Owntracks.Recorder.locations_data_jsont
355
+
body
356
+
with
323
357
| Ok locs -> locs
324
-
| Error _ -> []
358
+
| Error _ -> [])
325
359
326
360
let list_users ~sw env ~verbose_http ~recorder_url ?auth () : string list =
327
361
let url = Printf.sprintf "%s/api/0/list" recorder_url in
···
329
363
Logs.set_level (Some Logs.Debug);
330
364
Logs.set_reporter (Logs_fmt.reporter ())
331
365
end;
332
-
let session = Requests.create ~sw env in
333
-
let headers = match auth with
366
+
let session = Requests.v ~sw env in
367
+
let headers =
368
+
match auth with
334
369
| Some (username, password) ->
335
370
Requests.Headers.empty |> Requests.Headers.basic ~username ~password
336
371
| None -> Requests.Headers.empty
···
339
374
if Requests.Response.ok response then begin
340
375
let body = Requests.Response.body response |> Eio.Flow.read_all in
341
376
decode_string_list body
342
-
end else begin
377
+
end
378
+
else begin
343
379
Format.eprintf "HTTP error: %d@." (Requests.Response.status_code response);
344
380
[]
345
381
end
346
382
347
-
let list_devices ~sw env ~verbose_http ~recorder_url ~user ?auth () : string list =
348
-
let url = Printf.sprintf "%s/api/0/list?user=%s" recorder_url (Uri.pct_encode user) in
383
+
let list_devices ~sw env ~verbose_http ~recorder_url ~user ?auth () :
384
+
string list =
385
+
let url =
386
+
Printf.sprintf "%s/api/0/list?user=%s" recorder_url (Uri.pct_encode user)
387
+
in
349
388
if verbose_http then begin
350
389
Logs.set_level (Some Logs.Debug);
351
390
Logs.set_reporter (Logs_fmt.reporter ())
352
391
end;
353
-
let session = Requests.create ~sw env in
354
-
let headers = match auth with
392
+
let session = Requests.v ~sw env in
393
+
let headers =
394
+
match auth with
355
395
| Some (username, password) ->
356
396
Requests.Headers.empty |> Requests.Headers.basic ~username ~password
357
397
| None -> Requests.Headers.empty
···
360
400
if Requests.Response.ok response then begin
361
401
let body = Requests.Response.body response |> Eio.Flow.read_all in
362
402
decode_string_list body
363
-
end else begin
403
+
end
404
+
else begin
364
405
Format.eprintf "HTTP error: %d@." (Requests.Response.status_code response);
365
406
[]
366
407
end
367
408
368
-
let fetch_locations ~sw env ~verbose_http ~recorder_url ~user ~device ~from_date ~to_date ?auth () : Owntracks.Location.t list =
369
-
let url = Printf.sprintf "%s/api/0/locations?user=%s&device=%s&from=%s&to=%s"
370
-
recorder_url
371
-
(Uri.pct_encode user)
372
-
(Uri.pct_encode device)
373
-
from_date
374
-
to_date
409
+
let fetch_locations ~sw env ~verbose_http ~recorder_url ~user ~device
410
+
~from_date ~to_date ?auth () : Owntracks.Location.t list =
411
+
let url =
412
+
Printf.sprintf "%s/api/0/locations?user=%s&device=%s&from=%s&to=%s"
413
+
recorder_url (Uri.pct_encode user) (Uri.pct_encode device) from_date
414
+
to_date
375
415
in
376
416
Format.eprintf "Fetching from %s...@." url;
377
417
(* Set up verbose logging if requested *)
···
379
419
Logs.set_level (Some Logs.Debug);
380
420
Logs.set_reporter (Logs_fmt.reporter ())
381
421
end;
382
-
let session = Requests.create ~sw env in
383
-
let headers = match auth with
422
+
let session = Requests.v ~sw env in
423
+
let headers =
424
+
match auth with
384
425
| Some (username, password) ->
385
426
Requests.Headers.empty |> Requests.Headers.basic ~username ~password
386
427
| None -> Requests.Headers.empty
···
389
430
if Requests.Response.ok response then begin
390
431
let body = Requests.Response.body response |> Eio.Flow.read_all in
391
432
decode_locations body
392
-
end else begin
433
+
end
434
+
else begin
393
435
Format.eprintf "HTTP error: %d@." (Requests.Response.status_code response);
394
436
[]
395
437
end
396
438
end
397
439
398
440
let geojson_cmd ~fs =
399
-
let xdg = Xdge.create fs app_name in
441
+
let xdg = Xdge.v fs app_name in
400
442
let config = Config.load xdg |> Option.value ~default:Config.empty in
401
443
let mqtt_config = Config.to_mqtt_config config in
402
444
···
404
446
let today () =
405
447
let now = Unix.gettimeofday () in
406
448
let tm = Unix.gmtime now in
407
-
Printf.sprintf "%04d-%02d-%02d" (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
449
+
Printf.sprintf "%04d-%02d-%02d" (tm.Unix.tm_year + 1900)
450
+
(tm.Unix.tm_mon + 1) tm.Unix.tm_mday
408
451
in
409
452
410
-
let run parsed topic device duration track from_date to_date user recorder_url recorder_user recorder_password verbose_http =
411
-
let device = match device with Some _ -> device | None -> config.owntracks.default_device in
412
-
let recorder_url = match recorder_url with Some _ -> recorder_url | None -> config.owntracks.recorder.url in
413
-
let recorder_user = match recorder_user with Some _ -> recorder_user | None -> config.owntracks.recorder.user in
414
-
let recorder_password = match recorder_password with Some _ -> recorder_password | None -> config.owntracks.recorder.password in
453
+
let run parsed topic device duration track from_date to_date user recorder_url
454
+
recorder_user recorder_password verbose_http =
455
+
let device =
456
+
match device with
457
+
| Some _ -> device
458
+
| None -> config.owntracks.default_device
459
+
in
460
+
let recorder_url =
461
+
match recorder_url with
462
+
| Some _ -> recorder_url
463
+
| None -> config.owntracks.recorder.url
464
+
in
465
+
let recorder_user =
466
+
match recorder_user with
467
+
| Some _ -> recorder_user
468
+
| None -> config.owntracks.recorder.user
469
+
in
470
+
let recorder_password =
471
+
match recorder_password with
472
+
| Some _ -> recorder_password
473
+
| None -> config.owntracks.recorder.password
474
+
in
415
475
416
476
(* If --from is specified, use HTTP API instead of MQTT *)
417
477
match from_date with
418
-
| Some from_date ->
478
+
| Some from_date -> (
419
479
let to_date = Option.value to_date ~default:(today ()) in
420
480
(* Default user from config recorder.user, then "owntracks" *)
421
-
let user = match user with
481
+
let user =
482
+
match user with
422
483
| Some u -> u
423
-
| None -> Option.value config.owntracks.recorder.user ~default:"owntracks"
484
+
| None ->
485
+
Option.value config.owntracks.recorder.user ~default:"owntracks"
424
486
in
425
487
(* Default device from config default_device, then "phone" *)
426
-
let device = Option.value device ~default:(Option.value config.owntracks.default_device ~default:"phone") in
427
-
(match recorder_url with
428
-
| None ->
429
-
Format.eprintf "Error: --recorder-url or recorder_url config required for historical queries@.";
430
-
1
431
-
| Some recorder_url ->
432
-
let auth = match (recorder_user, recorder_password) with
433
-
| (Some u, Some p) -> Some (u, p)
434
-
| _ -> None
435
-
in
436
-
Eio_main.run @@ fun env ->
437
-
Mirage_crypto_rng_unix.use_default ();
438
-
Eio.Switch.run @@ fun sw ->
439
-
let locations = Recorder.fetch_locations ~sw env ~verbose_http ~recorder_url ~user ~device ~from_date ~to_date ?auth () in
440
-
match locations with
441
-
| [] ->
442
-
Format.eprintf "No locations found for %s/%s from %s to %s@." user device from_date to_date;
443
-
1
444
-
| locs ->
445
-
let device_name = Config.resolve_device_name config device in
446
-
let json = Owntracks.Geojson.linestring_feature ~device_name locs in
447
-
print_endline (Owntracks.Geojson.to_string json);
448
-
0)
488
+
let device =
489
+
Option.value device
490
+
~default:
491
+
(Option.value config.owntracks.default_device ~default:"phone")
492
+
in
493
+
match recorder_url with
494
+
| None ->
495
+
Format.eprintf
496
+
"Error: --recorder-url or recorder_url config required for \
497
+
historical queries@.";
498
+
1
499
+
| Some recorder_url -> (
500
+
let auth =
501
+
match (recorder_user, recorder_password) with
502
+
| Some u, Some p -> Some (u, p)
503
+
| _ -> None
504
+
in
505
+
Eio_main.run @@ fun env ->
506
+
Mirage_crypto_rng_unix.use_default ();
507
+
Eio.Switch.run @@ fun sw ->
508
+
let locations =
509
+
Recorder.fetch_locations ~sw env ~verbose_http ~recorder_url ~user
510
+
~device ~from_date ~to_date ?auth ()
511
+
in
512
+
match locations with
513
+
| [] ->
514
+
Format.eprintf "No locations found for %s/%s from %s to %s@."
515
+
user device from_date to_date;
516
+
1
517
+
| locs ->
518
+
let device_name = Config.resolve_device_name config device in
519
+
let json =
520
+
Owntracks.Geojson.linestring_feature ~device_name locs
521
+
in
522
+
print_endline (Owntracks.Geojson.to_string json);
523
+
0))
449
524
| None ->
450
525
(* Use MQTT for real-time data *)
451
526
let mqtt = parsed.Mqtte_cmd.mqtt in
452
527
let conn = mqtt.connection in
453
528
let topic =
454
529
Option.value topic
455
-
~default:(Option.value ~default:Owntracks.Mqtt.default_topic config.owntracks.topic)
530
+
~default:
531
+
(Option.value ~default:Owntracks.Mqtt.default_topic
532
+
config.owntracks.topic)
456
533
in
457
534
let result = ref None in
458
535
let track_points = ref [] in
···
466
543
467
544
let on_message msg =
468
545
let open Mqtte_eio.Client in
469
-
match Owntracks.Mqtt.of_mqtt ~topic:msg.topic ~payload:msg.payload with
546
+
match
547
+
Owntracks.Mqtt.of_mqtt ~topic:msg.topic ~payload:msg.payload
548
+
with
470
549
| Ok ot_msg -> (
471
550
match Owntracks.Mqtt.message ot_msg with
472
551
| Owntracks.Message.Location loc ->
473
-
let msg_device = Option.value ~default:"unknown" (Owntracks.Mqtt.device ot_msg) in
474
-
let matches = match device with
552
+
let msg_device =
553
+
Option.value ~default:"unknown"
554
+
(Owntracks.Mqtt.device ot_msg)
555
+
in
556
+
let matches =
557
+
match device with
475
558
| None -> true
476
-
| Some d -> d = msg_device || d = Config.resolve_device_name config msg_device
559
+
| Some d ->
560
+
d = msg_device
561
+
|| d = Config.resolve_device_name config msg_device
477
562
in
478
563
if matches then begin
479
-
let device_name = Config.resolve_device_name config msg_device in
564
+
let device_name =
565
+
Config.resolve_device_name config msg_device
566
+
in
480
567
if track then begin
481
568
track_device_name := device_name;
482
569
track_points := loc :: !track_points
483
-
end else if Option.is_none !result then
484
-
result := Some (Owntracks.Geojson.point_feature ~device_name loc)
570
+
end
571
+
else if Option.is_none !result then
572
+
result :=
573
+
Some (Owntracks.Geojson.point_feature ~device_name loc)
485
574
end
486
575
| _ -> ())
487
576
| Error _ -> ()
···
489
578
let on_disconnect () = () in
490
579
491
580
let pool =
492
-
Mqtte_cmd.create_pool ~sw ~net ~clock ~tls:conn.tls ~insecure:conn.insecure
493
-
~pool_config:mqtt.pool_config ()
581
+
Mqtte_cmd.create_pool ~sw ~net ~clock ~tls:conn.tls
582
+
~insecure:conn.insecure ~pool_config:mqtt.pool_config ()
494
583
in
495
584
let endpoint = Mqtte_cmd.endpoint conn in
496
585
497
586
let client =
498
-
Mqtte_eio.Client.connect_with_pool ~sw ~clock ~on_message ~on_disconnect
499
-
~config:mqtt.config ~pool ~endpoint ()
587
+
Mqtte_eio.Client.connect_with_pool ~sw ~clock ~on_message
588
+
~on_disconnect ~config:mqtt.config ~pool ~endpoint ()
500
589
in
501
590
502
591
Mqtte_eio.Client.subscribe ~qos:`At_least_once [ topic ] client;
···
505
594
(* Track mode: collect points for the full duration *)
506
595
let deadline = Eio.Time.now clock +. duration in
507
596
Format.eprintf "Collecting track for %.0f seconds...@." duration;
508
-
while Eio.Time.now clock < deadline && Mqtte_eio.Client.is_connected client do
597
+
while
598
+
Eio.Time.now clock < deadline
599
+
&& Mqtte_eio.Client.is_connected client
600
+
do
509
601
Eio.Time.sleep clock 0.5
510
602
done;
511
603
Mqtte_eio.Client.disconnect client;
512
604
match !track_points with
513
605
| [] ->
514
-
Format.eprintf "No locations received within %.0f seconds@." duration;
606
+
Format.eprintf "No locations received within %.0f seconds@."
607
+
duration;
515
608
1
516
609
| points ->
517
-
let json = Owntracks.Geojson.linestring_feature ~device_name:!track_device_name points in
610
+
let json =
611
+
Owntracks.Geojson.linestring_feature
612
+
~device_name:!track_device_name points
613
+
in
518
614
print_endline (Owntracks.Geojson.to_string json);
519
615
0
520
-
end else begin
616
+
end
617
+
else begin
521
618
(* Single point mode: wait for first location then exit immediately *)
522
619
let deadline = Eio.Time.now clock +. duration in
523
-
while Option.is_none !result && Eio.Time.now clock < deadline && Mqtte_eio.Client.is_connected client do
620
+
while
621
+
Option.is_none !result
622
+
&& Eio.Time.now clock < deadline
623
+
&& Mqtte_eio.Client.is_connected client
624
+
do
524
625
Eio.Time.sleep clock 0.1
525
626
done;
526
627
Mqtte_eio.Client.disconnect client;
···
529
630
print_endline (Owntracks.Geojson.to_string json);
530
631
0
531
632
| None ->
532
-
Format.eprintf "No location received within %.0f seconds@." duration;
633
+
Format.eprintf "No location received within %.0f seconds@."
634
+
duration;
533
635
1
534
636
end
535
637
in
536
638
let topic =
537
639
let doc = "MQTT topic (supports wildcards). Default: owntracks/#" in
538
-
Arg.(value & opt (some string) None & info [ "t"; "topic" ] ~docv:"TOPIC" ~doc)
640
+
Arg.(
641
+
value & opt (some string) None & info [ "t"; "topic" ] ~docv:"TOPIC" ~doc)
539
642
in
540
643
let device =
541
-
let doc = "Filter by device name or ID. Defaults to default_device from config." in
542
-
Arg.(value & opt (some string) None & info [ "d"; "device" ] ~docv:"DEVICE" ~doc)
644
+
let doc =
645
+
"Filter by device name or ID. Defaults to default_device from config."
646
+
in
647
+
Arg.(
648
+
value
649
+
& opt (some string) None
650
+
& info [ "d"; "device" ] ~docv:"DEVICE" ~doc)
543
651
in
544
652
let duration =
545
-
let doc = "Duration in seconds to wait for location (single point) or collect track data (with --track)" in
653
+
let doc =
654
+
"Duration in seconds to wait for location (single point) or collect \
655
+
track data (with --track)"
656
+
in
546
657
Arg.(value & opt float 30.0 & info [ "duration" ] ~docv:"SECONDS" ~doc)
547
658
in
548
659
let track =
549
-
let doc = "Collect a track (LineString) instead of a single point. \
550
-
Use --duration to set collection duration (e.g., --duration 86400 for 24h)." in
660
+
let doc =
661
+
"Collect a track (LineString) instead of a single point. Use --duration \
662
+
to set collection duration (e.g., --duration 86400 for 24h)."
663
+
in
551
664
Arg.(value & flag & info [ "track" ] ~doc)
552
665
in
553
666
let from_date =
554
-
let doc = "Start date for historical query (YYYY-MM-DD). Uses HTTP API instead of MQTT." in
667
+
let doc =
668
+
"Start date for historical query (YYYY-MM-DD). Uses HTTP API instead of \
669
+
MQTT."
670
+
in
555
671
Arg.(value & opt (some string) None & info [ "from" ] ~docv:"DATE" ~doc)
556
672
in
557
673
let to_date =
558
-
let doc = "End date for historical query (YYYY-MM-DD). Defaults to today." in
674
+
let doc =
675
+
"End date for historical query (YYYY-MM-DD). Defaults to today."
676
+
in
559
677
Arg.(value & opt (some string) None & info [ "to" ] ~docv:"DATE" ~doc)
560
678
in
561
679
let user =
···
563
681
Arg.(value & opt (some string) None & info [ "user" ] ~docv:"USER" ~doc)
564
682
in
565
683
let recorder_url =
566
-
let doc = "OwnTracks Recorder URL (e.g., https://recorder.example.com). \
567
-
Can also be set in config as [owntracks.recorder] url." in
568
-
Arg.(value & opt (some string) None & info [ "recorder-url" ] ~docv:"URL" ~doc)
684
+
let doc =
685
+
"OwnTracks Recorder URL (e.g., https://recorder.example.com). Can also \
686
+
be set in config as [owntracks.recorder] url."
687
+
in
688
+
Arg.(
689
+
value & opt (some string) None & info [ "recorder-url" ] ~docv:"URL" ~doc)
569
690
in
570
691
let recorder_user =
571
-
let doc = "User for HTTP Basic Auth to OwnTracks Recorder. \
572
-
Can also be set in config as [owntracks.recorder] user." in
573
-
Arg.(value & opt (some string) None & info [ "recorder-user" ] ~docv:"USER" ~doc)
692
+
let doc =
693
+
"User for HTTP Basic Auth to OwnTracks Recorder. Can also be set in \
694
+
config as [owntracks.recorder] user."
695
+
in
696
+
Arg.(
697
+
value
698
+
& opt (some string) None
699
+
& info [ "recorder-user" ] ~docv:"USER" ~doc)
574
700
in
575
701
let recorder_password =
576
-
let doc = "Password for HTTP Basic Auth to OwnTracks Recorder. \
577
-
Can also be set in config as [owntracks.recorder] password." in
578
-
Arg.(value & opt (some string) None & info [ "recorder-password" ] ~docv:"PASS" ~doc)
702
+
let doc =
703
+
"Password for HTTP Basic Auth to OwnTracks Recorder. Can also be set in \
704
+
config as [owntracks.recorder] password."
705
+
in
706
+
Arg.(
707
+
value
708
+
& opt (some string) None
709
+
& info [ "recorder-password" ] ~docv:"PASS" ~doc)
579
710
in
580
711
let verbose_http =
581
-
let doc = "Enable verbose HTTP-level logging for debugging recorder requests." in
712
+
let doc =
713
+
"Enable verbose HTTP-level logging for debugging recorder requests."
714
+
in
582
715
Arg.(value & flag & info [ "verbose-http" ] ~doc)
583
716
in
584
717
let term =
585
718
Term.(
586
719
const run
587
720
$ Mqtte_cmd.term_with_config ~app_name ~fs ~config:mqtt_config ()
588
-
$ topic $ device $ duration $ track $ from_date $ to_date $ user $ recorder_url
589
-
$ recorder_user $ recorder_password $ verbose_http)
721
+
$ topic $ device $ duration $ track $ from_date $ to_date $ user
722
+
$ recorder_url $ recorder_user $ recorder_password $ verbose_http)
590
723
in
591
724
let doc = "Output device location as GeoJSON" in
592
725
let man =
593
726
[
594
727
`S Manpage.s_description;
595
728
`P "Connects to MQTT and outputs location data as GeoJSON.";
596
-
`P "By default, outputs the first location as a GeoJSON Feature with Point geometry. \
597
-
With $(b,--track), collects locations for the specified duration and outputs a \
598
-
LineString showing the movement path.";
599
-
`P "With $(b,--from), queries the OwnTracks Recorder HTTP API for historical data \
600
-
instead of using MQTT. Requires $(b,--recorder-url) or recorder_url in config.";
729
+
`P
730
+
"By default, outputs the first location as a GeoJSON Feature with \
731
+
Point geometry. With $(b,--track), collects locations for the \
732
+
specified duration and outputs a LineString showing the movement \
733
+
path.";
734
+
`P
735
+
"With $(b,--from), queries the OwnTracks Recorder HTTP API for \
736
+
historical data instead of using MQTT. Requires $(b,--recorder-url) \
737
+
or recorder_url in config.";
601
738
`S Manpage.s_examples;
602
739
`Pre " owntracks geojson";
603
740
`Pre " owntracks geojson -d 'My Phone' --duration 60";
604
741
`Pre " owntracks geojson --track --duration 3600 # 1 hour track";
605
742
`Pre " owntracks geojson --from 2024-01-12 --to 2024-01-13 # historical";
606
-
`Pre " owntracks geojson --from 2024-01-12 --recorder-url https://recorder.example.com";
743
+
`Pre
744
+
" owntracks geojson --from 2024-01-12 --recorder-url \
745
+
https://recorder.example.com";
607
746
]
608
747
in
609
748
Cmd.v (Cmd.info "geojson" ~doc ~man) term
610
749
611
750
let recorder_cmd ~fs =
612
-
let xdg = Xdge.create fs app_name in
751
+
let xdg = Xdge.v fs app_name in
613
752
let config = Config.load xdg |> Option.value ~default:Config.empty in
614
753
615
754
let run recorder_url recorder_user recorder_password user verbose_http =
616
-
let recorder_url = match recorder_url with Some _ -> recorder_url | None -> config.owntracks.recorder.url in
617
-
let recorder_user = match recorder_user with Some _ -> recorder_user | None -> config.owntracks.recorder.user in
618
-
let recorder_password = match recorder_password with Some _ -> recorder_password | None -> config.owntracks.recorder.password in
755
+
let recorder_url =
756
+
match recorder_url with
757
+
| Some _ -> recorder_url
758
+
| None -> config.owntracks.recorder.url
759
+
in
760
+
let recorder_user =
761
+
match recorder_user with
762
+
| Some _ -> recorder_user
763
+
| None -> config.owntracks.recorder.user
764
+
in
765
+
let recorder_password =
766
+
match recorder_password with
767
+
| Some _ -> recorder_password
768
+
| None -> config.owntracks.recorder.password
769
+
in
619
770
620
771
match recorder_url with
621
772
| None ->
622
-
Format.eprintf "Error: --recorder-url or [owntracks.recorder] url config required@.";
773
+
Format.eprintf
774
+
"Error: --recorder-url or [owntracks.recorder] url config required@.";
623
775
1
624
-
| Some recorder_url ->
625
-
let auth = match (recorder_user, recorder_password) with
626
-
| (Some u, Some p) -> Some (u, p)
776
+
| Some recorder_url -> (
777
+
let auth =
778
+
match (recorder_user, recorder_password) with
779
+
| Some u, Some p -> Some (u, p)
627
780
| _ -> None
628
781
in
629
782
Eio_main.run @@ fun env ->
630
783
Mirage_crypto_rng_unix.use_default ();
631
784
Eio.Switch.run @@ fun sw ->
632
785
match user with
633
-
| None ->
786
+
| None -> (
634
787
(* List all users *)
635
-
let users = Recorder.list_users ~sw env ~verbose_http ~recorder_url ?auth () in
636
-
(match users with
637
-
| [] ->
638
-
Format.printf "No users found (or unable to access recorder).@.";
639
-
1
640
-
| users ->
641
-
Format.printf "Users on recorder:@.";
642
-
List.iter (fun u -> Format.printf " %s@." u) users;
643
-
0)
644
-
| Some user ->
788
+
let users =
789
+
Recorder.list_users ~sw env ~verbose_http ~recorder_url ?auth ()
790
+
in
791
+
match users with
792
+
| [] ->
793
+
Format.printf "No users found (or unable to access recorder).@.";
794
+
1
795
+
| users ->
796
+
Format.printf "Users on recorder:@.";
797
+
List.iter (fun u -> Format.printf " %s@." u) users;
798
+
0)
799
+
| Some user -> (
645
800
(* List devices for user *)
646
-
let devices = Recorder.list_devices ~sw env ~verbose_http ~recorder_url ~user ?auth () in
647
-
(match devices with
648
-
| [] ->
649
-
Format.printf "No devices found for user '%s'.@." user;
650
-
1
651
-
| devices ->
652
-
Format.printf "Devices for user '%s':@." user;
653
-
List.iter (fun d -> Format.printf " %s@." d) devices;
654
-
0)
801
+
let devices =
802
+
Recorder.list_devices ~sw env ~verbose_http ~recorder_url ~user
803
+
?auth ()
804
+
in
805
+
match devices with
806
+
| [] ->
807
+
Format.printf "No devices found for user '%s'.@." user;
808
+
1
809
+
| devices ->
810
+
Format.printf "Devices for user '%s':@." user;
811
+
List.iter (fun d -> Format.printf " %s@." d) devices;
812
+
0))
655
813
in
656
814
let recorder_url =
657
815
let doc = "OwnTracks Recorder URL (e.g., https://recorder.example.com)." in
658
-
Arg.(value & opt (some string) None & info [ "recorder-url" ] ~docv:"URL" ~doc)
816
+
Arg.(
817
+
value & opt (some string) None & info [ "recorder-url" ] ~docv:"URL" ~doc)
659
818
in
660
819
let recorder_user =
661
820
let doc = "User for HTTP Basic Auth to OwnTracks Recorder." in
662
-
Arg.(value & opt (some string) None & info [ "recorder-user" ] ~docv:"USER" ~doc)
821
+
Arg.(
822
+
value
823
+
& opt (some string) None
824
+
& info [ "recorder-user" ] ~docv:"USER" ~doc)
663
825
in
664
826
let recorder_password =
665
827
let doc = "Password for HTTP Basic Auth to OwnTracks Recorder." in
666
-
Arg.(value & opt (some string) None & info [ "recorder-password" ] ~docv:"PASS" ~doc)
828
+
Arg.(
829
+
value
830
+
& opt (some string) None
831
+
& info [ "recorder-password" ] ~docv:"PASS" ~doc)
667
832
in
668
833
let user =
669
834
let doc = "List devices for this user. If omitted, lists all users." in
···
674
839
Arg.(value & flag & info [ "verbose-http" ] ~doc)
675
840
in
676
841
let term =
677
-
Term.(const run $ recorder_url $ recorder_user $ recorder_password $ user $ verbose_http)
842
+
Term.(
843
+
const run $ recorder_url $ recorder_user $ recorder_password $ user
844
+
$ verbose_http)
678
845
in
679
846
let doc = "List users and devices from OwnTracks Recorder" in
680
847
let man =
681
848
[
682
849
`S Manpage.s_description;
683
-
`P "Query the OwnTracks Recorder HTTP API to list available users and devices.";
684
-
`P "Without $(b,--user), lists all users. With $(b,--user), lists devices for that user.";
850
+
`P
851
+
"Query the OwnTracks Recorder HTTP API to list available users and \
852
+
devices.";
853
+
`P
854
+
"Without $(b,--user), lists all users. With $(b,--user), lists devices \
855
+
for that user.";
685
856
`S Manpage.s_examples;
686
857
`Pre " owntracks recorder # list all users";
687
-
`Pre " owntracks recorder --user avsm # list devices for user 'avsm'";
858
+
`Pre
859
+
" owntracks recorder --user avsm # list devices for user 'avsm'";
688
860
]
689
861
in
690
862
Cmd.v (Cmd.info "recorder" ~doc ~man) term
···
692
864
let init_cmd ~fs:_ =
693
865
let run force =
694
866
Eio_main.run @@ fun env ->
695
-
let xdg = Xdge.create (Eio.Stdenv.fs env) app_name in
867
+
let xdg = Xdge.v (Eio.Stdenv.fs env) app_name in
696
868
let path = Eio.Path.(Xdge.config_dir xdg / "owntracks.toml") in
697
869
let exists = Eio.Path.is_file path in
698
870
if exists && not force then begin
···
708
880
0
709
881
end
710
882
in
711
-
let force = Arg.(value & flag & info [ "f"; "force" ] ~doc:"Overwrite existing") in
883
+
let force =
884
+
Arg.(value & flag & info [ "f"; "force" ] ~doc:"Overwrite existing")
885
+
in
712
886
let doc = "Create default configuration file" in
713
887
Cmd.v (Cmd.info "init" ~doc) Term.(const run $ force)
714
888
···
722
896
`S Manpage.s_description;
723
897
`P "Subscribe to OwnTracks location updates over MQTT.";
724
898
`S "CONFIGURATION";
725
-
`P (Printf.sprintf "Settings are stored in ~/.config/%s/owntracks.toml:" app_name);
899
+
`P
900
+
(Printf.sprintf "Settings are stored in ~/.config/%s/owntracks.toml:"
901
+
app_name);
726
902
`Pre
727
903
{|[owntracks]
728
904
topic = "owntracks/#"
···
740
916
]
741
917
in
742
918
let default = Term.(ret (const (`Help (`Pager, None)))) in
743
-
Cmd.group (Cmd.info app_name ~version:"0.1.0" ~doc ~man) ~default
744
-
[ listen_cmd ~fs; geojson_cmd ~fs; recorder_cmd ~fs; devices_cmd ~fs; init_cmd ~fs ]
919
+
Cmd.group
920
+
(Cmd.info app_name ~version:"0.1.0" ~doc ~man)
921
+
~default
922
+
[
923
+
listen_cmd ~fs;
924
+
geojson_cmd ~fs;
925
+
recorder_cmd ~fs;
926
+
devices_cmd ~fs;
927
+
init_cmd ~fs;
928
+
]
745
929
in
746
-
Eio_main.run @@ fun env ->
747
-
exit (Cmd.eval' (main_cmd ~fs:(Eio.Stdenv.fs env)))
930
+
Eio_main.run @@ fun env -> exit (Cmd.eval' (main_cmd ~fs:(Eio.Stdenv.fs env)))
+1
-1
dune-project
+1
-1
dune-project
+133
-139
lib/geojson.ml
+133
-139
lib/geojson.ml
···
24
24
let jsont = float_array_jsont ~kind:"Bbox"
25
25
end
26
26
27
-
(** Position coordinates [longitude, latitude] or [longitude, latitude, altitude]. *)
27
+
(** Position coordinates [longitude, latitude] or
28
+
[longitude, latitude, altitude]. *)
28
29
module Position = struct
29
30
type t = float_array
30
31
···
73
74
module Multi_point = struct
74
75
type t = Position.t garray
75
76
76
-
let jsont =
77
-
Geojson_object.geometry ~kind:"MultiPoint" (garray Position.jsont)
77
+
let jsont = Geojson_object.geometry ~kind:"MultiPoint" (garray Position.jsont)
78
78
end
79
79
80
80
(** LineString geometry. *)
81
81
module Line_string = struct
82
82
type t = Position.t garray
83
83
84
-
let jsont =
85
-
Geojson_object.geometry ~kind:"LineString" (garray Position.jsont)
86
-
84
+
let jsont = Geojson_object.geometry ~kind:"LineString" (garray Position.jsont)
87
85
let v positions = Geojson_object.make positions None (Jsont.Json.object' [])
88
86
end
89
87
···
171
169
let feature_id_jsont =
172
170
let number =
173
171
let dec = Jsont.Base.dec (fun n -> `Number n) in
174
-
let enc = Jsont.Base.enc (function `Number n -> n | _ -> assert false) in
172
+
let enc =
173
+
Jsont.Base.enc (function `Number n -> n | _ -> assert false)
174
+
in
175
175
Jsont.Base.number (Jsont.Base.map ~enc ~dec ())
176
176
in
177
177
let string =
178
178
let dec = Jsont.Base.dec (fun n -> `String n) in
179
-
let enc = Jsont.Base.enc (function `String n -> n | _ -> assert false) in
179
+
let enc =
180
+
Jsont.Base.enc (function `String n -> n | _ -> assert false)
181
+
in
180
182
Jsont.Base.string (Jsont.Base.map ~enc ~dec ())
181
183
in
182
184
let enc = function `Number _ -> number | `String _ -> string in
···
185
187
let case_map obj dec = Jsont.Object.Case.map (Jsont.kind obj) obj ~dec
186
188
187
189
let rec geometry_jsont =
188
-
lazy
189
-
begin
190
-
let case_point = case_map Point.jsont point in
191
-
let case_multi_point = case_map Multi_point.jsont multi_point in
192
-
let case_line_string = case_map Line_string.jsont line_string in
193
-
let case_multi_line_string =
194
-
case_map Multi_line_string.jsont multi_line_string
195
-
in
196
-
let case_polygon = case_map Polygon.jsont polygon in
197
-
let case_multi_polygon = case_map Multi_polygon.jsont multi_polygon in
198
-
let case_geometry_collection =
199
-
case_map (Lazy.force geometry_collection_jsont) geometry_collection
200
-
in
201
-
let enc_case = function
202
-
| `Point v -> Jsont.Object.Case.value case_point v
203
-
| `Multi_point v -> Jsont.Object.Case.value case_multi_point v
204
-
| `Line_string v -> Jsont.Object.Case.value case_line_string v
205
-
| `Multi_line_string v ->
206
-
Jsont.Object.Case.value case_multi_line_string v
207
-
| `Polygon v -> Jsont.Object.Case.value case_polygon v
208
-
| `Multi_polygon v -> Jsont.Object.Case.value case_multi_polygon v
209
-
| `Geometry_collection v ->
210
-
Jsont.Object.Case.value case_geometry_collection v
211
-
in
212
-
let cases =
213
-
Jsont.Object.Case.
214
-
[
215
-
make case_point;
216
-
make case_multi_point;
217
-
make case_line_string;
218
-
make case_multi_line_string;
219
-
make case_polygon;
220
-
make case_multi_polygon;
221
-
make case_geometry_collection;
222
-
]
223
-
in
224
-
Jsont.Object.map ~kind:"Geometry object" Fun.id
225
-
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
226
-
~tag_to_string:Fun.id ~tag_compare:String.compare
227
-
|> Jsont.Object.finish
228
-
end
190
+
lazy begin
191
+
let case_point = case_map Point.jsont point in
192
+
let case_multi_point = case_map Multi_point.jsont multi_point in
193
+
let case_line_string = case_map Line_string.jsont line_string in
194
+
let case_multi_line_string =
195
+
case_map Multi_line_string.jsont multi_line_string
196
+
in
197
+
let case_polygon = case_map Polygon.jsont polygon in
198
+
let case_multi_polygon = case_map Multi_polygon.jsont multi_polygon in
199
+
let case_geometry_collection =
200
+
case_map (Lazy.force geometry_collection_jsont) geometry_collection
201
+
in
202
+
let enc_case = function
203
+
| `Point v -> Jsont.Object.Case.value case_point v
204
+
| `Multi_point v -> Jsont.Object.Case.value case_multi_point v
205
+
| `Line_string v -> Jsont.Object.Case.value case_line_string v
206
+
| `Multi_line_string v ->
207
+
Jsont.Object.Case.value case_multi_line_string v
208
+
| `Polygon v -> Jsont.Object.Case.value case_polygon v
209
+
| `Multi_polygon v -> Jsont.Object.Case.value case_multi_polygon v
210
+
| `Geometry_collection v ->
211
+
Jsont.Object.Case.value case_geometry_collection v
212
+
in
213
+
let cases =
214
+
Jsont.Object.Case.
215
+
[
216
+
make case_point;
217
+
make case_multi_point;
218
+
make case_line_string;
219
+
make case_multi_line_string;
220
+
make case_polygon;
221
+
make case_multi_polygon;
222
+
make case_geometry_collection;
223
+
]
224
+
in
225
+
Jsont.Object.map ~kind:"Geometry object" Fun.id
226
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
227
+
~tag_to_string:Fun.id ~tag_compare:String.compare
228
+
|> Jsont.Object.finish
229
+
end
229
230
230
231
and feature_jsont : Feature.t object' Jsont.t Lazy.t =
231
-
lazy
232
-
begin
233
-
let case_feature = case_map (Lazy.force case_feature_jsont) Fun.id in
234
-
let enc_case v = Jsont.Object.Case.value case_feature v in
235
-
let cases = Jsont.Object.Case.[ make case_feature ] in
236
-
Jsont.Object.map ~kind:"Feature" Fun.id
237
-
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
238
-
~tag_to_string:Fun.id ~tag_compare:String.compare
239
-
|> Jsont.Object.finish
240
-
end
232
+
lazy begin
233
+
let case_feature = case_map (Lazy.force case_feature_jsont) Fun.id in
234
+
let enc_case v = Jsont.Object.Case.value case_feature v in
235
+
let cases = Jsont.Object.Case.[ make case_feature ] in
236
+
Jsont.Object.map ~kind:"Feature" Fun.id
237
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
238
+
~tag_to_string:Fun.id ~tag_compare:String.compare
239
+
|> Jsont.Object.finish
240
+
end
241
241
242
242
and case_feature_jsont : Feature.t object' Jsont.t Lazy.t =
243
-
lazy
244
-
begin
245
-
Jsont.Object.map ~kind:"Feature" Feature.make_geojson_object
246
-
|> Jsont.Object.opt_mem "id" feature_id_jsont ~enc:(fun o ->
247
-
Feature.id (Geojson_object.type' o))
248
-
|> Jsont.Object.mem "geometry"
249
-
(Jsont.option (Jsont.rec' geometry_jsont))
250
-
~enc:(fun o -> Feature.geometry (Geojson_object.type' o))
251
-
|> Jsont.Object.mem "properties" (Jsont.option Jsont.json_object)
252
-
~enc:(fun o -> Feature.properties (Geojson_object.type' o))
253
-
|> Geojson_object.finish_jsont
254
-
end
243
+
lazy begin
244
+
Jsont.Object.map ~kind:"Feature" Feature.make_geojson_object
245
+
|> Jsont.Object.opt_mem "id" feature_id_jsont ~enc:(fun o ->
246
+
Feature.id (Geojson_object.type' o))
247
+
|> Jsont.Object.mem "geometry"
248
+
(Jsont.option (Jsont.rec' geometry_jsont))
249
+
~enc:(fun o -> Feature.geometry (Geojson_object.type' o))
250
+
|> Jsont.Object.mem "properties" (Jsont.option Jsont.json_object)
251
+
~enc:(fun o -> Feature.properties (Geojson_object.type' o))
252
+
|> Geojson_object.finish_jsont
253
+
end
255
254
256
255
and geometry_collection_jsont =
257
-
lazy
258
-
begin
259
-
Jsont.Object.map ~kind:"GeometryCollection" Geojson_object.make
260
-
|> Jsont.Object.mem "geometries"
261
-
(Jsont.list (Jsont.rec' geometry_jsont))
262
-
~enc:Geojson_object.type'
263
-
|> Geojson_object.finish_jsont
264
-
end
256
+
lazy begin
257
+
Jsont.Object.map ~kind:"GeometryCollection" Geojson_object.make
258
+
|> Jsont.Object.mem "geometries"
259
+
(Jsont.list (Jsont.rec' geometry_jsont))
260
+
~enc:Geojson_object.type'
261
+
|> Geojson_object.finish_jsont
262
+
end
265
263
266
264
and feature_collection_json =
267
-
lazy
268
-
begin
269
-
Jsont.Object.map ~kind:"FeatureCollection" Geojson_object.make
270
-
|> Jsont.Object.mem "features"
271
-
Jsont.(list (Jsont.rec' feature_jsont))
272
-
~enc:Geojson_object.type'
273
-
|> Geojson_object.finish_jsont
274
-
end
265
+
lazy begin
266
+
Jsont.Object.map ~kind:"FeatureCollection" Geojson_object.make
267
+
|> Jsont.Object.mem "features"
268
+
Jsont.(list (Jsont.rec' feature_jsont))
269
+
~enc:Geojson_object.type'
270
+
|> Geojson_object.finish_jsont
271
+
end
275
272
276
273
and jsont : t Jsont.t Lazy.t =
277
-
lazy
278
-
begin
279
-
let case_point = case_map Point.jsont point in
280
-
let case_multi_point = case_map Multi_point.jsont multi_point in
281
-
let case_line_string = case_map Line_string.jsont line_string in
282
-
let case_multi_line_string =
283
-
case_map Multi_line_string.jsont multi_line_string
284
-
in
285
-
let case_polygon = case_map Polygon.jsont polygon in
286
-
let case_multi_polygon = case_map Multi_polygon.jsont multi_polygon in
287
-
let case_geometry_collection =
288
-
case_map (Lazy.force geometry_collection_jsont) geometry_collection
289
-
in
290
-
let case_feature =
291
-
case_map (Lazy.force case_feature_jsont) feature
292
-
in
293
-
let case_feature_collection =
294
-
case_map (Lazy.force feature_collection_json) feature_collection
295
-
in
296
-
let enc_case = function
297
-
| `Point v -> Jsont.Object.Case.value case_point v
298
-
| `Multi_point v -> Jsont.Object.Case.value case_multi_point v
299
-
| `Line_string v -> Jsont.Object.Case.value case_line_string v
300
-
| `Multi_line_string v ->
301
-
Jsont.Object.Case.value case_multi_line_string v
302
-
| `Polygon v -> Jsont.Object.Case.value case_polygon v
303
-
| `Multi_polygon v -> Jsont.Object.Case.value case_multi_polygon v
304
-
| `Geometry_collection v ->
305
-
Jsont.Object.Case.value case_geometry_collection v
306
-
| `Feature v -> Jsont.Object.Case.value case_feature v
307
-
| `Feature_collection v ->
308
-
Jsont.Object.Case.value case_feature_collection v
309
-
in
310
-
let cases =
311
-
Jsont.Object.Case.
312
-
[
313
-
make case_point;
314
-
make case_multi_point;
315
-
make case_line_string;
316
-
make case_multi_line_string;
317
-
make case_polygon;
318
-
make case_multi_polygon;
319
-
make case_geometry_collection;
320
-
make case_feature;
321
-
make case_feature_collection;
322
-
]
323
-
in
324
-
Jsont.Object.map ~kind:"GeoJSON" Fun.id
325
-
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
326
-
~tag_to_string:Fun.id ~tag_compare:String.compare
327
-
|> Jsont.Object.finish
328
-
end
274
+
lazy begin
275
+
let case_point = case_map Point.jsont point in
276
+
let case_multi_point = case_map Multi_point.jsont multi_point in
277
+
let case_line_string = case_map Line_string.jsont line_string in
278
+
let case_multi_line_string =
279
+
case_map Multi_line_string.jsont multi_line_string
280
+
in
281
+
let case_polygon = case_map Polygon.jsont polygon in
282
+
let case_multi_polygon = case_map Multi_polygon.jsont multi_polygon in
283
+
let case_geometry_collection =
284
+
case_map (Lazy.force geometry_collection_jsont) geometry_collection
285
+
in
286
+
let case_feature = case_map (Lazy.force case_feature_jsont) feature in
287
+
let case_feature_collection =
288
+
case_map (Lazy.force feature_collection_json) feature_collection
289
+
in
290
+
let enc_case = function
291
+
| `Point v -> Jsont.Object.Case.value case_point v
292
+
| `Multi_point v -> Jsont.Object.Case.value case_multi_point v
293
+
| `Line_string v -> Jsont.Object.Case.value case_line_string v
294
+
| `Multi_line_string v ->
295
+
Jsont.Object.Case.value case_multi_line_string v
296
+
| `Polygon v -> Jsont.Object.Case.value case_polygon v
297
+
| `Multi_polygon v -> Jsont.Object.Case.value case_multi_polygon v
298
+
| `Geometry_collection v ->
299
+
Jsont.Object.Case.value case_geometry_collection v
300
+
| `Feature v -> Jsont.Object.Case.value case_feature v
301
+
| `Feature_collection v ->
302
+
Jsont.Object.Case.value case_feature_collection v
303
+
in
304
+
let cases =
305
+
Jsont.Object.Case.
306
+
[
307
+
make case_point;
308
+
make case_multi_point;
309
+
make case_line_string;
310
+
make case_multi_line_string;
311
+
make case_polygon;
312
+
make case_multi_polygon;
313
+
make case_geometry_collection;
314
+
make case_feature;
315
+
make case_feature_collection;
316
+
]
317
+
in
318
+
Jsont.Object.map ~kind:"GeoJSON" Fun.id
319
+
|> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases
320
+
~tag_to_string:Fun.id ~tag_compare:String.compare
321
+
|> Jsont.Object.finish
322
+
end
329
323
330
324
let jsont = Lazy.force jsont
331
325
+58
-44
lib/geojson.mli
+58
-44
lib/geojson.mli
···
11
11
12
12
{1:overview Overview}
13
13
14
-
GeoJSON is a format for encoding geographic data structures. It supports
15
-
the following geometry types:
14
+
GeoJSON is a format for encoding geographic data structures. It supports the
15
+
following geometry types:
16
16
- {!Point} - a single position
17
17
- {!Line_string} - an array of positions forming a line
18
18
- {!Polygon} - an array of linear rings (closed line strings)
···
26
26
27
27
Creating a simple point feature:
28
28
{[
29
-
let pos = Position.v ~lng:(-122.4194) ~lat:37.7749 () in
30
-
let point = Point.v pos in
31
-
let feature = Geojson.Feature.v (`Point point) in
32
-
let geojson = `Feature feature in
33
-
Geojson.to_string geojson
29
+
let pos = Position.v ~lng:(-122.4194) ~lat:37.7749 () in
30
+
let point = Point.v pos in
31
+
let feature = Geojson.Feature.v (`Point point) in
32
+
let geojson = `Feature feature in
33
+
Geojson.to_string geojson
34
34
]} *)
35
35
36
36
(** {1:primitives Primitive Types} *)
···
38
38
(** Bounding box as an array of coordinates.
39
39
40
40
A bounding box is represented as an array of 4 or 6 numbers:
41
-
- 2D: [\[west, south, east, north\]]
42
-
- 3D: [\[west, south, min-altitude, east, north, max-altitude\]] *)
41
+
- 2D: [[west, south, east, north]]
42
+
- 3D: [[west, south, min-altitude, east, north, max-altitude]] *)
43
43
module Bbox : sig
44
44
type t = float array
45
45
(** The type for bounding boxes. *)
···
51
51
(** Geographic position coordinates.
52
52
53
53
Positions are represented as arrays of 2 or 3 numbers:
54
-
- 2D: [\[longitude, latitude\]]
55
-
- 3D: [\[longitude, latitude, altitude\]]
54
+
- 2D: [[longitude, latitude]]
55
+
- 3D: [[longitude, latitude, altitude]]
56
56
57
-
Note that the order is longitude first, then latitude, following the
58
-
GeoJSON specification (which differs from the common lat/lon convention). *)
57
+
Note that the order is longitude first, then latitude, following the GeoJSON
58
+
specification (which differs from the common lat/lon convention). *)
59
59
module Position : sig
60
60
type t = float array
61
61
(** The type for positions. *)
···
64
64
(** [jsont] is a JSON codec for positions. *)
65
65
66
66
val v : ?altitude:float -> lng:float -> lat:float -> unit -> t
67
-
(** [v ~lng ~lat ()] creates a 2D position.
68
-
[v ~altitude ~lng ~lat ()] creates a 3D position with altitude. *)
67
+
(** [v ~lng ~lat ()] creates a 2D position. [v ~altitude ~lng ~lat ()] creates
68
+
a 3D position with altitude. *)
69
69
70
70
val lng : t -> float
71
71
(** [lng t] returns the longitude (first element). *)
···
88
88
(** The type for GeoJSON objects wrapping a value of type ['a]. *)
89
89
90
90
val type' : 'a t -> 'a
91
-
(** [type' o] returns the wrapped value (the geometry coordinates or
92
-
feature data). *)
91
+
(** [type' o] returns the wrapped value (the geometry coordinates or feature
92
+
data). *)
93
93
94
94
val bbox : 'a t -> Bbox.t option
95
95
(** [bbox o] returns the optional bounding box. *)
···
124
124
125
125
(** LineString geometry - an ordered sequence of positions forming a line.
126
126
127
-
A LineString must have at least two positions. It represents a path
128
-
through coordinate space. *)
127
+
A LineString must have at least two positions. It represents a path through
128
+
coordinate space. *)
129
129
module Line_string : sig
130
130
type t = Position.t array
131
131
(** The type for linestring coordinates. *)
···
150
150
151
151
(** Polygon geometry - an area bounded by linear rings.
152
152
153
-
A polygon is represented as an array of linear rings. The first ring
154
-
is the exterior boundary; subsequent rings are holes. Each ring must
155
-
have at least four positions, with the first and last being identical
156
-
(a closed ring). *)
153
+
A polygon is represented as an array of linear rings. The first ring is the
154
+
exterior boundary; subsequent rings are holes. Each ring must have at least
155
+
four positions, with the first and last being identical (a closed ring). *)
157
156
module Polygon : sig
158
157
type t = Line_string.t array
159
158
(** The type for polygon coordinates (array of linear rings). *)
···
177
176
178
177
(** Main GeoJSON types including features and geometry collections.
179
178
180
-
This module provides the complete GeoJSON type hierarchy as defined
181
-
in {{:https://datatracker.ietf.org/doc/html/rfc7946}RFC 7946}. *)
179
+
This module provides the complete GeoJSON type hierarchy as defined in
180
+
{{:https://datatracker.ietf.org/doc/html/rfc7946}RFC 7946}. *)
182
181
module Geojson : sig
183
-
184
182
(** {1:types Type Definitions} *)
185
183
186
184
type 'a object' = 'a Geojson_object.t
187
185
(** Alias for GeoJSON object wrapper. *)
188
186
189
-
(** All geometry types as a polymorphic variant. *)
190
187
type geometry =
191
188
[ `Point of Point.t object'
192
189
| `Multi_point of Multi_point.t object'
···
195
192
| `Polygon of Polygon.t object'
196
193
| `Multi_polygon of Multi_polygon.t object'
197
194
| `Geometry_collection of geometry_collection object' ]
195
+
(** All geometry types as a polymorphic variant. *)
198
196
199
197
and geometry_collection = geometry list
200
198
(** A collection of geometry objects. *)
201
199
202
200
(** {1:features Features}
203
201
204
-
A Feature object represents a spatially bounded entity with
205
-
associated properties. *)
202
+
A Feature object represents a spatially bounded entity with associated
203
+
properties. *)
206
204
module Feature : sig
207
-
208
205
type id = [ `Number of float | `String of string ]
209
206
(** Feature identifiers can be either numbers or strings. *)
210
207
···
215
212
(** [id f] returns the optional feature identifier. *)
216
213
217
214
val geometry : t -> geometry option
218
-
(** [geometry f] returns the optional geometry. A feature may have
219
-
null geometry. *)
215
+
(** [geometry f] returns the optional geometry. A feature may have null
216
+
geometry. *)
220
217
221
218
val properties : t -> Jsont.json option
222
-
(** [properties f] returns the optional properties JSON object.
223
-
Properties can be any JSON object. *)
219
+
(** [properties f] returns the optional properties JSON object. Properties
220
+
can be any JSON object. *)
224
221
225
222
type collection = t object' list
226
223
(** A FeatureCollection is a list of features. *)
227
224
228
225
val v : ?properties:Jsont.json -> geometry -> t object'
229
-
(** [v ?properties geometry] creates a Feature with the given geometry
230
-
and optional properties JSON object. *)
226
+
(** [v ?properties geometry] creates a Feature with the given geometry and
227
+
optional properties JSON object. *)
231
228
end
232
229
233
230
(** {1:toplevel Top-level GeoJSON Type} *)
···
246
243
These constructors wrap geometry objects in the appropriate variant. *)
247
244
248
245
val point : Point.t object' -> [> `Point of Point.t object' ]
249
-
val multi_point : Multi_point.t object' -> [> `Multi_point of Multi_point.t object' ]
250
-
val line_string : Line_string.t object' -> [> `Line_string of Line_string.t object' ]
251
-
val multi_line_string : Multi_line_string.t object' -> [> `Multi_line_string of Multi_line_string.t object' ]
246
+
247
+
val multi_point :
248
+
Multi_point.t object' -> [> `Multi_point of Multi_point.t object' ]
249
+
250
+
val line_string :
251
+
Line_string.t object' -> [> `Line_string of Line_string.t object' ]
252
+
253
+
val multi_line_string :
254
+
Multi_line_string.t object' ->
255
+
[> `Multi_line_string of Multi_line_string.t object' ]
256
+
252
257
val polygon : Polygon.t object' -> [> `Polygon of Polygon.t object' ]
253
-
val multi_polygon : Multi_polygon.t object' -> [> `Multi_polygon of Multi_polygon.t object' ]
254
-
val geometry_collection : geometry_collection object' -> [> `Geometry_collection of geometry_collection object' ]
258
+
259
+
val multi_polygon :
260
+
Multi_polygon.t object' -> [> `Multi_polygon of Multi_polygon.t object' ]
261
+
262
+
val geometry_collection :
263
+
geometry_collection object' ->
264
+
[> `Geometry_collection of geometry_collection object' ]
265
+
255
266
val feature : Feature.t object' -> [> `Feature of Feature.t object' ]
256
-
val feature_collection : Feature.collection object' -> [> `Feature_collection of Feature.collection object' ]
267
+
268
+
val feature_collection :
269
+
Feature.collection object' ->
270
+
[> `Feature_collection of Feature.collection object' ]
257
271
258
272
(** {1:codec Encoding and Decoding} *)
259
273
260
274
val jsont : t Jsont.t
261
-
(** [jsont] is a JSON codec for GeoJSON objects. Handles all GeoJSON
262
-
types including features, feature collections, and all geometry types. *)
275
+
(** [jsont] is a JSON codec for GeoJSON objects. Handles all GeoJSON types
276
+
including features, feature collections, and all geometry types. *)
263
277
264
278
val to_string : t -> string
265
279
(** [to_string t] encodes [t] as a minified JSON string.
+21
-19
lib/owntracks.mli
+21
-19
lib/owntracks.mli
···
25
25
26
26
Decoding a location message using jsont_bytesrw:
27
27
{[
28
-
let json = {|{"_type":"location","lat":51.5,"lon":-0.1,"tst":1234567890}|} in
29
-
match Jsont_bytesrw.decode_string Owntracks.Message.jsont json with
30
-
| Ok (Location loc) ->
31
-
Printf.printf "Location: %.4f, %.4f\n"
32
-
(Owntracks.Location.lat loc) (Owntracks.Location.lon loc)
33
-
| Ok _ -> print_endline "Other message type"
34
-
| Error e -> Printf.printf "Error: %s\n" e
28
+
let json =
29
+
{|{"_type":"location","lat":51.5,"lon":-0.1,"tst":1234567890}|}
30
+
in
31
+
match Jsont_bytesrw.decode_string Owntracks.Message.jsont json with
32
+
| Ok (Location loc) ->
33
+
Printf.printf "Location: %.4f, %.4f\n"
34
+
(Owntracks.Location.lat loc)
35
+
(Owntracks.Location.lon loc)
36
+
| Ok _ -> print_endline "Other message type"
37
+
| Error e -> Printf.printf "Error: %s\n" e
35
38
]}
36
39
37
-
See {{:https://owntracks.org/booklet/tech/json/}OwnTracks JSON format}
38
-
for the complete specification.
40
+
See {{:https://owntracks.org/booklet/tech/json/}OwnTracks JSON format} for
41
+
the complete specification.
39
42
40
43
{1:modules Module Structure}
41
44
···
56
59
57
60
(** {1:types Message Types} *)
58
61
59
-
(** Location message - the primary OwnTracks message type. *)
60
62
module Location = Owntracks_location
63
+
(** Location message - the primary OwnTracks message type. *)
61
64
65
+
module Transition = Owntracks_transition
62
66
(** Transition event - region entry/exit. *)
63
-
module Transition = Owntracks_transition
64
67
68
+
module Waypoint = Owntracks_waypoint
65
69
(** Waypoint definition - monitored circular region. *)
66
-
module Waypoint = Owntracks_waypoint
67
70
68
-
(** Card message - user information for display. *)
69
71
module Card = Owntracks_card
72
+
(** Card message - user information for display. *)
70
73
71
-
(** LWT (Last Will and Testament) message. *)
72
74
module Lwt = Owntracks_lwt
75
+
(** LWT (Last Will and Testament) message. *)
73
76
77
+
module Message = Owntracks_message
74
78
(** All OwnTracks message types as a variant. *)
75
-
module Message = Owntracks_message
76
79
77
80
(** {1:integration Integration Modules} *)
78
81
79
-
(** MQTT integration for OwnTracks messages. *)
80
82
module Mqtt = Owntracks_mqtt
83
+
(** MQTT integration for OwnTracks messages. *)
81
84
82
-
(** OwnTracks Recorder HTTP API codecs. *)
83
85
module Recorder = Owntracks_recorder
86
+
(** OwnTracks Recorder HTTP API codecs. *)
84
87
88
+
module Geojson = Owntracks_geojson_output
85
89
(** Convert OwnTracks locations to GeoJSON format. *)
86
-
module Geojson = Owntracks_geojson_output
87
-
+4
-12
lib/owntracks_card.ml
+4
-12
lib/owntracks_card.ml
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
type t = {
7
-
name : string option;
8
-
face : string option;
9
-
tid : string option;
10
-
}
6
+
type t = { name : string option; face : string option; tid : string option }
11
7
12
8
let v ?name ?face ?tid () = { name; face; tid }
13
-
14
9
let name t = t.name
15
10
let face t = t.face
16
11
let tid t = t.tid
···
21
16
|> Jsont.Object.opt_mem "name" Jsont.string ~enc:(fun c -> c.name)
22
17
|> Jsont.Object.opt_mem "face" Jsont.string ~enc:(fun c -> c.face)
23
18
|> Jsont.Object.opt_mem "tid" Jsont.string ~enc:(fun c -> c.tid)
24
-
|> Jsont.Object.skip_unknown
25
-
|> Jsont.Object.finish
19
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
26
20
27
21
let jsont : t Jsont.t =
28
22
let make _type name face tid =
···
34
28
|> Jsont.Object.opt_mem "name" Jsont.string ~enc:(fun c -> c.name)
35
29
|> Jsont.Object.opt_mem "face" Jsont.string ~enc:(fun c -> c.face)
36
30
|> Jsont.Object.opt_mem "tid" Jsont.string ~enc:(fun c -> c.tid)
37
-
|> Jsont.Object.skip_unknown
38
-
|> Jsont.Object.finish
31
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
39
32
40
33
let pp ppf card =
41
-
Format.fprintf ppf "Card: %s"
42
-
(Option.value ~default:"(no name)" card.name)
34
+
Format.fprintf ppf "Card: %s" (Option.value ~default:"(no name)" card.name)
+10
-16
lib/owntracks_card.mli
+10
-16
lib/owntracks_card.mli
···
7
7
8
8
@canonical Owntracks.Card
9
9
10
-
Provides user information for display. Cards allow users to share
11
-
their name and photo with others tracking their location. The
12
-
tracker ID must match the location message's tid to associate the
13
-
card with the correct user. *)
10
+
Provides user information for display. Cards allow users to share their name
11
+
and photo with others tracking their location. The tracker ID must match the
12
+
location message's tid to associate the card with the correct user. *)
14
13
15
14
type t
16
15
(** The type for card messages. *)
17
16
18
17
(** {1 Constructors} *)
19
18
20
-
val v :
21
-
?name:string ->
22
-
?face:string ->
23
-
?tid:string ->
24
-
unit ->
25
-
t
19
+
val v : ?name:string -> ?face:string -> ?tid:string -> unit -> t
26
20
(** [v ()] creates a card message with optional fields. *)
27
21
28
22
(** {1 Accessors} *)
···
31
25
(** [name card] returns the full name of the user, if present. *)
32
26
33
27
val face : t -> string option
34
-
(** [face card] returns the Base64-encoded image (typically JPEG or PNG),
35
-
if present. *)
28
+
(** [face card] returns the Base64-encoded image (typically JPEG or PNG), if
29
+
present. *)
36
30
37
31
val tid : t -> string option
38
-
(** [tid card] returns the tracker ID that this card belongs to. Must
39
-
match the tid in location messages to be associated correctly. *)
32
+
(** [tid card] returns the tracker ID that this card belongs to. Must match the
33
+
tid in location messages to be associated correctly. *)
40
34
41
35
(** {1 JSON Codec} *)
42
36
43
37
val jsont : t Jsont.t
44
-
(** [jsont] is a JSON codec for card messages.
45
-
Expects the ["_type"] field to be ["card"]. *)
38
+
(** [jsont] is a JSON codec for card messages. Expects the ["_type"] field to be
39
+
["card"]. *)
46
40
47
41
val jsont_bare : t Jsont.t
48
42
(** [jsont_bare] is a JSON codec that doesn't require the ["_type"] field. *)
+49
-22
lib/owntracks_geojson_output.ml
+49
-22
lib/owntracks_geojson_output.ml
···
12
12
~lat:(Owntracks_location.lat loc)
13
13
()
14
14
15
-
let props ~device_name ~timestamp ~time ?accuracy ?speed ?battery ?tracker_id () =
15
+
let props ~device_name ~timestamp ~time ?accuracy ?speed ?battery ?tracker_id ()
16
+
=
16
17
let open Jsont.Json in
17
-
let add n f opt acc = match opt with Some v -> (n, f v) :: acc | None -> acc in
18
+
let add n f opt acc =
19
+
match opt with Some v -> (n, f v) :: acc | None -> acc
20
+
in
18
21
[
19
22
("name", string device_name);
20
23
("timestamp", int timestamp);
21
-
("time", string time)
24
+
("time", string time);
22
25
]
23
26
|> add "accuracy" number accuracy
24
-
|> add "speed" number speed
25
-
|> add "battery" int battery
27
+
|> add "speed" number speed |> add "battery" int battery
26
28
|> add "tracker_id" string tracker_id
27
-
|> fun mems -> Jsont.Json.object' (List.map (fun (n, v) -> Jsont.Json.mem (Jsont.Json.name n) v) mems)
29
+
|> fun mems ->
30
+
Jsont.Json.object'
31
+
(List.map (fun (n, v) -> Jsont.Json.mem (Jsont.Json.name n) v) mems)
28
32
29
33
let point_feature ~device_name loc : Geojson.t =
30
34
let point = Geometry.Point.v (pos_of_loc loc) in
31
35
let geom : Geojson.geometry = `Point point in
32
36
let tst = Owntracks_location.tst loc in
33
-
let properties = Some (props ~device_name ~timestamp:tst
34
-
~time:(Owntracks_location.format_timestamp tst)
35
-
?accuracy:(Owntracks_location.acc loc)
36
-
?speed:(Owntracks_location.vel loc)
37
-
?battery:(Owntracks_location.batt loc)
38
-
?tracker_id:(Owntracks_location.tid loc) ()) in
37
+
let properties =
38
+
Some
39
+
(props ~device_name ~timestamp:tst
40
+
~time:(Owntracks_location.format_timestamp tst)
41
+
?accuracy:(Owntracks_location.acc loc)
42
+
?speed:(Owntracks_location.vel loc)
43
+
?battery:(Owntracks_location.batt loc)
44
+
?tracker_id:(Owntracks_location.tid loc)
45
+
())
46
+
in
39
47
let feature = Geojson.Feature.v ?properties geom in
40
48
`Feature feature
41
49
42
50
let linestring_feature ~device_name locs : Geojson.t =
43
-
let sorted = List.sort (fun a b ->
44
-
Int.compare (Owntracks_location.tst a) (Owntracks_location.tst b)) locs in
51
+
let sorted =
52
+
List.sort
53
+
(fun a b ->
54
+
Int.compare (Owntracks_location.tst a) (Owntracks_location.tst b))
55
+
locs
56
+
in
45
57
let positions = Array.of_list (List.map pos_of_loc sorted) in
46
58
let line = Geometry.LineString.v positions in
47
59
let geom : Geojson.geometry = `Line_string line in
48
-
let start_time = match sorted with [] -> 0 | h :: _ -> Owntracks_location.tst h in
49
-
let end_time = match List.rev sorted with [] -> 0 | h :: _ -> Owntracks_location.tst h in
50
-
let properties = Some (Jsont.Json.object' [
51
-
Jsont.Json.mem (Jsont.Json.name "name") (Jsont.Json.string device_name);
52
-
Jsont.Json.mem (Jsont.Json.name "points") (Jsont.Json.int (List.length sorted));
53
-
Jsont.Json.mem (Jsont.Json.name "start_time") (Jsont.Json.string (Owntracks_location.format_timestamp start_time));
54
-
Jsont.Json.mem (Jsont.Json.name "end_time") (Jsont.Json.string (Owntracks_location.format_timestamp end_time));
55
-
]) in
60
+
let start_time =
61
+
match sorted with [] -> 0 | h :: _ -> Owntracks_location.tst h
62
+
in
63
+
let end_time =
64
+
match List.rev sorted with [] -> 0 | h :: _ -> Owntracks_location.tst h
65
+
in
66
+
let properties =
67
+
Some
68
+
(Jsont.Json.object'
69
+
[
70
+
Jsont.Json.mem (Jsont.Json.name "name")
71
+
(Jsont.Json.string device_name);
72
+
Jsont.Json.mem (Jsont.Json.name "points")
73
+
(Jsont.Json.int (List.length sorted));
74
+
Jsont.Json.mem
75
+
(Jsont.Json.name "start_time")
76
+
(Jsont.Json.string
77
+
(Owntracks_location.format_timestamp start_time));
78
+
Jsont.Json.mem
79
+
(Jsont.Json.name "end_time")
80
+
(Jsont.Json.string (Owntracks_location.format_timestamp end_time));
81
+
])
82
+
in
56
83
let feature = Geojson.Feature.v ?properties geom in
57
84
`Feature feature
58
85
+14
-12
lib/owntracks_geojson_output.mli
+14
-12
lib/owntracks_geojson_output.mli
···
8
8
@canonical Owntracks.Geojson
9
9
10
10
This module provides functions to convert location data into
11
-
{{:https://geojson.org/}GeoJSON} Point and LineString features
12
-
for use in mapping applications.
11
+
{{:https://geojson.org/}GeoJSON} Point and LineString features for use in
12
+
mapping applications.
13
13
14
-
The output is compatible with tools like Leaflet, MapLibre, QGIS,
15
-
and geojson.io. *)
14
+
The output is compatible with tools like Leaflet, MapLibre, QGIS, and
15
+
geojson.io. *)
16
16
17
-
val point_feature : device_name:string -> Owntracks_location.t -> Geojson.Geojson.t
18
-
(** [point_feature ~device_name loc] creates a GeoJSON Feature with
19
-
Point geometry from a single location.
17
+
val point_feature :
18
+
device_name:string -> Owntracks_location.t -> Geojson.Geojson.t
19
+
(** [point_feature ~device_name loc] creates a GeoJSON Feature with Point
20
+
geometry from a single location.
20
21
21
22
The feature properties include:
22
23
- [name]: the device name
···
27
28
- [battery]: battery percentage (if available)
28
29
- [tracker_id]: tracker ID (if available) *)
29
30
30
-
val linestring_feature : device_name:string -> Owntracks_location.t list -> Geojson.Geojson.t
31
-
(** [linestring_feature ~device_name locs] creates a GeoJSON Feature
32
-
with LineString geometry from a list of locations.
31
+
val linestring_feature :
32
+
device_name:string -> Owntracks_location.t list -> Geojson.Geojson.t
33
+
(** [linestring_feature ~device_name locs] creates a GeoJSON Feature with
34
+
LineString geometry from a list of locations.
33
35
34
-
Locations are sorted by timestamp before creating the line. The
35
-
feature properties include:
36
+
Locations are sorted by timestamp before creating the line. The feature
37
+
properties include:
36
38
- [name]: the device name
37
39
- [points]: number of positions in the line
38
40
- [start_time]: formatted timestamp of first point
+112
-62
lib/owntracks_location.ml
+112
-62
lib/owntracks_location.ml
···
25
25
26
26
let v ?tid ~tst ~lat ~lon ?alt ?acc ?vel ?cog ?batt ?bs ?conn ?t ?m ?poi
27
27
?(inregions = []) ?addr ?topic () =
28
-
{ tid; tst; lat; lon; alt; acc; vel; cog; batt; bs; conn; t; m; poi;
29
-
inregions; addr; topic }
28
+
{
29
+
tid;
30
+
tst;
31
+
lat;
32
+
lon;
33
+
alt;
34
+
acc;
35
+
vel;
36
+
cog;
37
+
batt;
38
+
bs;
39
+
conn;
40
+
t;
41
+
m;
42
+
poi;
43
+
inregions;
44
+
addr;
45
+
topic;
46
+
}
30
47
31
48
let tid t = t.tid
32
49
let tst t = t.tst
···
45
62
let inregions t = t.inregions
46
63
let addr t = t.addr
47
64
let topic t = t.topic
48
-
49
65
let with_topic topic t = { t with topic = Some topic }
50
66
51
67
let jsont : t Jsont.t =
52
-
let make _type tid tst lat lon alt acc vel cog batt bs conn t m poi
53
-
inregions addr topic =
68
+
let make _type tid tst lat lon alt acc vel cog batt bs conn t m poi inregions
69
+
addr topic =
54
70
ignore _type;
55
-
{ tid; tst; lat; lon; alt; acc; vel; cog; batt; bs; conn; t; m; poi;
56
-
inregions = Option.value ~default:[] inregions; addr; topic }
71
+
{
72
+
tid;
73
+
tst;
74
+
lat;
75
+
lon;
76
+
alt;
77
+
acc;
78
+
vel;
79
+
cog;
80
+
batt;
81
+
bs;
82
+
conn;
83
+
t;
84
+
m;
85
+
poi;
86
+
inregions = Option.value ~default:[] inregions;
87
+
addr;
88
+
topic;
89
+
}
57
90
in
58
91
Jsont.Object.map ~kind:"location" make
59
92
|> Jsont.Object.mem "_type" Jsont.string ~enc:(fun _ -> "location")
···
71
104
|> Jsont.Object.opt_mem "t" Jsont.string ~enc:(fun l -> l.t)
72
105
|> Jsont.Object.opt_mem "m" Jsont.int ~enc:(fun l -> l.m)
73
106
|> Jsont.Object.opt_mem "poi" Jsont.string ~enc:(fun l -> l.poi)
74
-
|> Jsont.Object.opt_mem "inregions" (Jsont.list Jsont.string)
75
-
~enc:(fun l -> match l.inregions with [] -> None | xs -> Some xs)
107
+
|> Jsont.Object.opt_mem "inregions" (Jsont.list Jsont.string) ~enc:(fun l ->
108
+
match l.inregions with [] -> None | xs -> Some xs)
76
109
|> Jsont.Object.opt_mem "addr" Jsont.string ~enc:(fun l -> l.addr)
77
110
|> Jsont.Object.opt_mem "topic" Jsont.string ~enc:(fun l -> l.topic)
78
-
|> Jsont.Object.skip_unknown
79
-
|> Jsont.Object.finish
111
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
80
112
81
113
let jsont_bare : t Jsont.t =
82
-
let make tid tst lat lon alt acc vel cog batt bs conn t m poi
83
-
inregions addr topic =
84
-
{ tid; tst; lat; lon; alt; acc; vel; cog; batt; bs; conn; t; m; poi;
85
-
inregions = Option.value ~default:[] inregions; addr; topic }
114
+
let make tid tst lat lon alt acc vel cog batt bs conn t m poi inregions addr
115
+
topic =
116
+
{
117
+
tid;
118
+
tst;
119
+
lat;
120
+
lon;
121
+
alt;
122
+
acc;
123
+
vel;
124
+
cog;
125
+
batt;
126
+
bs;
127
+
conn;
128
+
t;
129
+
m;
130
+
poi;
131
+
inregions = Option.value ~default:[] inregions;
132
+
addr;
133
+
topic;
134
+
}
86
135
in
87
136
Jsont.Object.map ~kind:"location" make
88
137
|> Jsont.Object.opt_mem "tid" Jsont.string ~enc:(fun l -> l.tid)
···
99
148
|> Jsont.Object.opt_mem "t" Jsont.string ~enc:(fun l -> l.t)
100
149
|> Jsont.Object.opt_mem "m" Jsont.int ~enc:(fun l -> l.m)
101
150
|> Jsont.Object.opt_mem "poi" Jsont.string ~enc:(fun l -> l.poi)
102
-
|> Jsont.Object.opt_mem "inregions" (Jsont.list Jsont.string)
103
-
~enc:(fun l -> match l.inregions with [] -> None | xs -> Some xs)
151
+
|> Jsont.Object.opt_mem "inregions" (Jsont.list Jsont.string) ~enc:(fun l ->
152
+
match l.inregions with [] -> None | xs -> Some xs)
104
153
|> Jsont.Object.opt_mem "addr" Jsont.string ~enc:(fun l -> l.addr)
105
154
|> Jsont.Object.opt_mem "topic" Jsont.string ~enc:(fun l -> l.topic)
106
-
|> Jsont.Object.skip_unknown
107
-
|> Jsont.Object.finish
155
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
108
156
109
157
let format_timestamp tst =
110
158
let t = Unix.gmtime (float_of_int tst) in
111
-
Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d UTC"
112
-
(t.Unix.tm_year + 1900) (t.Unix.tm_mon + 1) t.Unix.tm_mday
113
-
t.Unix.tm_hour t.Unix.tm_min t.Unix.tm_sec
159
+
Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d UTC" (t.Unix.tm_year + 1900)
160
+
(t.Unix.tm_mon + 1) t.Unix.tm_mday t.Unix.tm_hour t.Unix.tm_min
161
+
t.Unix.tm_sec
114
162
115
163
let pp_code_map ~unknown codes ppf = function
116
164
| Some s ->
117
-
let display = List.assoc_opt s codes |> Option.value ~default:s in
118
-
Format.pp_print_string ppf display
165
+
let display = List.assoc_opt s codes |> Option.value ~default:s in
166
+
Format.pp_print_string ppf display
119
167
| None -> Format.pp_print_string ppf unknown
120
168
121
169
let pp_conn =
122
170
pp_code_map ~unknown:"Unknown"
123
-
["w", "WiFi"; "m", "Mobile"; "o", "Offline"]
171
+
[ ("w", "WiFi"); ("m", "Mobile"); ("o", "Offline") ]
124
172
125
173
let pp_trigger =
126
174
pp_code_map ~unknown:"Unknown"
127
-
["p", "Ping"; "c", "Circular region"; "b", "Beacon"; "r", "Response";
128
-
"u", "Manual"; "t", "Timer"; "v", "Monitoring"]
175
+
[
176
+
("p", "Ping");
177
+
("c", "Circular region");
178
+
("b", "Beacon");
179
+
("r", "Response");
180
+
("u", "Manual");
181
+
("t", "Timer");
182
+
("v", "Monitoring");
183
+
]
129
184
130
185
let parse_topic topic =
131
186
match String.split_on_char '/' topic with
···
137
192
Format.fprintf ppf "-------------------------------------------@,";
138
193
begin match loc.topic with
139
194
| Some topic ->
140
-
begin match parse_topic topic with
141
-
| Some (user, device) ->
142
-
Format.fprintf ppf " User: %s / %s" user device;
143
-
Option.iter (fun tid -> Format.fprintf ppf " [%s]" tid) loc.tid;
144
-
Format.fprintf ppf "@,"
145
-
| None ->
146
-
Format.fprintf ppf " Topic: %s@," topic
147
-
end
195
+
begin match parse_topic topic with
196
+
| Some (user, device) ->
197
+
Format.fprintf ppf " User: %s / %s" user device;
198
+
Option.iter (fun tid -> Format.fprintf ppf " [%s]" tid) loc.tid;
199
+
Format.fprintf ppf "@,"
200
+
| None -> Format.fprintf ppf " Topic: %s@," topic
201
+
end
148
202
| None ->
149
-
Option.iter (fun tid ->
150
-
Format.fprintf ppf " Tracker: %s@," tid
151
-
) loc.tid
203
+
Option.iter
204
+
(fun tid -> Format.fprintf ppf " Tracker: %s@," tid)
205
+
loc.tid
152
206
end;
153
207
Format.fprintf ppf " Time: %s@," (format_timestamp loc.tst);
154
208
Format.fprintf ppf " Location: %.6f, %.6f@," loc.lat loc.lon;
155
-
Option.iter (fun alt ->
156
-
Format.fprintf ppf " Altitude: %.1f m@," alt
157
-
) loc.alt;
158
-
Option.iter (fun acc ->
159
-
Format.fprintf ppf " Accuracy: +/- %.0f m@," acc
160
-
) loc.acc;
161
-
Option.iter (fun vel ->
162
-
Format.fprintf ppf " Speed: %.1f km/h@," vel
163
-
) loc.vel;
164
-
Option.iter (fun cog ->
165
-
Format.fprintf ppf " Heading: %.0f deg@," cog
166
-
) loc.cog;
167
-
Option.iter (fun batt ->
168
-
Format.fprintf ppf " Battery: %d%%@," batt
169
-
) loc.batt;
209
+
Option.iter
210
+
(fun alt -> Format.fprintf ppf " Altitude: %.1f m@," alt)
211
+
loc.alt;
212
+
Option.iter
213
+
(fun acc -> Format.fprintf ppf " Accuracy: +/- %.0f m@," acc)
214
+
loc.acc;
215
+
Option.iter
216
+
(fun vel -> Format.fprintf ppf " Speed: %.1f km/h@," vel)
217
+
loc.vel;
218
+
Option.iter
219
+
(fun cog -> Format.fprintf ppf " Heading: %.0f deg@," cog)
220
+
loc.cog;
221
+
Option.iter
222
+
(fun batt -> Format.fprintf ppf " Battery: %d%%@," batt)
223
+
loc.batt;
170
224
Format.fprintf ppf " Conn: %a@," pp_conn loc.conn;
171
-
Option.iter (fun _ ->
172
-
Format.fprintf ppf " Trigger: %a@," pp_trigger loc.t
173
-
) loc.t;
174
-
Option.iter (fun poi ->
175
-
Format.fprintf ppf " POI: %s@," poi
176
-
) loc.poi;
225
+
Option.iter
226
+
(fun _ -> Format.fprintf ppf " Trigger: %a@," pp_trigger loc.t)
227
+
loc.t;
228
+
Option.iter (fun poi -> Format.fprintf ppf " POI: %s@," poi) loc.poi;
177
229
if loc.inregions <> [] then
178
230
Format.fprintf ppf " Regions: %s@," (String.concat ", " loc.inregions);
179
-
Option.iter (fun addr ->
180
-
Format.fprintf ppf " Address: %s@," addr
181
-
) loc.addr;
231
+
Option.iter (fun addr -> Format.fprintf ppf " Address: %s@," addr) loc.addr;
182
232
Format.fprintf ppf "-------------------------------------------@]"
+26
-26
lib/owntracks_location.mli
+26
-26
lib/owntracks_location.mli
···
7
7
8
8
@canonical Owntracks.Location
9
9
10
-
The primary OwnTracks message type, published when the device reports
11
-
its location. Contains GPS coordinates, accuracy, altitude, speed,
12
-
heading, and various device state information.
10
+
The primary OwnTracks message type, published when the device reports its
11
+
location. Contains GPS coordinates, accuracy, altitude, speed, heading, and
12
+
various device state information.
13
13
14
-
Required fields are latitude, longitude, and timestamp. All other
15
-
fields are optional and may not be present depending on device
16
-
capabilities and settings. *)
14
+
Required fields are latitude, longitude, and timestamp. All other fields are
15
+
optional and may not be present depending on device capabilities and
16
+
settings. *)
17
17
18
18
type t
19
19
(** The type for location messages. *)
···
40
40
?topic:string ->
41
41
unit ->
42
42
t
43
-
(** [v ~tst ~lat ~lon ()] creates a location with the required fields.
44
-
Optional fields can be provided as labeled arguments. *)
43
+
(** [v ~tst ~lat ~lon ()] creates a location with the required fields. Optional
44
+
fields can be provided as labeled arguments. *)
45
45
46
46
(** {1 Accessors} *)
47
47
···
50
50
characters) configured in the app. *)
51
51
52
52
val tst : t -> int
53
-
(** [tst loc] returns the timestamp as Unix epoch (seconds since
54
-
1970-01-01 00:00:00 UTC). *)
53
+
(** [tst loc] returns the timestamp as Unix epoch (seconds since 1970-01-01
54
+
00:00:00 UTC). *)
55
55
56
56
val lat : t -> float
57
57
(** [lat loc] returns the latitude in decimal degrees. Range: -90 to +90. *)
···
69
69
(** [vel loc] returns the velocity (speed) in km/h, if present. *)
70
70
71
71
val cog : t -> float option
72
-
(** [cog loc] returns the course over ground (heading) in degrees from
73
-
true north (0-360), if present. *)
72
+
(** [cog loc] returns the course over ground (heading) in degrees from true
73
+
north (0-360), if present. *)
74
74
75
75
val batt : t -> int option
76
76
(** [batt loc] returns the battery level as percentage (0-100), if present. *)
···
106
106
- [3] = Move mode (frequent updates) *)
107
107
108
108
val poi : t -> string option
109
-
(** [poi loc] returns the Point of Interest name if the device is
110
-
currently at a defined location. *)
109
+
(** [poi loc] returns the Point of Interest name if the device is currently at a
110
+
defined location. *)
111
111
112
112
val inregions : t -> string list
113
-
(** [inregions loc] returns the list of region names the device is
114
-
currently inside. May be empty. *)
113
+
(** [inregions loc] returns the list of region names the device is currently
114
+
inside. May be empty. *)
115
115
116
116
val addr : t -> string option
117
-
(** [addr loc] returns the reverse-geocoded address, if present.
118
-
Typically added by the OwnTracks Recorder server. *)
117
+
(** [addr loc] returns the reverse-geocoded address, if present. Typically added
118
+
by the OwnTracks Recorder server. *)
119
119
120
120
val topic : t -> string option
121
-
(** [topic loc] returns the MQTT topic this message was published to,
122
-
if present. Added during parsing. *)
121
+
(** [topic loc] returns the MQTT topic this message was published to, if
122
+
present. Added during parsing. *)
123
123
124
124
(** {1 Modifiers} *)
125
125
···
129
129
(** {1 JSON Codec} *)
130
130
131
131
val jsont : t Jsont.t
132
-
(** [jsont] is a JSON codec for location messages.
133
-
Expects the ["_type"] field to be ["location"]. *)
132
+
(** [jsont] is a JSON codec for location messages. Expects the ["_type"] field
133
+
to be ["location"]. *)
134
134
135
135
val jsont_bare : t Jsont.t
136
-
(** [jsont_bare] is a JSON codec that doesn't require the ["_type"] field.
137
-
Use this for parsing recorder API responses which omit the type field. *)
136
+
(** [jsont_bare] is a JSON codec that doesn't require the ["_type"] field. Use
137
+
this for parsing recorder API responses which omit the type field. *)
138
138
139
139
(** {1 Pretty Printing} *)
140
140
···
142
142
(** [pp ppf loc] pretty-prints a location message. *)
143
143
144
144
val format_timestamp : int -> string
145
-
(** [format_timestamp tst] formats a Unix timestamp as an ISO 8601 string
146
-
in UTC timezone. *)
145
+
(** [format_timestamp tst] formats a Unix timestamp as an ISO 8601 string in UTC
146
+
timezone. *)
+2
-5
lib/owntracks_lwt.ml
+2
-5
lib/owntracks_lwt.ml
···
6
6
type t = { tst : int }
7
7
8
8
let v ~tst = { tst }
9
-
10
9
let tst t = t.tst
11
10
12
11
let jsont_bare : t Jsont.t =
13
12
let make tst = { tst } in
14
13
Jsont.Object.map ~kind:"lwt" make
15
14
|> Jsont.Object.mem "tst" Jsont.int ~enc:(fun l -> l.tst)
16
-
|> Jsont.Object.skip_unknown
17
-
|> Jsont.Object.finish
15
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
18
16
19
17
let jsont : t Jsont.t =
20
18
let make _type tst =
···
24
22
Jsont.Object.map ~kind:"lwt" make
25
23
|> Jsont.Object.mem "_type" Jsont.string ~enc:(fun _ -> "lwt")
26
24
|> Jsont.Object.mem "tst" Jsont.int ~enc:(fun l -> l.tst)
27
-
|> Jsont.Object.skip_unknown
28
-
|> Jsont.Object.finish
25
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
29
26
30
27
let pp ppf lwt =
31
28
Format.fprintf ppf "LWT: client disconnected at %s"
+2
-2
lib/owntracks_lwt.mli
+2
-2
lib/owntracks_lwt.mli
···
27
27
(** {1 JSON Codec} *)
28
28
29
29
val jsont : t Jsont.t
30
-
(** [jsont] is a JSON codec for LWT messages.
31
-
Expects the ["_type"] field to be ["lwt"]. *)
30
+
(** [jsont] is a JSON codec for LWT messages. Expects the ["_type"] field to be
31
+
["lwt"]. *)
32
32
33
33
val jsont_bare : t Jsont.t
34
34
(** [jsont_bare] is a JSON codec that doesn't require the ["_type"] field. *)
+17
-11
lib/owntracks_message.ml
+17
-11
lib/owntracks_message.ml
···
22
22
Jsont.Object.Case.map "location" Owntracks_location.jsont_bare ~dec:location
23
23
in
24
24
let case_transition =
25
-
Jsont.Object.Case.map "transition" Owntracks_transition.jsont_bare ~dec:transition
25
+
Jsont.Object.Case.map "transition" Owntracks_transition.jsont_bare
26
+
~dec:transition
26
27
in
27
28
let case_waypoint =
28
29
Jsont.Object.Case.map "waypoint" Owntracks_waypoint.jsont_bare ~dec:waypoint
29
30
in
30
31
let case_waypoints =
31
-
Jsont.Object.Case.map "waypoints" Owntracks_waypoint.jsont_bare ~dec:waypoint
32
+
Jsont.Object.Case.map "waypoints" Owntracks_waypoint.jsont_bare
33
+
~dec:waypoint
32
34
in
33
35
let case_card =
34
36
Jsont.Object.Case.map "card" Owntracks_card.jsont_bare ~dec:card
···
44
46
| Lwt l -> Jsont.Object.Case.value case_lwt l
45
47
| Unknown _ -> assert false (* Cannot encode Unknown *)
46
48
in
47
-
let cases = Jsont.Object.Case.[
48
-
make case_location; make case_transition;
49
-
make case_waypoint; make case_waypoints;
50
-
make case_card; make case_lwt
51
-
] in
49
+
let cases =
50
+
Jsont.Object.Case.
51
+
[
52
+
make case_location;
53
+
make case_transition;
54
+
make case_waypoint;
55
+
make case_waypoints;
56
+
make case_card;
57
+
make case_lwt;
58
+
]
59
+
in
52
60
Jsont.Object.map ~kind:"message" Fun.id
53
61
|> Jsont.Object.case_mem "_type" Jsont.string ~enc:Fun.id ~enc_case cases
54
-
|> Jsont.Object.skip_unknown
55
-
|> Jsont.Object.finish
62
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
56
63
57
64
let pp ppf = function
58
65
| Location loc -> Owntracks_location.pp ppf loc
···
60
67
| Waypoint wp -> Owntracks_waypoint.pp ppf wp
61
68
| Card c -> Owntracks_card.pp ppf c
62
69
| Lwt l -> Owntracks_lwt.pp ppf l
63
-
| Unknown typ ->
64
-
Format.fprintf ppf "Unknown message type: %s" typ
70
+
| Unknown typ -> Format.fprintf ppf "Unknown message type: %s" typ
+8
-13
lib/owntracks_message.mli
+8
-13
lib/owntracks_message.mli
···
8
8
@canonical Owntracks.Message
9
9
10
10
All OwnTracks message types as a single variant. Use {!jsont} with
11
-
{{:https://erratique.ch/software/jsont}jsont_bytesrw} to decode
12
-
messages from JSON strings. *)
11
+
{{:https://erratique.ch/software/jsont}jsont_bytesrw} to decode messages
12
+
from JSON strings. *)
13
13
14
+
(** The type for OwnTracks messages. *)
14
15
type t =
15
-
| Location of Owntracks_location.t
16
-
(** A location update from the device. *)
17
-
| Transition of Owntracks_transition.t
18
-
(** A region entry/exit event. *)
19
-
| Waypoint of Owntracks_waypoint.t
20
-
(** A waypoint/region definition. *)
21
-
| Card of Owntracks_card.t
22
-
(** User information card. *)
23
-
| Lwt of Owntracks_lwt.t
24
-
(** Client disconnection notification. *)
16
+
| Location of Owntracks_location.t (** A location update from the device. *)
17
+
| Transition of Owntracks_transition.t (** A region entry/exit event. *)
18
+
| Waypoint of Owntracks_waypoint.t (** A waypoint/region definition. *)
19
+
| Card of Owntracks_card.t (** User information card. *)
20
+
| Lwt of Owntracks_lwt.t (** Client disconnection notification. *)
25
21
| Unknown of string
26
22
(** Unknown message type. Contains the ["_type"] value. *)
27
-
(** The type for OwnTracks messages. *)
28
23
29
24
(** {1 JSON Codec} *)
30
25
+9
-10
lib/owntracks_mqtt.ml
+9
-10
lib/owntracks_mqtt.ml
···
40
40
if String.length payload > 0 && payload.[0] = '{' then
41
41
let topic_json = Printf.sprintf "{\"topic\":%S," msg.topic in
42
42
topic_json ^ String.sub payload 1 (String.length payload - 1)
43
-
else
44
-
payload
43
+
else payload
45
44
in
46
-
match Jsont_bytesrw.decode_string Owntracks_message.jsont payload_with_topic with
45
+
match
46
+
Jsont_bytesrw.decode_string Owntracks_message.jsont payload_with_topic
47
+
with
47
48
| Ok message -> Ok { topic = msg.topic; user; device; message }
48
49
| Error e -> Error e
49
50
50
51
let of_mqtt ~topic ~payload : (t, string) result =
51
-
of_mqtt_message { Mqtt_message.topic; payload; qos = `At_least_once; retain = false }
52
+
of_mqtt_message
53
+
{ Mqtt_message.topic; payload; qos = `At_least_once; retain = false }
52
54
53
55
let default_topic = "owntracks/#"
54
-
55
56
let user_topic user = Printf.sprintf "owntracks/%s/#" user
56
-
57
57
let device_topic ~user ~device = Printf.sprintf "owntracks/%s/%s" user device
58
58
59
59
let pp ppf msg =
60
60
Format.fprintf ppf "@[<v 0>";
61
-
begin match msg.user, msg.device with
61
+
begin match (msg.user, msg.device) with
62
62
| Some user, Some device ->
63
-
Format.fprintf ppf "User: %s / Device: %s@," user device
64
-
| _ ->
65
-
Format.fprintf ppf "Topic: %s@," msg.topic
63
+
Format.fprintf ppf "User: %s / Device: %s@," user device
64
+
| _ -> Format.fprintf ppf "Topic: %s@," msg.topic
66
65
end;
67
66
Owntracks_message.pp ppf msg.message;
68
67
Format.fprintf ppf "@]"
+14
-14
lib/owntracks_mqtt.mli
+14
-14
lib/owntracks_mqtt.mli
···
7
7
8
8
@canonical Owntracks.Mqtt
9
9
10
-
This module provides helpers for parsing MQTT messages into OwnTracks
11
-
types and constructing MQTT topic patterns for subscriptions.
10
+
This module provides helpers for parsing MQTT messages into OwnTracks types
11
+
and constructing MQTT topic patterns for subscriptions.
12
12
13
13
{1 Topic Format}
14
14
···
55
55
(** [of_mqtt_message msg] parses an MQTT message into an OwnTracks message.
56
56
57
57
Extracts user and device from the topic if it follows the OwnTracks
58
-
convention ([owntracks/user/device]). The topic is also injected into
59
-
the message payload for location messages.
58
+
convention ([owntracks/user/device]). The topic is also injected into the
59
+
message payload for location messages.
60
60
61
61
Returns [Error] if the payload is not valid OwnTracks JSON. *)
62
62
63
63
val of_mqtt : topic:string -> payload:string -> (t, string) result
64
-
(** [of_mqtt ~topic ~payload] is a convenience function for parsing
65
-
MQTT messages without constructing an {!Mqtt_message.t} record.
64
+
(** [of_mqtt ~topic ~payload] is a convenience function for parsing MQTT
65
+
messages without constructing an {!Mqtt_message.t} record.
66
66
67
-
Equivalent to calling {!of_mqtt_message} with default QoS and
68
-
retain settings. *)
67
+
Equivalent to calling {!of_mqtt_message} with default QoS and retain
68
+
settings. *)
69
69
70
70
(** {1 Topic Helpers} *)
71
71
72
72
val default_topic : string
73
-
(** [default_topic] is ["owntracks/#"], a wildcard topic that matches
74
-
all OwnTracks messages from all users and devices. *)
73
+
(** [default_topic] is ["owntracks/#"], a wildcard topic that matches all
74
+
OwnTracks messages from all users and devices. *)
75
75
76
76
val user_topic : string -> string
77
-
(** [user_topic user] returns ["owntracks/{user}/#"], matching all
78
-
devices for a specific user. *)
77
+
(** [user_topic user] returns ["owntracks/{user}/#"], matching all devices for a
78
+
specific user. *)
79
79
80
80
val device_topic : user:string -> device:string -> string
81
-
(** [device_topic ~user ~device] returns ["owntracks/{user}/{device}"],
82
-
matching a specific device. *)
81
+
(** [device_topic ~user ~device] returns ["owntracks/{user}/{device}"], matching
82
+
a specific device. *)
83
83
84
84
val parse_topic : string -> (string * string) option
85
85
(** [parse_topic topic] extracts the user and device from an OwnTracks topic.
+3
-6
lib/owntracks_recorder.ml
+3
-6
lib/owntracks_recorder.ml
···
18
18
let make data = data in
19
19
Jsont.Object.map ~kind:"data_response" make
20
20
|> Jsont.Object.mem "data" locations_jsont ~enc:Fun.id
21
-
|> Jsont.Object.skip_unknown
22
-
|> Jsont.Object.finish
21
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
23
22
24
-
let string_list_jsont : string list Jsont.t =
25
-
Jsont.list Jsont.string
23
+
let string_list_jsont : string list Jsont.t = Jsont.list Jsont.string
26
24
27
25
let string_list_results_jsont : string list Jsont.t =
28
26
let make results = results in
29
27
Jsont.Object.map ~kind:"results_response" make
30
28
|> Jsont.Object.mem "results" string_list_jsont ~enc:Fun.id
31
-
|> Jsont.Object.skip_unknown
32
-
|> Jsont.Object.finish
29
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
+8
-9
lib/owntracks_recorder.mli
+8
-9
lib/owntracks_recorder.mli
···
7
7
8
8
@canonical Owntracks.Recorder
9
9
10
-
The {{:https://github.com/owntracks/recorder}OwnTracks Recorder} is a
11
-
server that stores location history and provides an HTTP API for
12
-
querying it.
10
+
The {{:https://github.com/owntracks/recorder}OwnTracks Recorder} is a server
11
+
that stores location history and provides an HTTP API for querying it.
13
12
14
-
This module provides codecs for parsing JSON responses from the
15
-
Recorder API. Use these with jsont_bytesrw for decoding.
13
+
This module provides codecs for parsing JSON responses from the Recorder
14
+
API. Use these with jsont_bytesrw for decoding.
16
15
17
16
{1 API Endpoints}
18
17
19
18
The Recorder provides these endpoints:
20
19
- [GET /api/0/list] - List all users
21
20
- [GET /api/0/list?user=USER] - List devices for a user
22
-
- [GET /api/0/locations?user=USER&device=DEVICE&from=DATE&to=DATE] -
23
-
Fetch location history *)
21
+
- [GET /api/0/locations?user=USER&device=DEVICE&from=DATE&to=DATE] - Fetch
22
+
location history *)
24
23
25
24
(** {1 Types} *)
26
25
···
42
41
(** {1 JSON Codecs} *)
43
42
44
43
val locations_jsont : Owntracks_location.t list Jsont.t
45
-
(** Codec for a JSON array of location objects (without ["_type"] field).
46
-
Use with the [/api/0/locations] endpoint when it returns an array. *)
44
+
(** Codec for a JSON array of location objects (without ["_type"] field). Use
45
+
with the [/api/0/locations] endpoint when it returns an array. *)
47
46
48
47
val locations_data_jsont : Owntracks_location.t list Jsont.t
49
48
(** Codec for [{data: [...]}] response format from some recorder endpoints. *)
+6
-11
lib/owntracks_transition.ml
+6
-11
lib/owntracks_transition.ml
···
39
39
|> Jsont.Object.mem "event" Jsont.string ~enc:(fun t -> t.event)
40
40
|> Jsont.Object.opt_mem "desc" Jsont.string ~enc:(fun t -> t.desc)
41
41
|> Jsont.Object.opt_mem "wtst" Jsont.int ~enc:(fun t -> t.wtst)
42
-
|> Jsont.Object.skip_unknown
43
-
|> Jsont.Object.finish
42
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
44
43
45
44
let jsont : t Jsont.t =
46
45
let make _type tid tst lat lon acc event desc wtst =
···
57
56
|> Jsont.Object.mem "event" Jsont.string ~enc:(fun t -> t.event)
58
57
|> Jsont.Object.opt_mem "desc" Jsont.string ~enc:(fun t -> t.desc)
59
58
|> Jsont.Object.opt_mem "wtst" Jsont.int ~enc:(fun t -> t.wtst)
60
-
|> Jsont.Object.skip_unknown
61
-
|> Jsont.Object.finish
59
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
62
60
63
61
let pp ppf tr =
64
62
Format.fprintf ppf "@[<v 0>";
65
63
Format.fprintf ppf "-------------------------------------------@,";
66
64
Format.fprintf ppf " Event: %s@," (String.uppercase_ascii tr.event);
67
-
Option.iter (fun desc ->
68
-
Format.fprintf ppf " Region: %s@," desc
69
-
) tr.desc;
70
-
Option.iter (fun tid ->
71
-
Format.fprintf ppf " Tracker: %s@," tid
72
-
) tr.tid;
73
-
Format.fprintf ppf " Time: %s@," (Owntracks_location.format_timestamp tr.tst);
65
+
Option.iter (fun desc -> Format.fprintf ppf " Region: %s@," desc) tr.desc;
66
+
Option.iter (fun tid -> Format.fprintf ppf " Tracker: %s@," tid) tr.tid;
67
+
Format.fprintf ppf " Time: %s@,"
68
+
(Owntracks_location.format_timestamp tr.tst);
74
69
Format.fprintf ppf " Location: %.6f, %.6f@," tr.lat tr.lon;
75
70
Format.fprintf ppf "-------------------------------------------@]"
+7
-7
lib/owntracks_transition.mli
+7
-7
lib/owntracks_transition.mli
···
7
7
8
8
@canonical Owntracks.Transition
9
9
10
-
Published when entering or leaving a monitored region. Transitions
11
-
are triggered by geofences (circular regions) or beacons configured
12
-
in the OwnTracks app. *)
10
+
Published when entering or leaving a monitored region. Transitions are
11
+
triggered by geofences (circular regions) or beacons configured in the
12
+
OwnTracks app. *)
13
13
14
14
type t
15
15
(** The type for transition events. *)
···
54
54
(** [desc tr] returns the description/name of the region, if present. *)
55
55
56
56
val wtst : t -> int option
57
-
(** [wtst tr] returns the timestamp of the waypoint definition that
58
-
triggered this transition, if present. *)
57
+
(** [wtst tr] returns the timestamp of the waypoint definition that triggered
58
+
this transition, if present. *)
59
59
60
60
(** {1 JSON Codec} *)
61
61
62
62
val jsont : t Jsont.t
63
-
(** [jsont] is a JSON codec for transition messages.
64
-
Expects the ["_type"] field to be ["transition"]. *)
63
+
(** [jsont] is a JSON codec for transition messages. Expects the ["_type"] field
64
+
to be ["transition"]. *)
65
65
66
66
val jsont_bare : t Jsont.t
67
67
(** [jsont_bare] is a JSON codec that doesn't require the ["_type"] field. *)
+5
-14
lib/owntracks_waypoint.ml
+5
-14
lib/owntracks_waypoint.ml
···
3
3
SPDX-License-Identifier: ISC
4
4
---------------------------------------------------------------------------*)
5
5
6
-
type t = {
7
-
tst : int;
8
-
lat : float;
9
-
lon : float;
10
-
rad : int;
11
-
desc : string;
12
-
}
6
+
type t = { tst : int; lat : float; lon : float; rad : int; desc : string }
13
7
14
8
let v ~tst ~lat ~lon ~rad ~desc = { tst; lat; lon; rad; desc }
15
-
16
9
let tst t = t.tst
17
10
let lat t = t.lat
18
11
let lon t = t.lon
···
27
20
|> Jsont.Object.mem "lon" Jsont.number ~enc:(fun w -> w.lon)
28
21
|> Jsont.Object.mem "rad" Jsont.int ~enc:(fun w -> w.rad)
29
22
|> Jsont.Object.mem "desc" Jsont.string ~enc:(fun w -> w.desc)
30
-
|> Jsont.Object.skip_unknown
31
-
|> Jsont.Object.finish
23
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
32
24
33
25
let jsont : t Jsont.t =
34
26
let make _type tst lat lon rad desc =
···
42
34
|> Jsont.Object.mem "lon" Jsont.number ~enc:(fun w -> w.lon)
43
35
|> Jsont.Object.mem "rad" Jsont.int ~enc:(fun w -> w.rad)
44
36
|> Jsont.Object.mem "desc" Jsont.string ~enc:(fun w -> w.desc)
45
-
|> Jsont.Object.skip_unknown
46
-
|> Jsont.Object.finish
37
+
|> Jsont.Object.skip_unknown |> Jsont.Object.finish
47
38
48
39
let pp ppf wp =
49
-
Format.fprintf ppf "Waypoint: %s at (%.6f, %.6f) radius %dm"
50
-
wp.desc wp.lat wp.lon wp.rad
40
+
Format.fprintf ppf "Waypoint: %s at (%.6f, %.6f) radius %dm" wp.desc wp.lat
41
+
wp.lon wp.rad
+7
-13
lib/owntracks_waypoint.mli
+7
-13
lib/owntracks_waypoint.mli
···
7
7
8
8
@canonical Owntracks.Waypoint
9
9
10
-
Describes a monitored circular region. Waypoints define geofences
11
-
that trigger transition events when the device enters or leaves them. *)
10
+
Describes a monitored circular region. Waypoints define geofences that
11
+
trigger transition events when the device enters or leaves them. *)
12
12
13
13
type t
14
14
(** The type for waypoint definitions. *)
15
15
16
16
(** {1 Constructors} *)
17
17
18
-
val v :
19
-
tst:int ->
20
-
lat:float ->
21
-
lon:float ->
22
-
rad:int ->
23
-
desc:string ->
24
-
t
18
+
val v : tst:int -> lat:float -> lon:float -> rad:int -> desc:string -> t
25
19
(** [v ~tst ~lat ~lon ~rad ~desc] creates a waypoint definition. *)
26
20
27
21
(** {1 Accessors} *)
28
22
29
23
val tst : t -> int
30
-
(** [tst wp] returns the timestamp when the waypoint was created or
31
-
last modified. *)
24
+
(** [tst wp] returns the timestamp when the waypoint was created or last
25
+
modified. *)
32
26
33
27
val lat : t -> float
34
28
(** [lat wp] returns the latitude of the region center. *)
···
45
39
(** {1 JSON Codec} *)
46
40
47
41
val jsont : t Jsont.t
48
-
(** [jsont] is a JSON codec for waypoint messages.
49
-
Expects the ["_type"] field to be ["waypoint"]. *)
42
+
(** [jsont] is a JSON codec for waypoint messages. Expects the ["_type"] field
43
+
to be ["waypoint"]. *)
50
44
51
45
val jsont_bare : t Jsont.t
52
46
(** [jsont_bare] is a JSON codec that doesn't require the ["_type"] field. *)