+15 -1

bin/dune

reviewed

··· 2 2 (name main) 3 3 (public_name owntracks) 4 4 (package owntracks) 5 5 - (libraries mqtte mqtte.eio mqtte.cmd owntracks eio_main xdge tomlt tomlt.eio logs.fmt fmt.tty mirage-crypto-rng.unix geojson jsont jsont.bytesrw requests)) 5 5 + (libraries 6 6 + mqtte 7 7 + mqtte.eio 8 8 + mqtte.cmd 9 9 + owntracks 10 10 + eio_main 11 11 + xdge 12 12 + tomlt 13 13 + tomlt.eio 14 14 + logs.fmt 15 15 + fmt.tty 16 16 + mirage-crypto-rng.unix 17 17 + jsont 18 18 + jsont.bytesrw 19 19 + requests))

+11 -201

bin/main.ml

reviewed

··· 300 300 let doc = "List configured device name mappings" in 301 301 Cmd.v (Cmd.info "devices" ~doc) Term.(const run $ const ()) 302 302 303 303 - (** {1 GeoJSON Output} *) 304 304 - 305 305 - (** Jsont adapter for the Geojson library *) 306 306 - module Jsont_json : Geojson.Json with type t = Jsont.json = struct 307 307 - type t = Jsont.json 308 308 - 309 309 - let find json keys = 310 310 - let rec go j = function 311 311 - | [] -> Some j 312 312 - | k :: ks -> 313 313 - match j with 314 314 - | Jsont.Object (mems, _) -> 315 315 - (match List.find_opt (fun ((n, _), _) -> n = k) mems with 316 316 - | Some (_, v) -> go v ks 317 317 - | None -> None) 318 318 - | _ -> None 319 319 - in 320 320 - go json keys 321 321 - 322 322 - let to_string = function 323 323 - | Jsont.String (s, _) -> Ok s 324 324 - | _ -> Error (`Msg "expected string") 325 325 - 326 326 - let string s = Jsont.Json.string s 327 327 - 328 328 - let to_float = function 329 329 - | Jsont.Number (f, _) -> Ok f 330 330 - | _ -> Error (`Msg "expected number") 331 331 - 332 332 - let float f = Jsont.Json.number f 333 333 - 334 334 - let to_int = function 335 335 - | Jsont.Number (f, _) -> Ok (int_of_float f) 336 336 - | _ -> Error (`Msg "expected number") 337 337 - 338 338 - let int i = Jsont.Json.int i 339 339 - 340 340 - let to_list f = function 341 341 - | Jsont.Array (l, _) -> Ok (List.map f l) 342 342 - | _ -> Error (`Msg "expected array") 343 343 - 344 344 - let list f l = Jsont.Json.list (List.map f l) 345 345 - 346 346 - let to_array f = function 347 347 - | Jsont.Array (l, _) -> Ok (Array.of_list (List.map f l)) 348 348 - | _ -> Error (`Msg "expected array") 349 349 - 350 350 - let array f a = Jsont.Json.list (List.map f (Array.to_list a)) 351 351 - 352 352 - let to_obj = function 353 353 - | Jsont.Object (mems, _) -> Ok (List.map (fun ((n, _), v) -> (n, v)) mems) 354 354 - | _ -> Error (`Msg "expected object") 355 355 - 356 356 - let obj l = Jsont.Json.object' (List.map (fun (n, v) -> Jsont.Json.mem (Jsont.Json.name n) v) l) 357 357 - 358 358 - let null = Jsont.Json.null () 359 359 - let is_null = function Jsont.Null _ -> true | _ -> false 360 360 - end 361 361 - 362 362 - module Geo = Geojson.Make (Jsont_json) 363 363 - 364 364 - module Geojson_output = struct 365 365 - let pos_of_loc (loc : Owntracks.location) = 366 366 - Geo.Geometry.Position.v ?altitude:loc.alt ~lng:loc.lon ~lat:loc.lat () 367 367 - 368 368 - let props ~device_name ~timestamp ~time ?accuracy ?speed ?battery ?tracker_id () = 369 369 - let open Jsont.Json in 370 370 - let add n f opt acc = match opt with Some v -> (n, f v) :: acc | None -> acc in 371 371 - [ 372 372 - ("name", string device_name); 373 373 - ("timestamp", int timestamp); 374 374 - ("time", string time) 375 375 - ] 376 376 - |> add "accuracy" number accuracy 377 377 - |> add "speed" number speed 378 378 - |> add "battery" int battery 379 379 - |> add "tracker_id" string tracker_id 380 380 - |> Jsont_json.obj 381 381 - 382 382 - (** Convert a location to GeoJSON Feature with Point geometry *) 383 383 - let point_feature ~device_name (loc : Owntracks.location) : Geo.t = 384 384 - let point = Geo.Geometry.Point.v (pos_of_loc loc) in 385 385 - let geom = Geo.Geometry.v (Point point) in 386 386 - let properties = Some (props ~device_name ~timestamp:loc.tst 387 387 - ~time:(Owntracks.format_timestamp loc.tst) 388 388 - ?accuracy:loc.acc ?speed:loc.vel ?battery:loc.batt ?tracker_id:loc.tid ()) in 389 389 - let feature = Geo.Feature.v ?properties geom in 390 390 - Geo.v (Feature feature) 391 391 - 392 392 - (** Convert a list of locations to GeoJSON Feature with LineString geometry *) 393 393 - let linestring_feature ~device_name (locs : Owntracks.location list) : Geo.t = 394 394 - let sorted = List.sort (fun a b -> Int.compare a.Owntracks.tst b.Owntracks.tst) locs in 395 395 - let positions = Array.of_list (List.map pos_of_loc sorted) in 396 396 - let line = Geo.Geometry.LineString.v positions in 397 397 - let geom = Geo.Geometry.v (LineString line) in 398 398 - let start_time = match sorted with [] -> 0 | h :: _ -> h.tst in 399 399 - let end_time = match List.rev sorted with [] -> 0 | h :: _ -> h.tst in 400 400 - let properties = Some (Jsont_json.obj [ 401 401 - ("name", Jsont.Json.string device_name); 402 402 - ("points", Jsont.Json.int (List.length sorted)); 403 403 - ("start_time", Jsont.Json.string (Owntracks.format_timestamp start_time)); 404 404 - ("end_time", Jsont.Json.string (Owntracks.format_timestamp end_time)); 405 405 - ]) in 406 406 - let feature = Geo.Feature.v ?properties geom in 407 407 - Geo.v (Feature feature) 408 408 - 409 409 - let to_string geo = 410 410 - let json = Geo.to_json geo in 411 411 - match Jsont_bytesrw.encode_string Jsont.json json with 412 412 - | Ok s -> s 413 413 - | Error e -> failwith e 414 414 - end 415 415 - 416 303 (** {1 OwnTracks Recorder HTTP API} *) 417 304 418 305 module Recorder = struct 419 419 - (** Query the OwnTracks Recorder HTTP API for historical locations. 420 420 - API: GET /api/0/locations?user=USER&device=DEVICE&from=YYYY-MM-DD&to=YYYY-MM-DD *) 421 421 - 422 422 - let location_of_json (json : Jsont.json) : Owntracks.location option = 423 423 - let get_float key = 424 424 - match json with 425 425 - | Jsont.Object (mems, _) -> 426 426 - List.find_map (fun ((k, _), v) -> 427 427 - if k = key then 428 428 - match v with 429 429 - | Jsont.Number (f, _) -> Some f 430 430 - | _ -> None 431 431 - else None) mems 432 432 - | _ -> None 433 433 - in 434 434 - let get_int key = Option.map int_of_float (get_float key) in 435 435 - let get_string key = 436 436 - match json with 437 437 - | Jsont.Object (mems, _) -> 438 438 - List.find_map (fun ((k, _), v) -> 439 439 - if k = key then 440 440 - match v with 441 441 - | Jsont.String (s, _) -> Some s 442 442 - | _ -> None 443 443 - else None) mems 444 444 - | _ -> None 445 445 - in 446 446 - match (get_float "lat", get_float "lon", get_int "tst") with 447 447 - | (Some lat, Some lon, Some tst) -> 448 448 - Some { 449 449 - Owntracks.lat; lon; tst; 450 450 - tid = get_string "tid"; 451 451 - alt = get_float "alt"; 452 452 - acc = get_float "acc"; 453 453 - vel = get_float "vel"; 454 454 - cog = get_float "cog"; 455 455 - batt = get_int "batt"; 456 456 - bs = get_int "bs"; 457 457 - conn = get_string "conn"; 458 458 - t = get_string "t"; 459 459 - m = get_int "m"; 460 460 - poi = get_string "poi"; 461 461 - inregions = []; 462 462 - addr = get_string "addr"; 463 463 - topic = get_string "topic"; 464 464 - } 465 465 - | _ -> None 306 306 + (** HTTP client for the OwnTracks Recorder API. 466 307 467 467 - let parse_locations_json json_str : Owntracks.location list = 468 468 - match Jsont_bytesrw.decode_string Jsont.json json_str with 469 469 - | Error _ -> [] 470 470 - | Ok json -> 471 471 - match json with 472 472 - | Jsont.Array (items, _) -> 473 473 - List.filter_map location_of_json items 474 474 - | Jsont.Object (mems, _) -> 475 475 - (* Sometimes the API returns { "data": [...] } *) 476 476 - (match List.find_opt (fun ((k, _), _) -> k = "data") mems with 477 477 - | Some (_, Jsont.Array (items, _)) -> List.filter_map location_of_json items 478 478 - | _ -> []) 479 479 - | _ -> [] 480 480 - 481 481 - let parse_string_list json_str : string list = 482 482 - match Jsont_bytesrw.decode_string Jsont.json json_str with 483 483 - | Error _ -> [] 484 484 - | Ok json -> 485 485 - match json with 486 486 - | Jsont.Object (mems, _) -> 487 487 - (* API returns { "results": ["user1", "user2", ...] } *) 488 488 - (match List.find_opt (fun ((k, _), _) -> k = "results") mems with 489 489 - | Some (_, Jsont.Array (items, _)) -> 490 490 - List.filter_map (function 491 491 - | Jsont.String (s, _) -> Some s 492 492 - | _ -> None) items 493 493 - | _ -> []) 494 494 - | Jsont.Array (items, _) -> 495 495 - List.filter_map (function 496 496 - | Jsont.String (s, _) -> Some s 497 497 - | _ -> None) items 498 498 - | _ -> [] 308 308 + Uses the parsing functions from Owntracks.Recorder. *) 499 309 500 310 let list_users ~sw env ~verbose_http ~recorder_url ?auth () : string list = 501 311 let url = Printf.sprintf "%s/api/0/list" recorder_url in ··· 512 322 let response = Requests.get ~headers session url in 513 323 if Requests.Response.ok response then begin 514 324 let body = Requests.Response.body response |> Eio.Flow.read_all in 515 515 - parse_string_list body 325 325 + Owntracks.Recorder.parse_string_list body 516 326 end else begin 517 327 Format.eprintf "HTTP error: %d@." (Requests.Response.status_code response); 518 328 [] ··· 533 343 let response = Requests.get ~headers session url in 534 344 if Requests.Response.ok response then begin 535 345 let body = Requests.Response.body response |> Eio.Flow.read_all in 536 536 - parse_string_list body 346 346 + Owntracks.Recorder.parse_string_list body 537 347 end else begin 538 348 Format.eprintf "HTTP error: %d@." (Requests.Response.status_code response); 539 349 [] ··· 562 372 let response = Requests.get ~headers session url in 563 373 if Requests.Response.ok response then begin 564 374 let body = Requests.Response.body response |> Eio.Flow.read_all in 565 565 - parse_locations_json body 375 375 + Owntracks.Recorder.parse_locations_json body 566 376 end else begin 567 377 Format.eprintf "HTTP error: %d@." (Requests.Response.status_code response); 568 378 [] ··· 617 427 1 618 428 | locs -> 619 429 let device_name = Config.resolve_device_name config device in 620 620 - let json = Geojson_output.linestring_feature ~device_name locs in 621 621 - print_endline (Geojson_output.to_string json); 430 430 + let json = Owntracks.Geojson_output.linestring_feature ~device_name locs in 431 431 + print_endline (Owntracks.Geojson_output.to_string json); 622 432 0) 623 433 | None -> 624 434 (* Use MQTT for real-time data *) ··· 655 465 track_device_name := device_name; 656 466 track_points := loc :: !track_points 657 467 end else if Option.is_none !result then 658 658 - result := Some (Geojson_output.point_feature ~device_name loc) 468 468 + result := Some (Owntracks.Geojson_output.point_feature ~device_name loc) 659 469 end 660 470 | _ -> ()) 661 471 | Error _ -> () ··· 688 498 Format.eprintf "No locations received within %.0f seconds@." duration; 689 499 1 690 500 | points -> 691 691 - let json = Geojson_output.linestring_feature ~device_name:!track_device_name points in 692 692 - print_endline (Geojson_output.to_string json); 501 501 + let json = Owntracks.Geojson_output.linestring_feature ~device_name:!track_device_name points in 502 502 + print_endline (Owntracks.Geojson_output.to_string json); 693 503 0 694 504 end else begin 695 505 (* Single point mode: wait for first location then exit immediately *) ··· 700 510 Mqtte_eio.Client.disconnect client; 701 511 match !result with 702 512 | Some json -> 703 703 - print_endline (Geojson_output.to_string json); 513 513 + print_endline (Owntracks.Geojson_output.to_string json); 704 514 0 705 515 | None -> 706 516 Format.eprintf "No location received within %.0f seconds@." duration;

