├── .gitignore ├── .merlin ├── .travis.yml ├── LICENSE ├── README.md ├── _tags ├── all.itarget ├── build.sh ├── charrua-unix.install ├── myocamlbuild.ml ├── opam └── src └── charruad.ml /.gitignore: -------------------------------------------------------------------------------- 1 | *.byte 2 | *.native 3 | _build 4 | *.a 5 | *.cma 6 | *.cmxa 7 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | S . 2 | S src 3 | B _build/src 4 | PKG cmdliner 5 | PKG lwt 6 | PKG cstruct 7 | PKG ipaddr 8 | PKG tuntap 9 | PKG rawlink 10 | PKG charrua-core 11 | PKG mtime.os 12 | EXT lwt 13 | EXT nonrec 14 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | sudo: false 3 | services: 4 | - docker 5 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-docker.sh 6 | script: bash -ex ./.travis-docker.sh 7 | env: 8 | global: 9 | - PACKAGE="charrua-unix.9999" 10 | matrix: 11 | - DISTRO="alpine-3.4" OCAML_VERSION="4.03.0" 12 | - DISTRO="alpine-3.4" OCAML_VERSION="4.04.0" 13 | - DISTRO="centos-6" OCAML_VERSION="4.03.0" 14 | - DISTRO="centos-6" OCAML_VERSION="4.04.0" 15 | - DISTRO="centos-7" OCAML_VERSION="4.03.0" 16 | - DISTRO="centos-7" OCAML_VERSION="4.04.0" 17 | - DISTRO="debian-stable" OCAML_VERSION="4.03.0" 18 | - DISTRO="debian-stable" OCAML_VERSION="4.04.0" 19 | - DISTRO="debian-testing" OCAML_VERSION="4.03.0" 20 | - DISTRO="debian-testing" OCAML_VERSION="4.04.0" 21 | - DISTRO="fedora-24" OCAML_VERSION="4.03.0" 22 | - DISTRO="fedora-24" OCAML_VERSION="4.04.0" 23 | - DISTRO="ubuntu-14.04" OCAML_VERSION="4.03.0" 24 | - DISTRO="ubuntu-14.04" OCAML_VERSION="4.04.0" 25 | - DISTRO="ubuntu-16.04" OCAML_VERSION="4.03.0" 26 | - DISTRO="ubuntu-16.04" OCAML_VERSION="4.04.0" 27 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Christiano F. Haesbaert 2 | 3 | Permission to use, copy, modify, and distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | 15 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ### Charrua DHCP Unix Server 2 | 3 | [charrua-unix](http://www.github.com/haesbaert/charrua-unix) is an _ISC-licensed_ 4 | Unix DHCP daemon based on 5 | [charrua-core](http://www.github.com/haesbaert/charrua-core). 6 | 7 | [![Build Status](https://travis-ci.org/haesbaert/charrua-unix.svg)](https://travis-ci.org/haesbaert/charrua-unix) 8 | 9 | #### Features 10 | 11 | * Supports a stripped down ISC dhcpd.conf. A configuration sample can be found 12 | [here](https://github.com/haesbaert/charrua-core/blob/master/sample/dhcpd.conf) 13 | * Priviledge dropping, the daemon doesn't run as root. 14 | * Almost purely-functional code. 15 | * Support for multiple interfaces/subnets. 16 | 17 | Try `charruad --help` for options. 18 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true: debug, bin_annot, strict_sequence 2 | true: package(charrua-core.server) 3 | true: package(lwt.unix), ppopt(-lwt-debug) 4 | true: package(cstruct cstruct.lwt cstruct.unix) 5 | true: package(cmdliner ipaddr tuntap rawlink mtime.clock.os) 6 | -------------------------------------------------------------------------------- /all.itarget: -------------------------------------------------------------------------------- 1 | src/charruad.native 2 | -------------------------------------------------------------------------------- /build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # Copyright (c) 2015 Christiano F. Haesbaert 4 | # 5 | # Permission to use, copy, modify, and distribute this software for any 6 | # purpose with or without fee is hereby granted, provided that the above 7 | # copyright notice and this permission notice appear in all copies. 8 | # 9 | # THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | # WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | # MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | # ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | # ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | # 17 | 18 | ocamlbuild -use-ocamlfind all.otarget $@ 19 | -------------------------------------------------------------------------------- /charrua-unix.install: -------------------------------------------------------------------------------- 1 | bin: ["_build/src/charruad.native" {"charruad"}] 2 | -------------------------------------------------------------------------------- /myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Christiano F. Haesbaert 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Ocamlbuild_plugin;; 18 | dispatch begin function 19 | | After_rules -> 20 | pflag ["ocaml";"compile";] "ppopt" (fun s -> S [A"-ppopt"; A s]); 21 | pflag ["ocaml";"ocamldep";] "ppopt" (fun s -> S [A"-ppopt"; A s]); 22 | | _ -> () 23 | end;; 24 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | name: "charrua-unix" 3 | version: "0.7" 4 | maintainer: "Christiano F. Haesbaert " 5 | authors: "Christiano F. Haesbaert " 6 | homepage: "https://github.com/haesbaert/charrua-unix" 7 | bug-reports: "https://github.com/haesbaert/charrua-unix/issues" 8 | license: "ISC" 9 | dev-repo: "https://github.com/haesbaert/charrua-unix.git" 10 | available: [ocaml-version >= "4.03" & opam-version >= "1.2"] 11 | build: [ 12 | ["sh" "build.sh"] 13 | ] 14 | depends: [ 15 | "ocamlfind" 16 | {build} 17 | "lwt" 18 | "charrua-core" {>= "0.5"} 19 | "cmdliner" 20 | "rawlink" 21 | "tuntap" 22 | "mtime" {>="1.0.0"} 23 | ] 24 | -------------------------------------------------------------------------------- /src/charruad.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Christiano F. Haesbaert 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | let () = Printexc.record_backtrace true 18 | 19 | let filter_map f l = List.rev @@ 20 | List.fold_left (fun a v -> match f v with Some v' -> v'::a | None -> a) [] l 21 | 22 | let level_of_string = function 23 | | "warning" -> Lwt_log.Warning 24 | | "notice" -> Lwt_log.Notice 25 | | "debug" -> Lwt_log.Debug 26 | | _ -> invalid_arg "Unknown verbosity level" 27 | 28 | (* Drop privileges and chroot to _charruad home *) 29 | let go_safe () = 30 | let (pw, gr) = try 31 | (Unix.getpwnam "_charruad", Unix.getgrnam "_charruad") 32 | with _ -> 33 | failwith "No user and/or group _charruad found, please create them." 34 | in 35 | Unix.chroot pw.Unix.pw_dir; 36 | Unix.chdir "/"; 37 | (* Unix.setproctitle "charruad"; XXX implement me *) 38 | let ogid = Unix.getgid () in 39 | let oegid = Unix.getegid () in 40 | let ouid = Unix.getuid () in 41 | let oeuid = Unix.geteuid () in 42 | Unix.setgroups (Array.of_list [pw.Unix.pw_gid]); 43 | Unix.setgid pw.Unix.pw_gid; 44 | Unix.setuid pw.Unix.pw_uid; 45 | if ogid = pw.Unix.pw_gid || 46 | oegid = pw.Unix.pw_gid || 47 | ouid = pw.Unix.pw_uid || 48 | oeuid = pw.Unix.pw_uid then 49 | failwith "Unexpected uid or gid after dropping privileges"; 50 | (* Make sure we cant restore the old gid and uid *) 51 | let canrestore = try 52 | Unix.setuid ouid; 53 | Unix.setuid oeuid; 54 | Unix.setgid ogid; 55 | Unix.setgid oegid; 56 | true 57 | with _ -> false in 58 | if canrestore then 59 | failwith "Was able to restore UID, setuid is broken" 60 | 61 | let read_file f = 62 | let ic = open_in f in 63 | let n = in_channel_length ic in 64 | let buf = Bytes.create n in 65 | really_input ic buf 0 n; 66 | close_in ic; 67 | buf 68 | 69 | let go_daemon () = 70 | Lwt_daemon.daemonize ~syslog:false () 71 | 72 | let init_log vlevel daemon = 73 | Lwt_log_core.Section.(set_level main vlevel); 74 | Lwt_log.default := if daemon then 75 | Lwt_log.syslog 76 | ~template:"$(date) $(level) $(name)[$(pid)]: $(message)" 77 | ~facility:`Daemon 78 | ~paths:["/dev/log"; "/var/run/log"; "/var/run/syslog"] 79 | () 80 | else 81 | Lwt_log.channel 82 | ~template:"$(date) $(level): $(message)" 83 | ~close_mode:`Keep 84 | ~channel:Lwt_io.stdout 85 | () 86 | 87 | let rec input config db link = 88 | let open Dhcp_server.Input in 89 | let open Lwt in 90 | 91 | Lwt_rawlink.read_packet link 92 | >>= fun buf -> 93 | let t = match Dhcp_wire.pkt_of_buf buf (Cstruct.len buf) with 94 | | Error e -> Lwt_log.error e 95 | >>= fun () -> 96 | return db 97 | | Ok pkt -> 98 | Lwt_log.debug_f "Received packet: %s" (Dhcp_wire.pkt_to_string pkt) 99 | >>= fun () -> 100 | let now = Mtime_clock.elapsed () |> Mtime.Span.to_s |> Int32.of_float in 101 | match (input_pkt config db pkt now) with 102 | | Silence -> return db 103 | | Update db -> return db 104 | | Reply (reply, db) -> 105 | Lwt_rawlink.send_packet link (Dhcp_wire.buf_of_pkt reply) 106 | >>= fun () -> 107 | Lwt_log.debug_f "Sent reply packet: %s" (Dhcp_wire.pkt_to_string reply) 108 | >>= fun () -> 109 | return db 110 | | Warning w -> Lwt_log.warning w 111 | >>= fun () -> 112 | return db 113 | | Error e -> Lwt_log.error e 114 | >>= fun () -> 115 | return db 116 | in 117 | t >>= fun db -> input config db link 118 | 119 | let ifname_of_address ip_addr interfaces = 120 | let ifnet = 121 | List.find (function name, (ip_addrx, _) -> ip_addr = ip_addrx) interfaces 122 | in 123 | match ifnet with name, (_, _) -> name 124 | 125 | let charruad configfile verbosity daemonize = 126 | let open Dhcp_server.Config in 127 | let open Dhcp_server.Lease in 128 | let open Lwt in 129 | 130 | init_log (level_of_string verbosity) daemonize; 131 | let interfaces = Tuntap.getifaddrs_v4 () in 132 | let addresses = List.map 133 | (function name, (addr, _) -> (addr, Tuntap.get_macaddr name)) 134 | interfaces 135 | in 136 | let configtxt = read_file configfile in 137 | (* let config = parse configtxt addresses in *) 138 | let db = make_db () in 139 | if daemonize then 140 | go_daemon (); 141 | Lwt_log.ign_notice "Charrua DHCPD starting"; 142 | (* Filter out the addresses which have networks assigned *) 143 | let threads = filter_map 144 | (fun addr_tuple -> 145 | let addr = fst addr_tuple in 146 | let s = Ipaddr.V4.to_string addr in 147 | let config = try Some (parse configtxt addr_tuple) with Not_found -> None in 148 | match config with 149 | | Some config -> 150 | Lwt_log.ign_notice_f "Found network for %s" s; 151 | (* Get a rawlink on the interface *) 152 | let ifname = ifname_of_address addr interfaces in 153 | let link = Lwt_rawlink.(open_link ~filter:(dhcp_filter ()) ifname) in 154 | (* Create a thread *) 155 | Some (input config db link) 156 | | None -> 157 | let () = Lwt_log.ign_debug_f "No network found for %s" s in 158 | None) 159 | addresses 160 | in 161 | if List.length threads = 0 then 162 | failwith "Could not match any interface address with any network section."; 163 | go_safe (); 164 | Lwt_main.run (Lwt.pick threads >>= fun _ -> 165 | Lwt_log.notice "Charrua DHCPD exiting") 166 | 167 | (* Parse command line and start the ball *) 168 | open Cmdliner 169 | let cmd = 170 | let configfile = Arg.(value & opt string "/etc/dhcpd.conf" & info ["c" ; "config"] 171 | ~doc:"Configuration file path") in 172 | let verbosity = Arg.(value & opt string "notice" & info ["v" ; "verbosity"] 173 | ~doc:"Log verbosity, warning|notice|debug") in 174 | let daemonize = Arg.(value & flag & info ["D" ; "daemon"] 175 | ~doc:"Daemonize") in 176 | (* let color = *) 177 | (* let when_enum = [ "always", `Always; "never", `Never; "auto", `Auto ] in *) 178 | (* let doc = Arg.info ~docv:"WHEN" *) 179 | (* ~doc:(Printf.sprintf "Colorize the output. $(docv) must be %s." *) 180 | (* (Arg.doc_alts_enum when_enum)) ["color"] in *) 181 | (* Arg.(value & opt (enum when_enum) `Auto & doc) in *) 182 | Term.(pure charruad $ configfile $ verbosity $ daemonize), 183 | Term.info "charruad" ~version:"0.1" ~doc:"Charrua DHCPD" 184 | let () = match Term.eval cmd with `Error _ -> exit 1 | _ -> exit 0 185 | --------------------------------------------------------------------------------