From 55173eb00c54454f9421f34f8ba6491f223d995b Mon Sep 17 00:00:00 2001 From: George Shammas Date: Sun, 16 Jul 2023 18:12:08 -0400 Subject: [PATCH] add async --- charrua-unix-async.opam | 31 ++++++++ unix/charruad_async.ml | 170 ++++++++++++++++++++++++++++++++++++++++ unix/dune | 12 +++ 3 files changed, 213 insertions(+) create mode 100644 charrua-unix-async.opam create mode 100644 unix/charruad_async.ml diff --git a/charrua-unix-async.opam b/charrua-unix-async.opam new file mode 100644 index 0000000..c3e6978 --- /dev/null +++ b/charrua-unix-async.opam @@ -0,0 +1,31 @@ +opam-version: "2.0" +synopsis: "Unix DHCP daemon" +description: """\ +charrua-unix is an _ISC-licensed_ Unix DHCP daemon based on +[charrua](http://www.github.com/mirage/charrua).""" +maintainer: "Christiano F. Haesbaert " +authors: "Christiano F. Haesbaert " +license: "ISC" +homepage: "https://github.com/mirage/charrua" +bug-reports: "https://github.com/mirage/charrua/issues" +depends: [ + "dune" {>= "1.4.0"} + "ocaml" {>= "4.08.0"} + "charrua" {= version} + "charrua-server" {= version} + "cstruct-unix" + "cmdliner" {>= "1.1.0"} + "async" + "rawlink-async" {>= "2.0"} + "tuntap" {>= "2.0.0"} + "mtime" {>= "2.0.0"} + "duration" + "ipaddr" {>= "5.1.0"} + "tcpip" {>= "7.0.0"} + "logs-syslog" {>= "0.3.1"} +] +build: [ + ["dune" "subst"] {dev} + ["dune" "build" "-p" name "-j" jobs] +] +dev-repo: "git+https://github.com/mirage/charrua.git" diff --git a/unix/charruad_async.ml b/unix/charruad_async.ml new file mode 100644 index 0000000..51a220a --- /dev/null +++ b/unix/charruad_async.ml @@ -0,0 +1,170 @@ +open! Core +open! Async +open Deferred.Let_syntax +module Unix = Core_unix + +let () = Printexc.record_backtrace true +let filter_map f l = List.filter_map ~f l +let start_time = Time_ns.now () + +(* Drop privileges and chroot to _charruad home *) +let go_safe user group = + let pw, _gr = + try (Unix.Passwd.getbyname_exn user, Unix.Group.getbyname_exn group) + with _ -> + failwith "No user and/or group _charruad found, please create them." + in + Unix.chroot pw.dir; + Unix.chdir "/"; + (* Unix.setproctitle "charruad"; XXX implement me *) + let ogid = Unix.getgid () in + let ouid = Unix.getuid () in + Unix.setgid pw.gid; + Unix.setuid pw.uid; + if ogid = pw.gid || ouid = pw.uid then + failwith "Unexpected uid or gid after dropping privileges"; + (* Make sure we cant restore the old gid and uid *) + let canrestore = + try + Unix.setuid ouid; + Unix.setgid ogid; + true + with _ -> false + in + if canrestore then failwith "Was able to restore UID, setuid is broken" + +let read_file = Reader.file_contents +let go_daemon = Daemon.daemonize + +let uptime_in_sec () = + Time_ns.diff (Time_ns.now ()) start_time + |> Time_ns.Span.to_sec |> Int.of_float + +let maybe_gc db now gbcol = + match now - gbcol >= 60 with + | false -> return (db, gbcol) + | true -> + Log.Global.debug_s [%message "Garbage collecting..."]; + return + ( Dhcp_server.Lease.garbage_collect db ~now:(Int32.of_int_exn now), + now + 60 ) + +let rec input config db link gbcol = + let open Dhcp_server.Input in + let%bind buf = Async_rawlink.read_packet link in + let now = uptime_in_sec () in + maybe_gc db now gbcol >>= fun (db, gbcol) -> + let t = + match Dhcp_wire.pkt_of_buf buf (Cstruct.length buf) with + | Error e -> + Log.Global.error_s [%message e]; + return db + | Ok pkt -> ( + Log.Global.debug_s + [%message "Received packet: " (Dhcp_wire.pkt_to_string pkt : string)]; + + match input_pkt config db pkt (Int32.of_int_exn now) with + | Silence -> return db + | Update db -> return db + | Reply (reply, db) -> + let%bind () = + Async_rawlink.send_packet link (Dhcp_wire.buf_of_pkt reply) + in + Log.Global.debug_s + [%message + "Sent reply packet: " (Dhcp_wire.pkt_to_string reply : string)]; + return db + | Warning w -> + Log.Global.info_s [%message w]; + return db + | Error e -> + Log.Global.error_s [%message e]; + return db) + in + t >>= fun db -> input config db link gbcol + +let ifname_of_address ip_addr interfaces = + let ifnet = + List.find_exn + ~f:(function + | _name, cidr -> + Ipaddr.V4.compare ip_addr (Ipaddr.V4.Prefix.address cidr) = 0) + interfaces + in + fst ifnet + +let charruad ~configfile ~group ~pidfile ~user ~daemonize = + let open Dhcp_server.Config in + let open Dhcp_server.Lease in + let interfaces = Tuntap.getifaddrs_v4 () in + let addresses = + List.map + ~f:(function + | name, cidr -> (Ipaddr.V4.Prefix.address cidr, Tuntap.get_macaddr name)) + interfaces + in + let%bind configtxt = read_file configfile in + (* let config = parse configtxt addresses in *) + let db = make_db () in + if daemonize then go_daemon (); + Log.Global.info_s [%message "Charrua DHCPD starting"]; + (* Filter out the addresses which have networks assigned *) + let threads = + filter_map + (fun addr_tuple -> + let addr = fst addr_tuple in + let s = Ipaddr.V4.to_string addr in + let config = + try Some (parse configtxt addr_tuple) with Not_found_s _ -> None + in + match config with + | Some config -> + Log.Global.info_s [%message "Found network for " s]; + (* Get a rawlink on the interface *) + let ifname = ifname_of_address addr interfaces in + let link = + Async_rawlink.(open_link ~filter:(dhcp_server_filter ()) ifname) + in + (* Create a thread *) + Some (input config db link (uptime_in_sec ())) + | None -> + let () = Log.Global.info_s [%message "No network found for " s] in + None) + addresses + in + if List.length threads = 0 then + failwith "Could not match any interface address with any network section."; + (* Open pidfile before dropping priviledges *) + let%bind pidc = Writer.open_file pidfile in + go_safe user group; + fprintf pidc "%d" (Unix.getpid () |> Pid.to_int); + let%bind () = Writer.close pidc in + Async.Deferred.all_unit threads + +(* Parse command line and start the ball *) +let command = + Command.async ~summary:"Charrua DHCPD" + (let%map_open.Command () = + Log_extended.Command.setup_via_params ~default_output_level:`Info + ~log_to_console_by_default:(Log_extended.Command.Stdout Color) + ~log_to_syslog_by_default:true () + and configfile = + flag "-config" + (optional_with_default "/etc/charruad.conf" string) + ~doc:"Configuration file path." + and user = + flag "-user" + (optional_with_default "_charruad" string) + ~doc:"User to run as." + and group = + flag "-group" + (optional_with_default "_charruad" string) + ~doc:"Group to run as." + and pidfile = + flag "-pidfile" + (optional_with_default "/run/charruad.pid" string) + ~doc:"Pid file path." + and daemonize = flag "-daemon" no_arg ~doc:"Daemonize." in + fun () -> charruad ~configfile ~user ~group ~pidfile ~daemonize) + +let () = Command_unix.run ~version:"%%VERSION%%" command diff --git a/unix/dune b/unix/dune index 4906a9a..8c61bdd 100644 --- a/unix/dune +++ b/unix/dune @@ -14,3 +14,15 @@ (libraries charrua charrua-server cstruct-unix cmdliner eio_main ipaddr tuntap rawlink-eio mtime.clock.os logs-syslog logs-syslog.unix duration)) + +(executable + (name charruad_async) + (modules charruad_async) + (public_name charruad-async) + (package charrua-unix-async) + (preprocess (pps ppx_jane)) + (libraries charrua charrua-server cstruct-unix + async async.log_extended + core_unix core_unix.command_unix core_unix.daemon + tuntap rawlink-async + ))