-1

dune-project

reviewed

··· 14 14 (depends 15 15 (ocaml (>= 5.1)) 16 16 jsont 17 17 - geojson 18 17 requests 19 18 (mqtte (>= 0.1)) 20 19 (eio (>= 1.0))

+343

lib/geojson.ml

reviewed

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2024 The jsont programmers. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + (** GeoJSON codec using jsont. 7 7 + 8 8 + See {{:https://datatracker.ietf.org/doc/html/rfc7946}RFC 7946} for the 9 9 + GeoJSON specification. This module provides types and jsont codecs for 10 10 + encoding and decoding GeoJSON data. *) 11 11 + 12 12 + type float_array = float array 13 13 + 14 14 + let float_array_jsont ~kind = Jsont.array ~kind Jsont.number 15 15 + 16 16 + type 'a garray = 'a array 17 17 + 18 18 + let garray = Jsont.array 19 19 + 20 20 + (** Bounding box. *) 21 21 + module Bbox = struct 22 22 + type t = float_array 23 23 + 24 24 + let jsont = float_array_jsont ~kind:"Bbox" 25 25 + end 26 26 + 27 27 + (** Position coordinates [longitude, latitude] or [longitude, latitude, altitude]. *) 28 28 + module Position = struct 29 29 + type t = float_array 30 30 + 31 31 + let jsont = float_array_jsont ~kind:"Position" 32 32 + 33 33 + let v ?altitude ~lng ~lat () = 34 34 + match altitude with 35 35 + | Some alt -> [| lng; lat; alt |] 36 36 + | None -> [| lng; lat |] 37 37 + 38 38 + let lng t = t.(0) 39 39 + let lat t = t.(1) 40 40 + let altitude t = if Array.length t > 2 then Some t.(2) else None 41 41 + end 42 42 + 43 43 + (** Internal wrapper for GeoJSON objects with bbox and unknown fields. *) 44 44 + module Geojson_object = struct 45 45 + type 'a t = { type' : 'a; bbox : Bbox.t option; unknown : Jsont.json } 46 46 + 47 47 + let make type' bbox unknown = { type'; bbox; unknown } 48 48 + let type' o = o.type' 49 49 + let bbox o = o.bbox 50 50 + let unknown o = o.unknown 51 51 + 52 52 + let finish_jsont map = 53 53 + map 54 54 + |> Jsont.Object.opt_mem "bbox" Bbox.jsont ~enc:bbox 55 55 + |> Jsont.Object.keep_unknown Jsont.json_mems ~enc:unknown 56 56 + |> Jsont.Object.finish 57 57 + 58 58 + let geometry ~kind coordinates = 59 59 + Jsont.Object.map ~kind make 60 60 + |> Jsont.Object.mem "coordinates" coordinates ~enc:type' 61 61 + |> finish_jsont 62 62 + end 63 63 + 64 64 + (** Point geometry. *) 65 65 + module Point = struct 66 66 + type t = Position.t 67 67 + 68 68 + let jsont = Geojson_object.geometry ~kind:"Point" Position.jsont 69 69 + let v pos = Geojson_object.make pos None (Jsont.Json.object' []) 70 70 + end 71 71 + 72 72 + (** MultiPoint geometry. *) 73 73 + module Multi_point = struct 74 74 + type t = Position.t garray 75 75 + 76 76 + let jsont = 77 77 + 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 84 + let jsont = 85 85 + Geojson_object.geometry ~kind:"LineString" (garray Position.jsont) 86 86 + 87 87 + let v positions = Geojson_object.make positions None (Jsont.Json.object' []) 88 88 + end 89 89 + 90 90 + (** MultiLineString geometry. *) 91 91 + module Multi_line_string = struct 92 92 + type t = Line_string.t garray 93 93 + 94 94 + let jsont = 95 95 + Geojson_object.geometry ~kind:"LineString" (garray (garray Position.jsont)) 96 96 + end 97 97 + 98 98 + (** Polygon geometry. *) 99 99 + module Polygon = struct 100 100 + type t = Line_string.t garray 101 101 + 102 102 + let jsont = 103 103 + Geojson_object.geometry ~kind:"Polygon" (garray (garray Position.jsont)) 104 104 + end 105 105 + 106 106 + (** MultiPolygon geometry. *) 107 107 + module Multi_polygon = struct 108 108 + type t = Polygon.t garray 109 109 + 110 110 + let jsont = 111 111 + Geojson_object.geometry ~kind:"MultiPolygon" 112 112 + (garray (garray (garray Position.jsont))) 113 113 + end 114 114 + 115 115 + (** Main GeoJSON module with all geometry types, features, and collections. *) 116 116 + module Geojson = struct 117 117 + type 'a object' = 'a Geojson_object.t 118 118 + 119 119 + type geometry = 120 120 + [ `Point of Point.t object' 121 121 + | `Multi_point of Multi_point.t object' 122 122 + | `Line_string of Line_string.t object' 123 123 + | `Multi_line_string of Multi_line_string.t object' 124 124 + | `Polygon of Polygon.t object' 125 125 + | `Multi_polygon of Multi_polygon.t object' 126 126 + | `Geometry_collection of geometry_collection object' ] 127 127 + 128 128 + and geometry_collection = geometry list 129 129 + 130 130 + (** Feature with optional id, geometry, and properties. *) 131 131 + module Feature = struct 132 132 + type id = [ `Number of float | `String of string ] 133 133 + 134 134 + type t = { 135 135 + id : id option; 136 136 + geometry : geometry option; 137 137 + properties : Jsont.json option; 138 138 + } 139 139 + 140 140 + let make id geometry properties = { id; geometry; properties } 141 141 + 142 142 + let make_geojson_object id geometry properties = 143 143 + Geojson_object.make (make id geometry properties) 144 144 + 145 145 + let id f = f.id 146 146 + let geometry f = f.geometry 147 147 + let properties f = f.properties 148 148 + 149 149 + type collection = t object' list 150 150 + 151 151 + let v ?properties geometry = 152 152 + let obj = { id = None; geometry = Some geometry; properties } in 153 153 + Geojson_object.make obj None (Jsont.Json.object' []) 154 154 + end 155 155 + 156 156 + type t = 157 157 + [ `Feature of Feature.t object' 158 158 + | `Feature_collection of Feature.collection object' 159 159 + | geometry ] 160 160 + 161 161 + let point v = `Point v 162 162 + let multi_point v = `Multi_point v 163 163 + let line_string v = `Line_string v 164 164 + let multi_line_string v = `Multi_line_string v 165 165 + let polygon v = `Polygon v 166 166 + let multi_polygon v = `Multi_polygon v 167 167 + let geometry_collection vs = `Geometry_collection vs 168 168 + let feature v = `Feature v 169 169 + let feature_collection vs = `Feature_collection vs 170 170 + 171 171 + let feature_id_jsont = 172 172 + let number = 173 173 + let dec = Jsont.Base.dec (fun n -> `Number n) in 174 174 + let enc = Jsont.Base.enc (function `Number n -> n | _ -> assert false) 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 179 + let enc = Jsont.Base.enc (function `String n -> n | _ -> assert false) in 180 180 + Jsont.Base.string (Jsont.Base.map ~enc ~dec ()) 181 181 + in 182 182 + let enc = function `Number _ -> number | `String _ -> string in 183 183 + Jsont.any ~kind:"id" ~dec_number:number ~dec_string:string ~enc () 184 184 + 185 185 + let case_map obj dec = Jsont.Object.Case.map (Jsont.kind obj) obj ~dec 186 186 + 187 187 + let rec geometry_jsont = 188 188 + lazy 189 189 + begin 190 190 + let case_point = case_map Point.jsont point in 191 191 + let case_multi_point = case_map Multi_point.jsont multi_point in 192 192 + let case_line_string = case_map Line_string.jsont line_string in 193 193 + let case_multi_line_string = 194 194 + case_map Multi_line_string.jsont multi_line_string 195 195 + in 196 196 + let case_polygon = case_map Polygon.jsont polygon in 197 197 + let case_multi_polygon = case_map Multi_polygon.jsont multi_polygon in 198 198 + let case_geometry_collection = 199 199 + case_map (Lazy.force geometry_collection_jsont) geometry_collection 200 200 + in 201 201 + let enc_case = function 202 202 + | `Point v -> Jsont.Object.Case.value case_point v 203 203 + | `Multi_point v -> Jsont.Object.Case.value case_multi_point v 204 204 + | `Line_string v -> Jsont.Object.Case.value case_line_string v 205 205 + | `Multi_line_string v -> 206 206 + Jsont.Object.Case.value case_multi_line_string v 207 207 + | `Polygon v -> Jsont.Object.Case.value case_polygon v 208 208 + | `Multi_polygon v -> Jsont.Object.Case.value case_multi_polygon v 209 209 + | `Geometry_collection v -> 210 210 + Jsont.Object.Case.value case_geometry_collection v 211 211 + in 212 212 + let cases = 213 213 + Jsont.Object.Case. 214 214 + [ 215 215 + make case_point; 216 216 + make case_multi_point; 217 217 + make case_line_string; 218 218 + make case_multi_line_string; 219 219 + make case_polygon; 220 220 + make case_multi_polygon; 221 221 + make case_geometry_collection; 222 222 + ] 223 223 + in 224 224 + Jsont.Object.map ~kind:"Geometry object" Fun.id 225 225 + |> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases 226 226 + ~tag_to_string:Fun.id ~tag_compare:String.compare 227 227 + |> Jsont.Object.finish 228 228 + end 229 229 + 230 230 + and feature_jsont : Feature.t object' Jsont.t Lazy.t = 231 231 + lazy 232 232 + begin 233 233 + let case_feature = case_map (Lazy.force case_feature_jsont) Fun.id in 234 234 + let enc_case v = Jsont.Object.Case.value case_feature v in 235 235 + let cases = Jsont.Object.Case.[ make case_feature ] in 236 236 + Jsont.Object.map ~kind:"Feature" Fun.id 237 237 + |> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases 238 238 + ~tag_to_string:Fun.id ~tag_compare:String.compare 239 239 + |> Jsont.Object.finish 240 240 + end 241 241 + 242 242 + and case_feature_jsont : Feature.t object' Jsont.t Lazy.t = 243 243 + lazy 244 244 + begin 245 245 + Jsont.Object.map ~kind:"Feature" Feature.make_geojson_object 246 246 + |> Jsont.Object.opt_mem "id" feature_id_jsont ~enc:(fun o -> 247 247 + Feature.id (Geojson_object.type' o)) 248 248 + |> Jsont.Object.mem "geometry" 249 249 + (Jsont.option (Jsont.rec' geometry_jsont)) 250 250 + ~enc:(fun o -> Feature.geometry (Geojson_object.type' o)) 251 251 + |> Jsont.Object.mem "properties" (Jsont.option Jsont.json_object) 252 252 + ~enc:(fun o -> Feature.properties (Geojson_object.type' o)) 253 253 + |> Geojson_object.finish_jsont 254 254 + end 255 255 + 256 256 + and geometry_collection_jsont = 257 257 + lazy 258 258 + begin 259 259 + Jsont.Object.map ~kind:"GeometryCollection" Geojson_object.make 260 260 + |> Jsont.Object.mem "geometries" 261 261 + (Jsont.list (Jsont.rec' geometry_jsont)) 262 262 + ~enc:Geojson_object.type' 263 263 + |> Geojson_object.finish_jsont 264 264 + end 265 265 + 266 266 + and feature_collection_json = 267 267 + lazy 268 268 + begin 269 269 + Jsont.Object.map ~kind:"FeatureCollection" Geojson_object.make 270 270 + |> Jsont.Object.mem "features" 271 271 + Jsont.(list (Jsont.rec' feature_jsont)) 272 272 + ~enc:Geojson_object.type' 273 273 + |> Geojson_object.finish_jsont 274 274 + end 275 275 + 276 276 + and jsont : t Jsont.t Lazy.t = 277 277 + lazy 278 278 + begin 279 279 + let case_point = case_map Point.jsont point in 280 280 + let case_multi_point = case_map Multi_point.jsont multi_point in 281 281 + let case_line_string = case_map Line_string.jsont line_string in 282 282 + let case_multi_line_string = 283 283 + case_map Multi_line_string.jsont multi_line_string 284 284 + in 285 285 + let case_polygon = case_map Polygon.jsont polygon in 286 286 + let case_multi_polygon = case_map Multi_polygon.jsont multi_polygon in 287 287 + let case_geometry_collection = 288 288 + case_map (Lazy.force geometry_collection_jsont) geometry_collection 289 289 + in 290 290 + let case_feature = 291 291 + case_map (Lazy.force case_feature_jsont) feature 292 292 + in 293 293 + let case_feature_collection = 294 294 + case_map (Lazy.force feature_collection_json) feature_collection 295 295 + in 296 296 + let enc_case = function 297 297 + | `Point v -> Jsont.Object.Case.value case_point v 298 298 + | `Multi_point v -> Jsont.Object.Case.value case_multi_point v 299 299 + | `Line_string v -> Jsont.Object.Case.value case_line_string v 300 300 + | `Multi_line_string v -> 301 301 + Jsont.Object.Case.value case_multi_line_string v 302 302 + | `Polygon v -> Jsont.Object.Case.value case_polygon v 303 303 + | `Multi_polygon v -> Jsont.Object.Case.value case_multi_polygon v 304 304 + | `Geometry_collection v -> 305 305 + Jsont.Object.Case.value case_geometry_collection v 306 306 + | `Feature v -> Jsont.Object.Case.value case_feature v 307 307 + | `Feature_collection v -> 308 308 + Jsont.Object.Case.value case_feature_collection v 309 309 + in 310 310 + let cases = 311 311 + Jsont.Object.Case. 312 312 + [ 313 313 + make case_point; 314 314 + make case_multi_point; 315 315 + make case_line_string; 316 316 + make case_multi_line_string; 317 317 + make case_polygon; 318 318 + make case_multi_polygon; 319 319 + make case_geometry_collection; 320 320 + make case_feature; 321 321 + make case_feature_collection; 322 322 + ] 323 323 + in 324 324 + Jsont.Object.map ~kind:"GeoJSON" Fun.id 325 325 + |> Jsont.Object.case_mem "type" Jsont.string ~enc:Fun.id ~enc_case cases 326 326 + ~tag_to_string:Fun.id ~tag_compare:String.compare 327 327 + |> Jsont.Object.finish 328 328 + end 329 329 + 330 330 + let jsont = Lazy.force jsont 331 331 + 332 332 + let to_string t = 333 333 + match Jsont_bytesrw.encode_string jsont t with 334 334 + | Ok s -> s 335 335 + | Error e -> failwith e 336 336 + end 337 337 + 338 338 + (** Convenience module for working with GeoJSON geometry types. *) 339 339 + module Geometry = struct 340 340 + module Position = Position 341 341 + module Point = Point 342 342 + module LineString = Line_string 343 343 + end

+278

lib/geojson.mli

reviewed

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2024 The jsont programmers. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + (** GeoJSON codec using jsont. 7 7 + 8 8 + This module provides types and {{:https://erratique.ch/software/jsont}jsont} 9 9 + codecs for encoding and decoding GeoJSON data according to 10 10 + {{:https://datatracker.ietf.org/doc/html/rfc7946}RFC 7946}. 11 11 + 12 12 + {1:overview Overview} 13 13 + 14 14 + GeoJSON is a format for encoding geographic data structures. It supports 15 15 + the 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) 19 19 + - {!Multi_point}, {!Multi_line_string}, {!Multi_polygon} - collections 20 20 + - Geometry collections 21 21 + 22 22 + These geometries can be wrapped in {!Geojson.Feature} objects with 23 23 + associated properties, or grouped into feature collections. 24 24 + 25 25 + {1:example Example} 26 26 + 27 27 + Creating a simple point feature: 28 28 + {[ 29 29 + let pos = Position.v ~lng:(-122.4194) ~lat:37.7749 () in 30 30 + let point = Point.v pos in 31 31 + let feature = Geojson.Feature.v (`Point point) in 32 32 + let geojson = `Feature feature in 33 33 + Geojson.to_string geojson 34 34 + ]} *) 35 35 + 36 36 + (** {1:primitives Primitive Types} *) 37 37 + 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 41 + - 2D: [\[west, south, east, north\]] 42 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. *) 46 46 + 47 47 + val jsont : t Jsont.t 48 48 + (** [jsont] is a JSON codec for bounding boxes. *) 49 49 + end 50 50 + 51 51 + (** Geographic position coordinates. 52 52 + 53 53 + Positions are represented as arrays of 2 or 3 numbers: 54 54 + - 2D: [\[longitude, latitude\]] 55 55 + - 3D: [\[longitude, latitude, altitude\]] 56 56 + 57 57 + Note that the order is longitude first, then latitude, following the 58 58 + GeoJSON 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. *) 62 62 + 63 63 + val jsont : t Jsont.t 64 64 + (** [jsont] is a JSON codec for positions. *) 65 65 + 66 66 + val v : ?altitude:float -> lng:float -> lat:float -> unit -> t 67 67 + (** [v ~lng ~lat ()] creates a 2D position. 68 68 + [v ~altitude ~lng ~lat ()] creates a 3D position with altitude. *) 69 69 + 70 70 + val lng : t -> float 71 71 + (** [lng t] returns the longitude (first element). *) 72 72 + 73 73 + val lat : t -> float 74 74 + (** [lat t] returns the latitude (second element). *) 75 75 + 76 76 + val altitude : t -> float option 77 77 + (** [altitude t] returns the altitude if present (third element). *) 78 78 + end 79 79 + 80 80 + (** {1:internal Internal Types} *) 81 81 + 82 82 + (** Internal wrapper for GeoJSON objects with optional bounding box. 83 83 + 84 84 + All GeoJSON objects can have an optional bounding box and may contain 85 85 + unknown JSON members that are preserved during round-tripping. *) 86 86 + module Geojson_object : sig 87 87 + type 'a t 88 88 + (** The type for GeoJSON objects wrapping a value of type ['a]. *) 89 89 + 90 90 + val type' : 'a t -> 'a 91 91 + (** [type' o] returns the wrapped value (the geometry coordinates or 92 92 + feature data). *) 93 93 + 94 94 + val bbox : 'a t -> Bbox.t option 95 95 + (** [bbox o] returns the optional bounding box. *) 96 96 + end 97 97 + 98 98 + (** {1:geometry Geometry Types} *) 99 99 + 100 100 + (** Point geometry - a single position. 101 101 + 102 102 + A Point represents a single location in coordinate space. *) 103 103 + module Point : sig 104 104 + type t = Position.t 105 105 + (** The type for point coordinates. *) 106 106 + 107 107 + val jsont : t Geojson_object.t Jsont.t 108 108 + (** [jsont] is a JSON codec for Point geometry objects. *) 109 109 + 110 110 + val v : Position.t -> t Geojson_object.t 111 111 + (** [v pos] creates a Point geometry from a position. *) 112 112 + end 113 113 + 114 114 + (** MultiPoint geometry - a collection of positions. 115 115 + 116 116 + A MultiPoint represents multiple locations. *) 117 117 + module Multi_point : sig 118 118 + type t = Position.t array 119 119 + (** The type for multipoint coordinates. *) 120 120 + 121 121 + val jsont : t Geojson_object.t Jsont.t 122 122 + (** [jsont] is a JSON codec for MultiPoint geometry objects. *) 123 123 + end 124 124 + 125 125 + (** LineString geometry - an ordered sequence of positions forming a line. 126 126 + 127 127 + A LineString must have at least two positions. It represents a path 128 128 + through coordinate space. *) 129 129 + module Line_string : sig 130 130 + type t = Position.t array 131 131 + (** The type for linestring coordinates. *) 132 132 + 133 133 + val jsont : t Geojson_object.t Jsont.t 134 134 + (** [jsont] is a JSON codec for LineString geometry objects. *) 135 135 + 136 136 + val v : Position.t array -> t Geojson_object.t 137 137 + (** [v positions] creates a LineString geometry from an array of positions. *) 138 138 + end 139 139 + 140 140 + (** MultiLineString geometry - a collection of line strings. 141 141 + 142 142 + Represents multiple paths or lines. *) 143 143 + module Multi_line_string : sig 144 144 + type t = Line_string.t array 145 145 + (** The type for multilinestring coordinates. *) 146 146 + 147 147 + val jsont : t Geojson_object.t Jsont.t 148 148 + (** [jsont] is a JSON codec for MultiLineString geometry objects. *) 149 149 + end 150 150 + 151 151 + (** Polygon geometry - an area bounded by linear rings. 152 152 + 153 153 + A polygon is represented as an array of linear rings. The first ring 154 154 + is the exterior boundary; subsequent rings are holes. Each ring must 155 155 + have at least four positions, with the first and last being identical 156 156 + (a closed ring). *) 157 157 + module Polygon : sig 158 158 + type t = Line_string.t array 159 159 + (** The type for polygon coordinates (array of linear rings). *) 160 160 + 161 161 + val jsont : t Geojson_object.t Jsont.t 162 162 + (** [jsont] is a JSON codec for Polygon geometry objects. *) 163 163 + end 164 164 + 165 165 + (** MultiPolygon geometry - a collection of polygons. 166 166 + 167 167 + Represents multiple areas, possibly with holes. *) 168 168 + module Multi_polygon : sig 169 169 + type t = Polygon.t array 170 170 + (** The type for multipolygon coordinates. *) 171 171 + 172 172 + val jsont : t Geojson_object.t Jsont.t 173 173 + (** [jsont] is a JSON codec for MultiPolygon geometry objects. *) 174 174 + end 175 175 + 176 176 + (** {1:geojson Main GeoJSON Module} *) 177 177 + 178 178 + (** Main GeoJSON types including features and geometry collections. 179 179 + 180 180 + This module provides the complete GeoJSON type hierarchy as defined 181 181 + in {{:https://datatracker.ietf.org/doc/html/rfc7946}RFC 7946}. *) 182 182 + module Geojson : sig 183 183 + 184 184 + (** {1:types Type Definitions} *) 185 185 + 186 186 + type 'a object' = 'a Geojson_object.t 187 187 + (** Alias for GeoJSON object wrapper. *) 188 188 + 189 189 + (** All geometry types as a polymorphic variant. *) 190 190 + type geometry = 191 191 + [ `Point of Point.t object' 192 192 + | `Multi_point of Multi_point.t object' 193 193 + | `Line_string of Line_string.t object' 194 194 + | `Multi_line_string of Multi_line_string.t object' 195 195 + | `Polygon of Polygon.t object' 196 196 + | `Multi_polygon of Multi_polygon.t object' 197 197 + | `Geometry_collection of geometry_collection object' ] 198 198 + 199 199 + and geometry_collection = geometry list 200 200 + (** A collection of geometry objects. *) 201 201 + 202 202 + (** {1:features Features} 203 203 + 204 204 + A Feature object represents a spatially bounded entity with 205 205 + associated properties. *) 206 206 + module Feature : sig 207 207 + 208 208 + type id = [ `Number of float | `String of string ] 209 209 + (** Feature identifiers can be either numbers or strings. *) 210 210 + 211 211 + type t 212 212 + (** The type for feature data (id, geometry, properties). *) 213 213 + 214 214 + val id : t -> id option 215 215 + (** [id f] returns the optional feature identifier. *) 216 216 + 217 217 + val geometry : t -> geometry option 218 218 + (** [geometry f] returns the optional geometry. A feature may have 219 219 + null geometry. *) 220 220 + 221 221 + val properties : t -> Jsont.json option 222 222 + (** [properties f] returns the optional properties JSON object. 223 223 + Properties can be any JSON object. *) 224 224 + 225 225 + type collection = t object' list 226 226 + (** A FeatureCollection is a list of features. *) 227 227 + 228 228 + val v : ?properties:Jsont.json -> geometry -> t object' 229 229 + (** [v ?properties geometry] creates a Feature with the given geometry 230 230 + and optional properties JSON object. *) 231 231 + end 232 232 + 233 233 + (** {1:toplevel Top-level GeoJSON Type} *) 234 234 + 235 235 + type t = 236 236 + [ `Feature of Feature.t object' 237 237 + | `Feature_collection of Feature.collection object' 238 238 + | geometry ] 239 239 + (** The type for any GeoJSON object. A valid GeoJSON document can be: 240 240 + - A {!Feature} with geometry and properties 241 241 + - A FeatureCollection containing multiple features 242 242 + - Any geometry type directly *) 243 243 + 244 244 + (** {1:constructors Constructors} 245 245 + 246 246 + These constructors wrap geometry objects in the appropriate variant. *) 247 247 + 248 248 + val point : Point.t object' -> [> `Point of Point.t object' ] 249 249 + val multi_point : Multi_point.t object' -> [> `Multi_point of Multi_point.t object' ] 250 250 + val line_string : Line_string.t object' -> [> `Line_string of Line_string.t object' ] 251 251 + val multi_line_string : Multi_line_string.t object' -> [> `Multi_line_string of Multi_line_string.t object' ] 252 252 + val polygon : Polygon.t object' -> [> `Polygon of Polygon.t object' ] 253 253 + val multi_polygon : Multi_polygon.t object' -> [> `Multi_polygon of Multi_polygon.t object' ] 254 254 + val geometry_collection : geometry_collection object' -> [> `Geometry_collection of geometry_collection object' ] 255 255 + val feature : Feature.t object' -> [> `Feature of Feature.t object' ] 256 256 + val feature_collection : Feature.collection object' -> [> `Feature_collection of Feature.collection object' ] 257 257 + 258 258 + (** {1:codec Encoding and Decoding} *) 259 259 + 260 260 + val jsont : t Jsont.t 261 261 + (** [jsont] is a JSON codec for GeoJSON objects. Handles all GeoJSON 262 262 + types including features, feature collections, and all geometry types. *) 263 263 + 264 264 + val to_string : t -> string 265 265 + (** [to_string t] encodes [t] as a minified JSON string. 266 266 + @raise Failure if encoding fails. *) 267 267 + end 268 268 + 269 269 + (** {1:convenience Convenience Modules} *) 270 270 + 271 271 + (** Convenience aliases for common geometry operations. 272 272 + 273 273 + Provides shorter names for frequently used modules. *) 274 274 + module Geometry : sig 275 275 + module Position = Position 276 276 + module Point = Point 277 277 + module LineString = Line_string 278 278 + end

+168

lib/owntracks.ml

reviewed

··· 429 429 pp_message ppf msg.message; 430 430 Format.fprintf ppf "@]" 431 431 end 432 432 + 433 433 + (** {1:recorder OwnTracks Recorder HTTP API} *) 434 434 + 435 435 + (** Query the OwnTracks Recorder HTTP API for historical locations. 436 436 + 437 437 + The OwnTracks Recorder provides an HTTP API for querying historical 438 438 + location data. This module provides functions to list users, list 439 439 + devices for a user, and fetch historical locations. 440 440 + 441 441 + API endpoints: 442 442 + - [GET /api/0/list] - List all users 443 443 + - [GET /api/0/list?user=USER] - List devices for a user 444 444 + - [GET /api/0/locations?user=USER&device=DEVICE&from=YYYY-MM-DD&to=YYYY-MM-DD] - Fetch locations *) 445 445 + module Recorder = struct 446 446 + 447 447 + (** {2:types Types} *) 448 448 + 449 449 + (** Authentication credentials for HTTP Basic Auth. *) 450 450 + type auth = { username : string; password : string } 451 451 + 452 452 + (** {2:parsing JSON Parsing} *) 453 453 + 454 454 + (** Parse a location from a JSON object. *) 455 455 + let location_of_json (json : Jsont.json) : location option = 456 456 + let get_float key = 457 457 + match json with 458 458 + | Jsont.Object (mems, _) -> 459 459 + List.find_map (fun ((k, _), v) -> 460 460 + if k = key then 461 461 + match v with 462 462 + | Jsont.Number (f, _) -> Some f 463 463 + | _ -> None 464 464 + else None) mems 465 465 + | _ -> None 466 466 + in 467 467 + let get_int key = Option.map int_of_float (get_float key) in 468 468 + let get_string key = 469 469 + match json with 470 470 + | Jsont.Object (mems, _) -> 471 471 + List.find_map (fun ((k, _), v) -> 472 472 + if k = key then 473 473 + match v with 474 474 + | Jsont.String (s, _) -> Some s 475 475 + | _ -> None 476 476 + else None) mems 477 477 + | _ -> None 478 478 + in 479 479 + match (get_float "lat", get_float "lon", get_int "tst") with 480 480 + | (Some lat, Some lon, Some tst) -> 481 481 + Some { 482 482 + lat; lon; tst; 483 483 + tid = get_string "tid"; 484 484 + alt = get_float "alt"; 485 485 + acc = get_float "acc"; 486 486 + vel = get_float "vel"; 487 487 + cog = get_float "cog"; 488 488 + batt = get_int "batt"; 489 489 + bs = get_int "bs"; 490 490 + conn = get_string "conn"; 491 491 + t = get_string "t"; 492 492 + m = get_int "m"; 493 493 + poi = get_string "poi"; 494 494 + inregions = []; 495 495 + addr = get_string "addr"; 496 496 + topic = get_string "topic"; 497 497 + } 498 498 + | _ -> None 499 499 + 500 500 + (** Parse a list of locations from a JSON string. 501 501 + 502 502 + Handles both array format and object with "data" key. *) 503 503 + let parse_locations_json json_str : location list = 504 504 + match Jsont_bytesrw.decode_string Jsont.json json_str with 505 505 + | Error _ -> [] 506 506 + | Ok json -> 507 507 + match json with 508 508 + | Jsont.Array (items, _) -> 509 509 + List.filter_map location_of_json items 510 510 + | Jsont.Object (mems, _) -> 511 511 + (* Sometimes the API returns { "data": [...] } *) 512 512 + (match List.find_opt (fun ((k, _), _) -> k = "data") mems with 513 513 + | Some (_, Jsont.Array (items, _)) -> List.filter_map location_of_json items 514 514 + | _ -> []) 515 515 + | _ -> [] 516 516 + 517 517 + (** Parse a list of strings from a JSON response. 518 518 + 519 519 + Handles both array format and object with "results" key. *) 520 520 + let parse_string_list json_str : string list = 521 521 + match Jsont_bytesrw.decode_string Jsont.json json_str with 522 522 + | Error _ -> [] 523 523 + | Ok json -> 524 524 + match json with 525 525 + | Jsont.Object (mems, _) -> 526 526 + (* API returns { "results": ["user1", "user2", ...] } *) 527 527 + (match List.find_opt (fun ((k, _), _) -> k = "results") mems with 528 528 + | Some (_, Jsont.Array (items, _)) -> 529 529 + List.filter_map (function 530 530 + | Jsont.String (s, _) -> Some s 531 531 + | _ -> None) items 532 532 + | _ -> []) 533 533 + | Jsont.Array (items, _) -> 534 534 + List.filter_map (function 535 535 + | Jsont.String (s, _) -> Some s 536 536 + | _ -> None) items 537 537 + | _ -> [] 538 538 + end 539 539 + 540 540 + (** {1:geojson_output GeoJSON Output} *) 541 541 + 542 542 + (** Convert OwnTracks locations to GeoJSON format. 543 543 + 544 544 + This module provides functions to convert location data into GeoJSON 545 545 + Point and LineString features for use in mapping applications. *) 546 546 + module Geojson_output = struct 547 547 + open Geojson 548 548 + 549 549 + (** Convert a location to a GeoJSON position. *) 550 550 + let pos_of_loc (loc : location) = 551 551 + Geometry.Position.v ?altitude:loc.alt ~lng:loc.lon ~lat:loc.lat () 552 552 + 553 553 + (** Create GeoJSON properties object for a location. *) 554 554 + let props ~device_name ~timestamp ~time ?accuracy ?speed ?battery ?tracker_id () = 555 555 + let open Jsont.Json in 556 556 + let add n f opt acc = match opt with Some v -> (n, f v) :: acc | None -> acc in 557 557 + [ 558 558 + ("name", string device_name); 559 559 + ("timestamp", int timestamp); 560 560 + ("time", string time) 561 561 + ] 562 562 + |> add "accuracy" number accuracy 563 563 + |> add "speed" number speed 564 564 + |> add "battery" int battery 565 565 + |> add "tracker_id" string tracker_id 566 566 + |> fun mems -> Jsont.Json.object' (List.map (fun (n, v) -> Jsont.Json.mem (Jsont.Json.name n) v) mems) 567 567 + 568 568 + (** Convert a location to a GeoJSON Feature with Point geometry. *) 569 569 + let point_feature ~device_name (loc : location) : Geojson.t = 570 570 + let point = Geometry.Point.v (pos_of_loc loc) in 571 571 + let geom : Geojson.geometry = `Point point in 572 572 + let properties = Some (props ~device_name ~timestamp:loc.tst 573 573 + ~time:(format_timestamp loc.tst) 574 574 + ?accuracy:loc.acc ?speed:loc.vel ?battery:loc.batt ?tracker_id:loc.tid ()) in 575 575 + let feature = Geojson.Feature.v ?properties geom in 576 576 + `Feature feature 577 577 + 578 578 + (** Convert a list of locations to a GeoJSON Feature with LineString geometry. 579 579 + 580 580 + Locations are sorted by timestamp before creating the linestring. *) 581 581 + let linestring_feature ~device_name (locs : location list) : Geojson.t = 582 582 + let sorted = List.sort (fun a b -> Int.compare a.tst b.tst) locs in 583 583 + let positions = Array.of_list (List.map pos_of_loc sorted) in 584 584 + let line = Geometry.LineString.v positions in 585 585 + let geom : Geojson.geometry = `Line_string line in 586 586 + let start_time = match sorted with [] -> 0 | h :: _ -> h.tst in 587 587 + let end_time = match List.rev sorted with [] -> 0 | h :: _ -> h.tst in 588 588 + let properties = Some (Jsont.Json.object' [ 589 589 + Jsont.Json.mem (Jsont.Json.name "name") (Jsont.Json.string device_name); 590 590 + Jsont.Json.mem (Jsont.Json.name "points") (Jsont.Json.int (List.length sorted)); 591 591 + Jsont.Json.mem (Jsont.Json.name "start_time") (Jsont.Json.string (format_timestamp start_time)); 592 592 + Jsont.Json.mem (Jsont.Json.name "end_time") (Jsont.Json.string (format_timestamp end_time)); 593 593 + ]) in 594 594 + let feature = Geojson.Feature.v ?properties geom in 595 595 + `Feature feature 596 596 + 597 597 + (** Encode a GeoJSON value to a JSON string. *) 598 598 + let to_string = Geojson.to_string 599 599 + end

+452

lib/owntracks.mli

reviewed

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + (** OwnTracks message types and JSON codecs. 7 7 + 8 8 + This module provides types and {{:https://erratique.ch/software/jsont}jsont} 9 9 + codecs for parsing {{:https://owntracks.org/}OwnTracks} MQTT messages. 10 10 + OwnTracks is an open-source location tracking application that publishes 11 11 + location data over MQTT. 12 12 + 13 13 + {1:overview Overview} 14 14 + 15 15 + OwnTracks publishes several message types: 16 16 + - {!location} - GPS coordinates, accuracy, speed, battery, etc. 17 17 + - {!transition} - Region entry/exit events 18 18 + - {!waypoint} - Monitored region definitions 19 19 + - {!card} - User information for display 20 20 + - {!lwt} - Last Will and Testament (disconnect notification) 21 21 + 22 22 + Messages are published to MQTT topics in the format [owntracks/user/device]. 23 23 + 24 24 + {1:example Example} 25 25 + 26 26 + Decoding a location message: 27 27 + {[ 28 28 + let json = {|{"_type":"location","lat":51.5,"lon":-0.1,"tst":1234567890}|} in 29 29 + match Owntracks.decode_message json with 30 30 + | Ok (Location loc) -> 31 31 + Printf.printf "Location: %.4f, %.4f\n" loc.lat loc.lon 32 32 + | Ok _ -> print_endline "Other message type" 33 33 + | Error e -> Printf.printf "Error: %s\n" e 34 34 + ]} 35 35 + 36 36 + See {{:https://owntracks.org/booklet/tech/json/}OwnTracks JSON format} 37 37 + for the complete specification. *) 38 38 + 39 39 + (** {1:types Message Types} *) 40 40 + 41 41 + (** Location message - the primary OwnTracks message type. 42 42 + 43 43 + Published when the device reports its location. Contains GPS coordinates, 44 44 + accuracy, altitude, speed, heading, and various device state information. 45 45 + 46 46 + Required fields are [lat], [lon], and [tst]. All other fields are optional 47 47 + and may not be present depending on device capabilities and settings. *) 48 48 + type location = { 49 49 + tid : string option; 50 50 + (** Tracker ID - a short identifier (typically 2 characters) configured 51 51 + in the app. Used to identify the device in a compact way. *) 52 52 + 53 53 + tst : int; 54 54 + (** Timestamp as Unix epoch (seconds since 1970-01-01 00:00:00 UTC). 55 55 + This is when the location was recorded by the device. *) 56 56 + 57 57 + lat : float; 58 58 + (** Latitude in decimal degrees. Range: -90 to +90. *) 59 59 + 60 60 + lon : float; 61 61 + (** Longitude in decimal degrees. Range: -180 to +180. *) 62 62 + 63 63 + alt : float option; 64 64 + (** Altitude above sea level in meters. May be negative for locations 65 65 + below sea level. *) 66 66 + 67 67 + acc : float option; 68 68 + (** Horizontal accuracy (radius) in meters. Indicates the confidence 69 69 + interval for the reported position. *) 70 70 + 71 71 + vel : float option; 72 72 + (** Velocity (speed) in km/h. Only present when the device is moving. *) 73 73 + 74 74 + cog : float option; 75 75 + (** Course over ground (heading) in degrees from true north (0-360). 76 76 + Indicates the direction of travel. *) 77 77 + 78 78 + batt : int option; 79 79 + (** Battery level as percentage (0-100). *) 80 80 + 81 81 + bs : int option; 82 82 + (** Battery status: 83 83 + - [0] = unknown 84 84 + - [1] = unplugged 85 85 + - [2] = charging 86 86 + - [3] = full *) 87 87 + 88 88 + conn : string option; 89 89 + (** Connection type: 90 90 + - ["w"] = WiFi 91 91 + - ["m"] = Mobile/cellular 92 92 + - ["o"] = Offline *) 93 93 + 94 94 + t : string option; 95 95 + (** Trigger - what caused this location report: 96 96 + - ["p"] = Ping (response to request) 97 97 + - ["c"] = Circular region event 98 98 + - ["b"] = Beacon event 99 99 + - ["r"] = Response to reportLocation 100 100 + - ["u"] = Manual/user-initiated 101 101 + - ["t"] = Timer-based 102 102 + - ["v"] = Monitoring mode change *) 103 103 + 104 104 + m : int option; 105 105 + (** Monitoring mode: 106 106 + - [0] = Quiet (no location reporting) 107 107 + - [1] = Manual (only when requested) 108 108 + - [2] = Significant changes only 109 109 + - [3] = Move mode (frequent updates) *) 110 110 + 111 111 + poi : string option; 112 112 + (** Point of Interest - name of a waypoint if the device is currently 113 113 + at a defined location. *) 114 114 + 115 115 + inregions : string list; 116 116 + (** List of region names the device is currently inside. May be empty 117 117 + if not inside any monitored regions. *) 118 118 + 119 119 + addr : string option; 120 120 + (** Reverse-geocoded address. This is typically added by the OwnTracks 121 121 + Recorder server, not the device itself. *) 122 122 + 123 123 + topic : string option; 124 124 + (** MQTT topic this message was published to. Added during parsing, 125 125 + not present in the original JSON. *) 126 126 + } 127 127 + 128 128 + (** Transition event - published when entering or leaving a monitored region. 129 129 + 130 130 + Transitions are triggered by geofences (circular regions) or beacons 131 131 + configured in the OwnTracks app. *) 132 132 + type transition = { 133 133 + t_tid : string option; 134 134 + (** Tracker ID of the device. *) 135 135 + 136 136 + t_tst : int; 137 137 + (** Timestamp when the transition occurred. *) 138 138 + 139 139 + t_lat : float; 140 140 + (** Latitude where the transition was detected. *) 141 141 + 142 142 + t_lon : float; 143 143 + (** Longitude where the transition was detected. *) 144 144 + 145 145 + t_acc : float option; 146 146 + (** Accuracy of the position in meters. *) 147 147 + 148 148 + t_event : string; 149 149 + (** Event type: ["enter"] when entering a region, ["leave"] when leaving. *) 150 150 + 151 151 + t_desc : string option; 152 152 + (** Description/name of the region. *) 153 153 + 154 154 + t_wtst : int option; 155 155 + (** Timestamp of the waypoint definition that triggered this transition. *) 156 156 + } 157 157 + 158 158 + (** Waypoint definition - describes a monitored circular region. 159 159 + 160 160 + Waypoints define geofences that trigger {!transition} events when 161 161 + the device enters or leaves them. *) 162 162 + type waypoint = { 163 163 + w_tst : int; 164 164 + (** Timestamp when the waypoint was created or last modified. *) 165 165 + 166 166 + w_lat : float; 167 167 + (** Latitude of the region center. *) 168 168 + 169 169 + w_lon : float; 170 170 + (** Longitude of the region center. *) 171 171 + 172 172 + w_rad : int; 173 173 + (** Radius of the circular region in meters. *) 174 174 + 175 175 + w_desc : string; 176 176 + (** Description/name of the waypoint. *) 177 177 + } 178 178 + 179 179 + (** Card message - provides user information for display. 180 180 + 181 181 + Cards allow users to share their name and photo with others tracking 182 182 + their location. The tracker ID must match the location message's [tid] 183 183 + to associate the card with the correct user. *) 184 184 + type card = { 185 185 + c_name : string option; 186 186 + (** Full name of the user. *) 187 187 + 188 188 + c_face : string option; 189 189 + (** Base64-encoded image (typically JPEG or PNG). *) 190 190 + 191 191 + c_tid : string option; 192 192 + (** Tracker ID that this card belongs to. Must match the [tid] in 193 193 + location messages to be associated correctly. *) 194 194 + } 195 195 + 196 196 + (** LWT (Last Will and Testament) message. 197 197 + 198 198 + Published automatically by the MQTT broker when a client disconnects 199 199 + unexpectedly. This allows subscribers to know when a device has gone 200 200 + offline. *) 201 201 + type lwt = { 202 202 + lwt_tst : int; 203 203 + (** Timestamp of the disconnection. *) 204 204 + } 205 205 + 206 206 + (** All OwnTracks message types as a variant. *) 207 207 + type message = 208 208 + | Location of location 209 209 + (** A location update from the device. *) 210 210 + | Transition of transition 211 211 + (** A region entry/exit event. *) 212 212 + | Waypoint of waypoint 213 213 + (** A waypoint/region definition. *) 214 214 + | Card of card 215 215 + (** User information card. *) 216 216 + | Lwt of lwt 217 217 + (** Client disconnection notification. *) 218 218 + | Unknown of string * Jsont.json 219 219 + (** Unknown message type. Contains the [_type] value and raw JSON 220 220 + for messages that don't match known types. *) 221 221 + 222 222 + (** {1:codecs JSON Codecs} 223 223 + 224 224 + These codecs can be used with jsont for encoding and decoding individual 225 225 + message types. For most use cases, {!decode_message} is more convenient. *) 226 226 + 227 227 + val location_jsont : location Jsont.t 228 228 + (** JSON codec for location messages. *) 229 229 + 230 230 + val transition_jsont : transition Jsont.t 231 231 + (** JSON codec for transition messages. *) 232 232 + 233 233 + val waypoint_jsont : waypoint Jsont.t 234 234 + (** JSON codec for waypoint messages. *) 235 235 + 236 236 + val card_jsont : card Jsont.t 237 237 + (** JSON codec for card messages. *) 238 238 + 239 239 + val lwt_jsont : lwt Jsont.t 240 240 + (** JSON codec for LWT messages. *) 241 241 + 242 242 + (** {1:decoding Decoding} *) 243 243 + 244 244 + val decode_message : string -> (message, string) result 245 245 + (** [decode_message json_str] decodes a JSON string into an OwnTracks message. 246 246 + 247 247 + The message type is determined by the ["_type"] field in the JSON: 248 248 + - ["location"] -> {!Location} 249 249 + - ["transition"] -> {!Transition} 250 250 + - ["waypoint"] or ["waypoints"] -> {!Waypoint} 251 251 + - ["card"] -> {!Card} 252 252 + - ["lwt"] -> {!Lwt} 253 253 + - Other values -> {!Unknown} 254 254 + 255 255 + Returns [Error] with an error message if the JSON is malformed or 256 256 + missing required fields. *) 257 257 + 258 258 + (** {1:formatting Formatting and Display} *) 259 259 + 260 260 + val format_timestamp : int -> string 261 261 + (** [format_timestamp tst] formats a Unix timestamp as an ISO 8601 string 262 262 + in UTC timezone. 263 263 + 264 264 + Example: [format_timestamp 1234567890] returns ["2009-02-13 23:31:30 UTC"]. *) 265 265 + 266 266 + val parse_topic : string -> (string * string) option 267 267 + (** [parse_topic topic] extracts the user and device from an OwnTracks topic. 268 268 + 269 269 + OwnTracks topics follow the pattern [owntracks/user/device]. 270 270 + 271 271 + Returns [Some (user, device)] if the topic matches, [None] otherwise. *) 272 272 + 273 273 + val pp_location : Format.formatter -> location -> unit 274 274 + (** [pp_location ppf loc] pretty-prints a location message. *) 275 275 + 276 276 + val pp_transition : Format.formatter -> transition -> unit 277 277 + (** [pp_transition ppf tr] pretty-prints a transition message. *) 278 278 + 279 279 + val pp_message : Format.formatter -> message -> unit 280 280 + (** [pp_message ppf msg] pretty-prints any OwnTracks message. *) 281 281 + 282 282 + (** {1:mqtt MQTT Integration} *) 283 283 + 284 284 + (** MQTT integration for OwnTracks messages. 285 285 + 286 286 + This module provides helpers for parsing MQTT messages into OwnTracks 287 287 + types and constructing MQTT topic patterns for subscriptions. 288 288 + 289 289 + {2 Topic Format} 290 290 + 291 291 + OwnTracks uses the topic pattern [owntracks/{user}/{device}] where: 292 292 + - [{user}] is typically a username or identifier 293 293 + - [{device}] identifies the specific device (phone, tablet, etc.) 294 294 + 295 295 + Use {!Mqtt.default_topic} to subscribe to all OwnTracks messages, or 296 296 + {!Mqtt.user_topic} / {!Mqtt.device_topic} for filtered subscriptions. *) 297 297 + module Mqtt : sig 298 298 + 299 299 + (** {1:types Types} *) 300 300 + 301 301 + type mqtt_message = { 302 302 + topic : string; 303 303 + payload : string; 304 304 + qos : [ `At_most_once | `At_least_once | `Exactly_once ]; 305 305 + retain : bool; 306 306 + } 307 307 + (** Raw MQTT message with topic, payload, QoS level, and retain flag. *) 308 308 + 309 309 + type t = { 310 310 + topic : string; 311 311 + user : string option; 312 312 + device : string option; 313 313 + message : message; 314 314 + } 315 315 + (** Parsed OwnTracks message with extracted user/device information. *) 316 316 + 317 317 + (** {1:parsing Parsing} *) 318 318 + 319 319 + val of_mqtt_message : mqtt_message -> (t, string) result 320 320 + (** [of_mqtt_message msg] parses an MQTT message into an OwnTracks message. 321 321 + 322 322 + Extracts user and device from the topic if it follows the OwnTracks 323 323 + convention ([owntracks/user/device]). The topic is also injected into 324 324 + the message payload for location messages. 325 325 + 326 326 + Returns [Error] if the payload is not valid OwnTracks JSON. *) 327 327 + 328 328 + val of_mqtt : topic:string -> payload:string -> (t, string) result 329 329 + (** [of_mqtt ~topic ~payload] is a convenience function for parsing 330 330 + MQTT messages without constructing an {!mqtt_message} record. 331 331 + 332 332 + Equivalent to calling {!of_mqtt_message} with default QoS and 333 333 + retain settings. *) 334 334 + 335 335 + (** {1:topics Topic Helpers} *) 336 336 + 337 337 + val default_topic : string 338 338 + (** [default_topic] is ["owntracks/#"], a wildcard topic that matches 339 339 + all OwnTracks messages from all users and devices. *) 340 340 + 341 341 + val user_topic : string -> string 342 342 + (** [user_topic user] returns ["owntracks/{user}/#"], matching all 343 343 + devices for a specific user. *) 344 344 + 345 345 + val device_topic : user:string -> device:string -> string 346 346 + (** [device_topic ~user ~device] returns ["owntracks/{user}/{device}"], 347 347 + matching a specific device. *) 348 348 + 349 349 + (** {1:formatting Pretty Printing} *) 350 350 + 351 351 + val pp : Format.formatter -> t -> unit 352 352 + (** [pp ppf msg] pretty-prints an OwnTracks MQTT message with user/device 353 353 + information. *) 354 354 + end 355 355 + 356 356 + (** {1:recorder OwnTracks Recorder API} *) 357 357 + 358 358 + (** JSON parsing for the OwnTracks Recorder HTTP API. 359 359 + 360 360 + The {{:https://github.com/owntracks/recorder}OwnTracks Recorder} is a 361 361 + server that stores location history and provides an HTTP API for 362 362 + querying it. 363 363 + 364 364 + This module provides functions to parse JSON responses from the 365 365 + Recorder API. The actual HTTP client implementation is left to the 366 366 + application. 367 367 + 368 368 + {2 API Endpoints} 369 369 + 370 370 + The Recorder provides these endpoints: 371 371 + - [GET /api/0/list] - List all users 372 372 + - [GET /api/0/list?user=USER] - List devices for a user 373 373 + - [GET /api/0/locations?user=USER&device=DEVICE&from=DATE&to=DATE] - 374 374 + Fetch location history *) 375 375 + module Recorder : sig 376 376 + 377 377 + (** {1:types Types} *) 378 378 + 379 379 + type auth = { 380 380 + username : string; 381 381 + password : string; 382 382 + } 383 383 + (** HTTP Basic Authentication credentials. *) 384 384 + 385 385 + (** {1:parsing JSON Parsing} *) 386 386 + 387 387 + val location_of_json : Jsont.json -> location option 388 388 + (** [location_of_json json] attempts to parse a JSON object as a location. 389 389 + 390 390 + Returns [Some location] if the JSON contains at least [lat], [lon], 391 391 + and [tst] fields; [None] otherwise. *) 392 392 + 393 393 + val parse_locations_json : string -> location list 394 394 + (** [parse_locations_json json_str] parses a JSON response containing 395 395 + location data. 396 396 + 397 397 + Handles two response formats: 398 398 + - Array format: [\[{...}, {...}, ...\]] 399 399 + - Object format: [{"data": \[{...}, {...}, ...\]}] 400 400 + 401 401 + Returns an empty list if parsing fails or no valid locations found. *) 402 402 + 403 403 + val parse_string_list : string -> string list 404 404 + (** [parse_string_list json_str] parses a JSON response containing a 405 405 + list of strings (e.g., usernames or device names). 406 406 + 407 407 + Handles two response formats: 408 408 + - Array format: [\["a", "b", ...\]] 409 409 + - Object format: [{"results": \["a", "b", ...\]}] 410 410 + 411 411 + Returns an empty list if parsing fails. *) 412 412 + end 413 413 + 414 414 + (** {1:geojson GeoJSON Output} *) 415 415 + 416 416 + (** Convert OwnTracks locations to GeoJSON format. 417 417 + 418 418 + This module provides functions to convert location data into 419 419 + {{:https://geojson.org/}GeoJSON} Point and LineString features 420 420 + for use in mapping applications. 421 421 + 422 422 + The output is compatible with tools like Leaflet, MapLibre, QGIS, 423 423 + and geojson.io. *) 424 424 + module Geojson_output : sig 425 425 + 426 426 + val point_feature : device_name:string -> location -> Geojson.Geojson.t 427 427 + (** [point_feature ~device_name loc] creates a GeoJSON Feature with 428 428 + Point geometry from a single location. 429 429 + 430 430 + The feature properties include: 431 431 + - [name]: the device name 432 432 + - [timestamp]: Unix timestamp 433 433 + - [time]: formatted timestamp string 434 434 + - [accuracy]: horizontal accuracy (if available) 435 435 + - [speed]: velocity in km/h (if available) 436 436 + - [battery]: battery percentage (if available) 437 437 + - [tracker_id]: tracker ID (if available) *) 438 438 + 439 439 + val linestring_feature : device_name:string -> location list -> Geojson.Geojson.t 440 440 + (** [linestring_feature ~device_name locs] creates a GeoJSON Feature 441 441 + with LineString geometry from a list of locations. 442 442 + 443 443 + Locations are sorted by timestamp before creating the line. The 444 444 + feature properties include: 445 445 + - [name]: the device name 446 446 + - [points]: number of positions in the line 447 447 + - [start_time]: formatted timestamp of first point 448 448 + - [end_time]: formatted timestamp of last point *) 449 449 + 450 450 + val to_string : Geojson.Geojson.t -> string 451 451 + (** [to_string geojson] encodes the GeoJSON value as a JSON string. *) 452 452 + end

-1

owntracks.opam

reviewed

··· 10 10 "dune" {>= "3.20"} 11 11 "ocaml" {>= "5.1"} 12 12 "jsont" 13 13 - "geojson" 14 13 "requests" 15 14 "mqtte" {>= "0.1"} 16 15 "eio" {>= "1.0"}