├── .gitignore ├── CHANGES.md ├── LICENSE.md ├── Makefile ├── README.md ├── charrua-client.opam ├── charrua-server.opam ├── charrua-unix.opam ├── charrua.opam ├── client ├── dhcp_client.ml ├── dhcp_client.mli ├── dune ├── lwt │ ├── dhcp_client_lwt.ml │ ├── dhcp_client_lwt.mli │ └── dune └── mirage │ ├── dhcp_client_mirage.ml │ ├── dhcp_client_mirage.mli │ ├── dhcp_ipv4.ml │ ├── dhcp_ipv4.mli │ └── dune ├── docs ├── TODO_RFC7844.md ├── rfc2131.txt ├── rfc2132.txt └── rfc7844.txt ├── dune-project ├── lib ├── dhcp_wire.ml ├── dhcp_wire.mli └── dune ├── sample └── dhcpd.conf ├── server ├── ast.ml ├── dhcp_lexer.mll ├── dhcp_parser.mly ├── dhcp_server.ml ├── dhcp_server.mli ├── dune └── util.ml ├── test ├── client │ ├── dune │ ├── lwt │ │ ├── dune │ │ └── test_client_lwt.ml │ └── test_client.ml ├── dhcp.pcap ├── dhcp2.pcap ├── dune ├── pcap.ml └── test.ml └── unix ├── charruad.ml └── dune /.gitignore: -------------------------------------------------------------------------------- 1 | *.install 2 | _build 3 | .merlin 4 | *.swp 5 | _opam 6 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ### v2.0.0 (2025-02-11) 2 | 3 | * Adapt to tcpip 9.0.0 API changes (less functors) (#132 @hannesm) 4 | * Adapt to mirage-crypto 1.2.0 API changes (#131 @hannesm) 5 | 6 | ### v1.6.0 (2024-12-09) 7 | 8 | * charruad: update to new cmdliner (#117 @haesbaert) 9 | * support mtime >= 2.0.0 (#121 @haesbaert, @tmcgilchrist) 10 | * charrua-unix: use duration package (#122 @hannesm) 11 | * replace Cstruct.copy by Cstruct.to_string (#123 @gridbugs) 12 | * use mirage-crypto-rng instead of mirage-random-test (#126 @hannesm) 13 | * remove mirage-random dependency, use mirage-crypto-rng instead - and update 14 | to mirage-crypto-rng >= 1.0.0 (#127 @hannesm) 15 | * remove ppx_cstruct and sexplib from dependency cone (#128 @hannesm) 16 | * charrua-client: update to tcpip >= 8.1.0 (#129 @hannesm) 17 | 18 | ### v1.5.0 (2021-12-15) 19 | 20 | * Adapt to mirage-protocols 8.0.0, ethernet 3.0.0, arp 3.0.0, and tcpip 7.0.0 21 | changes (#116 @hannesm) 22 | * Avoid deprecated Lwt_main.yield, use Lwt.pause instead (#115 @hannesm) 23 | 24 | ### v1.4.1 (2021-10-27) 25 | 26 | * Add database serializers (db_of_string/db_to_string) #112 @haesbaert 27 | * Remove rresult dependency (#114 @hannesm) 28 | * Avoid deprecated Cstruct.len function 29 | 30 | ### v1.4.0 (2021-07-19) 31 | 32 | Changes in #111 by @haesbaert 33 | 34 | * Allow optional arguments to be erased in Dhcp_server.make 35 | * maxleasetime -> max-lease-time in dhcpd.conf 36 | * fix handling of DHCPRELEASE 37 | * rewrite lease database 38 | * charruad: collect garbage leases, write pid file, implement -u/--user and 39 | -g/--group 40 | * opam lint, raise lower bound to 4.08.0 41 | 42 | ### v1.3.0 (2020-11-25) 43 | 44 | * Revise packaging: charrua-client-lwt and charrua-client-mirage are now 45 | available as charrua-client.lwt and charrua-client.mirage (#110 @hannesm) 46 | * Dhcp_ipv4 directly uses Dhcp_client_mirage (instead of an abstract module 47 | interface being passed) (#110 @hannesm) 48 | * Fix sending of client_identifier with appropriate type as sent by the client 49 | (#98 @hannesm, reported in #84 by @lynxis) 50 | 51 | ### v1.2.2 (2020-06-22) 52 | 53 | * Support for ipaddr 5.0.0 and tcpip 5.0.0 (#109 @hannesm) 54 | 55 | ### v1.2.1 (2020-05-11) 56 | 57 | * Fix minimal dune version (1.4) (#108 @samoht) 58 | 59 | ### v1.2.0 (2019-11-01) 60 | 61 | * adapt to mirage-protocols 4.0.0 and tcpip 4.0.0 changes (#105 @hannesm) 62 | * bump lower bound to OCaml 4.06.0 (#105 @hannesm) 63 | 64 | ### v1.1.0 (2019-07-18) 65 | 66 | * support ipaddr/macaddr.4.0.0 interfaces (#103 @avsm) 67 | * cleanup warnings in dune's default dev profile (#103 @avsm) 68 | * test with OCaml 4.08.0 (#103 @avsm) 69 | 70 | ### v1.0.0 (2019-04-18) 71 | 72 | * explicit sexplib dependency, compatible with cstruct 4.0.0 (#99, @TheLortex) 73 | * charrua-server is an independent opam package now (#100, @hannesm) 74 | * charrua is the new name for charrua-core (#100, @hannesm) 75 | * the repository moved to https://github.com/mirage/charrua 76 | 77 | ### v0.12.0 (2019-02-25) 78 | 79 | * Adjust to mirage-net 2.0.0 and mirage-protocols 2.0.0 changes (#94, @hannesm) 80 | 81 | ### v0.11.2 (2019-02-05) 82 | 83 | * build system ported to dune (#92, @hannesm) 84 | * compatibility with tcpip 3.7.0 (#91, @hannesm) 85 | * compatibility with rawlink 1.0 (#90, @hannesm) 86 | 87 | ### v0.11.1 (2019-01-09) 88 | 89 | * compatibility with ipaddr 3.0 (#88, @hannesm) 90 | * compatibility with tcpip 3.6.0 (#88, @hannesm) 91 | 92 | ### v0.11.0 (2018-11-16) 93 | 94 | * client: use the Random interface from Mirage directly, avoid calls to Stdlibrandom (removed from mirage-random 1.2.0) 95 | * unix: require lwt_log explicitly 96 | 97 | ### v0.10 (2018-09-16) 98 | 99 | * charrua-unix: safe-string support (@haesbaert) 100 | * client: add "anonymity profiles" by asking for common sets of options, to reduce the ease of profiling users by the set of DHCP requests sent (#76 @juga0) 101 | * core, client: Document code using comments (#76 and #78, @juga0 @yomimono) 102 | * core: add documentation and RFCs for specs we support (@juga0) 103 | * unix: add support for 4.06.0 via Bytes.to_string in charruad.ml (@haesbaert) 104 | * Support private_classless_static_route option (#76 @juga0) 105 | * Adjust to tcpip 3.5.0 and mirage-protocols-lwt 1.4.0 changes mirage-qubes-ipv4 106 | Static_ipv4.Make now requires a Random device and a monotonic clock 107 | connect requires a Mclock.t 108 | Mirage_protocols_lwt.IPV4 does not define the type alias ethif (#83 @hannesm) 109 | * build: various fixes (#71, #72 by @yomimono and @hannesm) 110 | 111 | ### v0.9 (2017-08-02) 112 | 113 | * core: re-implement UDP checksum on input (#63 @haesbaert) 114 | * client: implement renewal logic (breaking API change) (#60 @yomimono) 115 | * client: split mirage sublibrary into lwt sublibrary (timing logic) and mirage sublibrary (shims for MirageOS APIs) (#60 @yomimono) 116 | * numerous test and build bugfixes (#68 #64 #61 @samoht, #67 #66 #65 @djs55) 117 | 118 | ### v0.8 (2017-06-12) 119 | 120 | * Port to Jbuilder (#57 @avsm). 121 | 122 | ### v0.7 (2017-14-04) 123 | 124 | * Fixed a bug where only the first tuple from an option list would be parsed 125 | * Fixed parsing of long option lists 126 | * Fixed parsing for options 120 and 121 127 | * Updated copyrights 128 | 129 | ### v0.6 (2017-04-01) 130 | 131 | * `Dhcp_wire.buf_of_pkt` now correctly rejects empty options 132 | * `Dhcp_wire.options_of_buf` now enforces minimun length on all cases 133 | * Fixed option code for `Bcmcs_controller_ipv4_addr` 134 | * **CRITICAL** Fixed a bug where `dhcp_flags` was read from the wrong offset 135 | This bug was present in versions 0.4 and 0.5 136 | 137 | ### v0.5 (2017-03-14) 138 | 139 | * Topkg support added 140 | * Time type on input_pkt changed to int32 141 | * Bump tcpip support to version 3.1.0 142 | 143 | ### v0.4 (2017-01-21) 144 | 145 | * MirageOS3 compatibility 146 | * Ocaml 4.02.3 deprecated 147 | * Fixed lease database bug 148 | * Converted to Result.t 149 | * IP-address range on subnet made optional 150 | * Added Lease.to_string 151 | * Travis support 152 | * Improved default lease time 153 | * Fixed cases where pkt_of_buf could raise an exception 154 | 155 | ### v0.3 (2016-04-02) 156 | 157 | * Fixed uninitialized data on packet parsing, normalized to zero 158 | * Lease.database moved out of Config.t 159 | * Leases are now purely functional 160 | * Garbage collect function added 161 | * Moved Lease into Dhcp_server.Lease 162 | * Config.subnet merged into Config.t 163 | * Convert to ppx 164 | * Minor bug fixes 165 | 166 | ### v0.2 (2015-11-10) 167 | 168 | * Custom exceptions removed, only Invalid_argument now 169 | * Improved mli documentation 170 | * Major rewrite 171 | * Support ocaml 4.01 172 | 173 | ### v0.1 (2015-10-09) 174 | 175 | * Initial release 176 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015-2017 Christiano F. Haesbaert 2 | Copyright (c) 2016 Gina Marie Maini 3 | Copyright (c) 2016-2017 Mindy Preston 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 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all clean test 2 | 3 | all: 4 | dune build 5 | 6 | clean: 7 | dune clean 8 | 9 | test: 10 | dune runtest 11 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## Charrua DHCP - a DHCP client, server and wire frame encoder and decoder 2 | 3 | [![docs](https://img.shields.io/badge/doc-online-blue.svg)](https://mirage.github.io/charrua/) 4 | 5 | [charrua](http://www.github.com/mirage/charrua) is an 6 | _ISC-licensed_ DHCP library implementation in OCaml. 7 | It provides the following packages: 8 | 9 | - charrua: a library that handles wire traffic parsing 10 | - charrua-server: a DHCP server implementation 11 | - charrua-client: a library for handling DHCP client state and messages 12 | - charrua-unix: a Unix DHCP server implementation 13 | 14 | ### Charrua 15 | 16 | The name `charrua` is a reference to the, now extinct, semi-nomadic people of 17 | southern South America. 18 | 19 | Charrua consists of the single module `Dhcp_wire` responsible for parsing and 20 | constructing DHCP messages, 21 | 22 | You can browse the API for [charrua](https://www.github.com/mirage/charrua) at 23 | https://mirage.github.io/charrua/ 24 | 25 | #### Features 26 | 27 | * `Dhcp_wire` provides marshalling and unmarshalling utilities for DHCP, it is the 28 | base for `Dhcp_server`. 29 | * Logic/sequencing is agnostic of IO and platform, so it can run on Unix as a 30 | process, as a Mirage unikernel or anything else. 31 | * All DHCP options are supported at the time of this writing. 32 | * Code is purely applicative. 33 | * It's in OCaml, so it's pretty cool. 34 | 35 | ### Charrua-server 36 | 37 | The module `Dhcp_server` supports a stripped down ISC `dhcpd.conf`, so you can 38 | probably just use your old `dhcpd.conf`. It also supports manual configuration 39 | building in OCaml. 40 | 41 | [dhcp](https://github.com/mirage/mirage-skeleton/tree/master/applications/dhcp) 42 | is a [MirageOS](https://mirage.io) DHCP unikernel server based on charrua, 43 | included as a part of the MirageOS unikernel example and starting-point 44 | repository. 45 | 46 | ### Charrua-client 47 | 48 | charrua-client is a DHCP client powered by [charrua](https://github.com/mirage/charrua). 49 | 50 | The base library exposes a simple state machine in `Dhcp_client` 51 | for use in acquiring a DHCP lease. 52 | 53 | `charrua-client-lwt` extends `charrua-client` with a functor `Dhcp_client_lwt`, 54 | using the provided modules for timing and networking logic, 55 | for convenient use by a program which might wish to implement a full client. 56 | 57 | `charrua-client-mirage` exposes an additional `Dhcp_client_mirage` for direct use 58 | with the [MirageOS library operating system](https://github.com/mirage/mirage). 59 | 60 | ### Charrua-unix Server 61 | 62 | charrua-unix is an _ISC-licensed_ Unix DHCP daemon based on 63 | [charrua](http://www.github.com/mirage/charrua). 64 | 65 | #### Features 66 | 67 | * Supports a stripped down ISC dhcpd.conf. A configuration sample can be found 68 | [here](https://github.com/mirage/charrua/blob/master/sample/dhcpd.conf) 69 | * Privilege dropping: the daemon doesn't run as root. 70 | * Almost purely-functional code. 71 | * Support for multiple interfaces/subnets. 72 | 73 | Try `charruad --help` for options. 74 | 75 | This project became one of the [Mirage Pioneer](https://github.com/mirage/mirage-www/wiki/Pioneer-Projects) 76 | projects. 77 | -------------------------------------------------------------------------------- /charrua-client.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: "DHCP client implementation" 3 | description: """\ 4 | charrua-client is a DHCP client powered by [charrua](https://github.com/mirage/charrua). 5 | 6 | The base library exposes a simple state machine in `Dhcp_client` 7 | for use in acquiring a DHCP lease.""" 8 | maintainer: "Mindy Preston" 9 | authors: "Mindy Preston" 10 | license: "ISC" 11 | tags: "org:mirage" 12 | homepage: "https://github.com/mirage/charrua" 13 | doc: "https://docs.mirage.io" 14 | bug-reports: "https://github.com/mirage/charrua/issues" 15 | depends: [ 16 | "dune" {>= "1.4.0"} 17 | "ocaml" {>= "4.08.0"} 18 | "alcotest" {with-test} 19 | "cstruct-unix" {with-test} 20 | "mirage-crypto-rng" {with-test & >= "1.2.0"} 21 | "charrua-server" {= version & with-test} 22 | "charrua" {= version} 23 | "cstruct" {>= "6.0.0"} 24 | "ipaddr" {>= "5.0.0"} 25 | "macaddr" {>= "4.0.0"} 26 | "mirage-crypto-rng" {>= "1.0.0"} 27 | "mirage-mtime" {>= "4.0.0"} 28 | "mirage-sleep" {>= "4.0.0"} 29 | "mirage-net" {>= "3.0.0"} 30 | "randomconv" {>= "0.2.0"} 31 | "duration" 32 | "logs" 33 | "fmt" 34 | "ethernet" {>= "3.0.0"} 35 | "arp" {>= "3.0.0"} 36 | "tcpip" {>= "9.0.0"} 37 | "lwt" {>= "4.0.0"} 38 | ] 39 | build: [ 40 | ["dune" "subst"] {dev} 41 | ["dune" "build" "-p" name "-j" jobs] 42 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 43 | ] 44 | dev-repo: "git+https://github.com/mirage/charrua.git" 45 | x-maintenance-intent: [ "(latest)" ] 46 | -------------------------------------------------------------------------------- /charrua-server.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: "DHCP server" 3 | description: """\ 4 | Charrua-server consists of a single `Dhcp_server` module used for constructing DHCP 5 | servers. 6 | 7 | [dhcp](https://github.com/mirage/mirage-skeleton/tree/master/applications/dhcp) 8 | is a Mirage DHCP unikernel server based on charrua, included as a part of the MirageOS unikernel example and starting-point repository. 9 | 10 | #### Features 11 | 12 | * `Dhcp_server` supports a stripped down ISC dhcpd.conf, so you can probably just 13 | use your old `dhcpd.conf`. It also supports manual configuration building in 14 | OCaml. 15 | * Logic/sequencing is agnostic of IO and platform, so it can run on Unix as a 16 | process, as a Mirage unikernel or anything else. 17 | * All DHCP options are supported at the time of this writing. 18 | * Code is purely applicative. 19 | * It's in OCaml, so it's pretty cool. 20 | 21 | The name `charrua` is a reference to the, now extinct, semi-nomadic people of 22 | southern South America.""" 23 | maintainer: "Christiano F. Haesbaert " 24 | authors: "Christiano F. Haesbaert " 25 | license: "ISC" 26 | homepage: "https://github.com/mirage/charrua" 27 | doc: "https://mirage.github.io/charrua/" 28 | bug-reports: "https://github.com/mirage/charrua/issues" 29 | depends: [ 30 | "ocaml" {>= "4.08.0"} 31 | "dune" {>= "1.4.0"} 32 | "menhir" {build & >= "20181006"} 33 | "charrua" {= version} 34 | "cstruct" {>= "6.0.0"} 35 | "ipaddr" {>= "5.0.0"} 36 | "macaddr" {>= "4.0.0"} 37 | "cstruct-unix" {with-test} 38 | "tcpip" {>= "9.0.0" & with-test} 39 | "alcotest" {with-test & >= "1.4.0"} 40 | ] 41 | build: [ 42 | ["dune" "subst"] {dev} 43 | ["dune" "build" "-p" name "-j" jobs] 44 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 45 | ] 46 | dev-repo: "git+https://github.com/mirage/charrua.git" 47 | x-maintenance-intent: [ "(latest)" ] 48 | -------------------------------------------------------------------------------- /charrua-unix.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: "Unix DHCP daemon" 3 | description: """\ 4 | charrua-unix is an _ISC-licensed_ Unix DHCP daemon based on 5 | [charrua](http://www.github.com/mirage/charrua).""" 6 | maintainer: "Christiano F. Haesbaert " 7 | authors: "Christiano F. Haesbaert " 8 | license: "ISC" 9 | homepage: "https://github.com/mirage/charrua" 10 | bug-reports: "https://github.com/mirage/charrua/issues" 11 | depends: [ 12 | "dune" {>= "1.4.0"} 13 | "ocaml" {>= "4.08.0"} 14 | "lwt" {>= "3.0.0"} 15 | "lwt_log" 16 | "charrua" {= version} 17 | "charrua-server" {= version} 18 | "cstruct-unix" 19 | "cmdliner" {>= "1.1.0"} 20 | "rawlink-lwt" {>= "2.0"} 21 | "tuntap" {>= "2.0.0"} 22 | "mtime" {>= "2.0.0"} 23 | "duration" 24 | "cstruct-lwt" {>= "6.0.0"} 25 | "ipaddr" {>= "5.1.0"} 26 | "tcpip" {>= "9.0.0"} 27 | "fmt" {>= "0.9.0"} 28 | "logs" {>= "0.7.0"} 29 | ] 30 | build: [ 31 | ["dune" "subst"] {dev} 32 | ["dune" "build" "-p" name "-j" jobs] 33 | ] 34 | dev-repo: "git+https://github.com/mirage/charrua.git" 35 | x-maintenance-intent: [ "(latest)" ] 36 | -------------------------------------------------------------------------------- /charrua.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Christiano F. Haesbaert " 3 | authors: "Christiano F. Haesbaert " 4 | license: "ISC" 5 | homepage: "https://github.com/mirage/charrua" 6 | bug-reports: "https://github.com/mirage/charrua/issues" 7 | dev-repo: "git+https://github.com/mirage/charrua.git" 8 | doc: "https://mirage.github.io/charrua/" 9 | 10 | build: [ 11 | ["dune" "subst"] {dev} 12 | ["dune" "build" "-p" name "-j" jobs] 13 | ] 14 | 15 | depends: [ 16 | "ocaml" {>= "4.13.0"} 17 | "dune" {>= "1.4.0"} 18 | "cstruct" {>= "6.0.0"} 19 | "ipaddr" {>= "5.0.0"} 20 | "macaddr" {>= "4.0.0"} 21 | "ethernet" {>= "3.0.0"} 22 | "tcpip" {>= "9.0.0"} 23 | "ohex" {>= "0.2.0"} 24 | "fmt" {>= "0.9.0"} 25 | ] 26 | conflicts: [ "result" {< "1.5"} ] 27 | synopsis: "DHCP wire frame encoder and decoder" 28 | description: """ 29 | Charrua consists a single modules, `Dhcp_wire` responsible for parsing and 30 | constructing DHCP messages 31 | 32 | You can browse the API for [charrua](http://www.github.com/mirage/charrua) at 33 | https://mirage.github.io/charrua/ 34 | 35 | #### Features 36 | 37 | * `Dhcp_wire` provides marshalling and unmarshalling utilities for DHCP. 38 | * Logic/sequencing is agnostic of IO and platform, so it can run on Unix as a 39 | process, as a Mirage unikernel or anything else. 40 | * All DHCP options are supported at the time of this writing. 41 | * Code is purely applicative. 42 | * It's in OCaml, so it's pretty cool. 43 | 44 | The name `charrua` is a reference to the, now extinct, semi-nomadic people of 45 | southern South America. 46 | """ 47 | x-maintenance-intent: [ "(latest)" ] 48 | -------------------------------------------------------------------------------- /client/dhcp_client.ml: -------------------------------------------------------------------------------- 1 | (* a variant type representing the current [state] of the client transaction. 2 | Represented states differ from the diagram presented in RFC2131 in the 3 | following ways: 4 | The earliest state is `Selecting`. There is no representation of INIT-REBOOT, 5 | REBOOTING, or INIT. Calls to `create` will generate a client in state 6 | `Selecting` with the corresponding `DHCPDISCOVER` recorded, and that packet 7 | is exposed to the caller of `create`, who is responsible for sending it. 8 | There is no REBINDING state. Clients which do not re-enter the `Bound` state 9 | from `Renewing` do not halt their network and re-enter the `Selecting` state. 10 | *) 11 | type state = | Selecting of Dhcp_wire.pkt (* dhcpdiscover sent *) 12 | | Requesting of (Dhcp_wire.pkt * Dhcp_wire.pkt) (* dhcpoffer input * dhcprequest sent *) 13 | | Bound of Dhcp_wire.pkt (* dhcpack received *) 14 | | Renewing of (Dhcp_wire.pkt * Dhcp_wire.pkt) (* dhcpack received, dhcprequest sent *) 15 | 16 | (* `srcmac` will be used as the source of Ethernet frames, 17 | as well as the client identifier whenever one is required (e.g. padded with 18 | 0x00 in the `chaddr` field of the BOOTP message). 19 | `request_options` will be sent in DHCPDISCOVER and DHCPREQUEST packets. *) 20 | type t = { 21 | srcmac : Macaddr.t; 22 | request_options : Dhcp_wire.option_code list; 23 | state : state; 24 | } 25 | 26 | (* constant fields are represented here for convenience. 27 | This module can then be locally opened where required *) 28 | module Constants = struct 29 | open Dhcp_wire 30 | let htype = Ethernet_10mb 31 | let hlen = 6 (* length of a mac address in bytes *) 32 | let hops = 0 33 | let sname = "" 34 | let file = "" 35 | end 36 | 37 | (* This are the options that Windows 10 uses in the PRL implement RFC7844. 38 | They are ordered by code number. 39 | TODO: There should be a variable in the configuration where the user 40 | specifies to use the Anonymity Profiles, and ignore any other option that 41 | would modify this static PRL. 42 | This PRL could be also reverted to the minimal one and be used only when 43 | using Anonymity Profiles. 44 | *) 45 | (* if the caller of `Dhcp_client.create` has not requested their own list of 46 | Dhcp_wire.option_code , provide a default one with the minimum set of things 47 | usually required for a working network connection in MirageOS. *) 48 | let default_requests = 49 | Dhcp_wire.([ 50 | SUBNET_MASK; 51 | ROUTERS; 52 | DNS_SERVERS; 53 | DOMAIN_NAME; 54 | PERFORM_ROUTER_DISC; 55 | STATIC_ROUTES; 56 | VENDOR_SPECIFIC; 57 | NETBIOS_NAME_SERVERS; 58 | NETBIOS_NODE; 59 | NETBIOS_SCOPE; 60 | CLASSLESS_STATIC_ROUTE; 61 | PRIVATE_CLASSLESS_STATIC_ROUTE; 62 | WEB_PROXY_AUTO_DISC; 63 | ]) 64 | 65 | (* a pretty-printer for the client, useful for debugging and logging. *) 66 | let pp fmt p = 67 | let pp_state fmt = function 68 | | Selecting pkt -> Format.fprintf fmt "SELECTING. Generated %a" Dhcp_wire.pp_pkt pkt 69 | | Requesting (received, sent) -> 70 | Format.fprintf fmt 71 | "REQUESTING. Received %a, and generated response %a" 72 | Dhcp_wire.pp_pkt received Dhcp_wire.pp_pkt sent 73 | | Bound pkt -> Format.fprintf fmt "BOUND. Received %a" Dhcp_wire.pp_pkt pkt 74 | | Renewing (ack, request) -> 75 | Format.fprintf fmt 76 | "RENEWING. Have lease %a, generated request %a" 77 | Dhcp_wire.pp_pkt ack Dhcp_wire.pp_pkt request 78 | in 79 | Format.fprintf fmt "%a: %a" Macaddr.pp p.srcmac pp_state p.state 80 | 81 | (* the lease function lets callers know whether the abstract (to them) lease 82 | object carries a usable network configuration. *) 83 | let lease {state; _} = match state with 84 | | Bound dhcpack | Renewing (dhcpack, _) -> Some dhcpack 85 | | Requesting _ | Selecting _ -> None 86 | 87 | (* a convenience function for retrieving the most recently used transaction id. 88 | I don't know why this is needed or useful for anyone; it should probaby be 89 | removed. *) 90 | let xid {state; _} = 91 | let open Dhcp_wire in 92 | match state with 93 | | Selecting p -> p.xid 94 | | Requesting (_i, o) -> o.xid 95 | | Bound a -> a.xid 96 | | Renewing (_i, o) -> o.xid 97 | 98 | (* given a set of information, assemble a DHCPREQUEST packet from the Constants 99 | module and other constants defined in Dhcp_wire. *) 100 | let make_request ?(ciaddr = Ipaddr.V4.any) ~xid ~chaddr ~srcmac ~siaddr ~options () = 101 | let open Dhcp_wire in 102 | Constants.({ 103 | htype; hlen; hops; sname; file; 104 | xid; 105 | chaddr; 106 | srcport = Dhcp_wire.client_port; 107 | dstport = Dhcp_wire.server_port; 108 | srcmac; 109 | srcip = Ipaddr.V4.any; 110 | (* destinations should still be broadcast, 111 | * even though we have the necessary information to send unicast, 112 | * because there might be >1 DHCP server on the network. 113 | * those who we're not responding to should know that we're in a 114 | * transaction to accept another lease. *) 115 | dstmac = Macaddr.broadcast; 116 | dstip = Ipaddr.V4.broadcast; 117 | op = BOOTREQUEST; 118 | options; 119 | secs = 0; 120 | flags = Broadcast; 121 | ciaddr; 122 | yiaddr = Ipaddr.V4.any; 123 | siaddr; 124 | giaddr = Ipaddr.V4.any; 125 | }) 126 | 127 | (* respond to an incoming DHCPOFFER. *) 128 | let offer t ~xid ~chaddr ~server_ip ~request_ip ~offer_options:_ = 129 | let open Dhcp_wire in 130 | (* TODO: make sure the offer contains everything we expect before we accept it *) 131 | let options = [ 132 | Message_type DHCPREQUEST; 133 | Request_ip request_ip; 134 | Server_identifier server_ip; 135 | ] in 136 | let options = 137 | match t.request_options with 138 | | [] -> options (* if this is the case, the user explicitly requested it; honor that *) 139 | | _::_ -> (Parameter_requests t.request_options) :: options 140 | in 141 | make_request ~xid ~chaddr ~srcmac:t.srcmac ~siaddr:server_ip ~options:options () 142 | 143 | (* make a new DHCP client. allow the user to request a specific xid, any 144 | requests, and the MAC address to use as the source for Ethernet messages and 145 | the chaddr in the fixed-length part of the message *) 146 | let create ?requests xid srcmac = 147 | let open Constants in 148 | let open Dhcp_wire in 149 | let requests = match requests with 150 | | None | Some [] -> default_requests 151 | | Some requests -> requests 152 | in 153 | let pkt = { 154 | htype; hlen; hops; sname; file; 155 | srcmac; 156 | dstmac = Macaddr.broadcast; 157 | srcip = Ipaddr.V4.any; 158 | dstip = Ipaddr.V4.broadcast; 159 | srcport = client_port; 160 | dstport = server_port; 161 | op = BOOTREQUEST; 162 | xid; 163 | secs = 0; 164 | flags = Broadcast; 165 | ciaddr = Ipaddr.V4.any; 166 | yiaddr = Ipaddr.V4.any; 167 | siaddr = Ipaddr.V4.any; 168 | giaddr = Ipaddr.V4.any; 169 | chaddr = srcmac; 170 | options = [ 171 | Message_type DHCPDISCOVER; 172 | Client_id (Hwaddr srcmac); 173 | Parameter_requests requests; 174 | ]; 175 | } in 176 | {srcmac; request_options = requests; state = Selecting pkt}, pkt 177 | 178 | (* for a DHCP client, figure out whether an incoming packet should modify the 179 | state, and if a response message is warranted, generate it. 180 | Defined transitions are: 181 | Selecting -> DHCPOFFER -> Requesting 182 | Requesting -> DHCPACK -> Bound 183 | Requesting -> DHCPNAK -> Selecting 184 | Renewing -> DHCPACK -> Bound 185 | Renewing -> DHCPNAK -> Selecting 186 | *) 187 | let input t buf = 188 | let open Dhcp_wire in 189 | match pkt_of_buf buf (Cstruct.length buf) with 190 | | Error _ -> `Noop 191 | | Ok incoming -> 192 | (* RFC2131 4.4.1: respond only to messages for our xid *) 193 | if compare incoming.xid (xid t) = 0 then begin 194 | match find_message_type incoming.options, t.state with 195 | | None, _ -> `Noop 196 | | Some DHCPOFFER, Selecting dhcpdiscover -> 197 | (* "the mechanism used to select one DHCPOFFER [is] implementation 198 | dependent" (RFC2131) so just take the first one *) 199 | let dhcprequest = offer t ~server_ip:incoming.siaddr 200 | ~request_ip:incoming.yiaddr 201 | ~offer_options:incoming.options 202 | ~xid:dhcpdiscover.xid 203 | ~chaddr:dhcpdiscover.chaddr in 204 | `Response ({t with state = Requesting (incoming, dhcprequest)}, 205 | dhcprequest) 206 | | Some DHCPOFFER, _ -> (* DHCPOFFER is irrelevant when we're not selecting *) 207 | `Noop 208 | | Some DHCPACK, Renewing _ 209 | | Some DHCPACK, Requesting _ -> `New_lease ({t with state = Bound incoming}, incoming) 210 | | Some DHCPNAK, Requesting _ | Some DHCPNAK, Renewing _ -> 211 | `Response (create ~requests:t.request_options (xid t) t.srcmac) 212 | | Some DHCPACK, Selecting _ (* too soon *) 213 | | Some DHCPACK, Bound _ -> (* too late *) 214 | `Noop 215 | | Some DHCPDISCOVER, _ | Some DHCPDECLINE, _ | Some DHCPRELEASE, _ 216 | | Some DHCPINFORM, _ | Some DHCPREQUEST, _ -> 217 | (* we don't need to care about these client messages *) 218 | `Noop 219 | | Some DHCPNAK, Selecting _| Some DHCPNAK, Bound _ -> `Noop (* irrelevant *) 220 | | Some DHCPLEASEQUERY, _ | Some DHCPLEASEUNASSIGNED, _ 221 | | Some DHCPLEASEUNKNOWN, _ | Some DHCPLEASEACTIVE, _ 222 | | Some DHCPBULKLEASEQUERY, _ | Some DHCPLEASEQUERYDONE, _ -> 223 | (* these messages are for relay agents to extract information from servers; 224 | * our client does not care about them and shouldn't reply *) 225 | `Noop 226 | | Some DHCPFORCERENEW, _ -> `Noop (* unsupported *) 227 | end else `Noop 228 | 229 | (* try to renew the lease, probably because some time has elapsed. *) 230 | let renew t = match t.state with 231 | | Selecting _ | Requesting _ -> `Noop 232 | | Renewing (_lease, request) -> `Response (t, request) 233 | | Bound lease -> 234 | let open Dhcp_wire in 235 | let request = offer t ~xid:lease.xid ~chaddr:lease.chaddr 236 | ~server_ip:lease.siaddr ~request_ip:lease.yiaddr 237 | ~offer_options:lease.options in 238 | let state = Renewing (lease, request) in 239 | `Response ({t with state = state}, request) 240 | -------------------------------------------------------------------------------- /client/dhcp_client.mli: -------------------------------------------------------------------------------- 1 | type t 2 | (** we expect all serialization and deserialization to happen through Cstruct.t *) 3 | 4 | val pp : Format.formatter -> t -> unit 5 | 6 | val create : ?requests : Dhcp_wire.option_code list -> Cstruct.uint32 -> Macaddr.t -> (t * Dhcp_wire.pkt) 7 | (** [create xid mac] returns a pair of [t, buffer]. [t] represents the current 8 | * state of the client in the lease transaction, and [buffer] is the suggested 9 | * next packet the caller should take to progress toward accepting a lease. 10 | * The argument [xid] allows the caller to specify a transaction ID 11 | * to use for the lease attempt. 12 | * [requests] is a list of option codes which the client should ask for in its 13 | * attempt to get a DHCP lease. If [requests] is not given, we'll make an educated 14 | * guess rather than requesting nothing. 15 | *) 16 | 17 | val input : t -> Cstruct.t -> [`Response of t * Dhcp_wire.pkt | `New_lease of t * Dhcp_wire.pkt | `Noop ] 18 | (** [input t buf] attempts to advance the state of [t] 19 | * with the contents of [buf]. If [buf] is invalid or not useful given 20 | * the current state of [t], [`Noop] is returned indicating no action should be taken. 21 | * Otherwise, either a [`Response] will be suggested along with a [t] whose state has been advanced, 22 | * or a [`New_lease] will be returned along with a [t] whose state has been advanced. *) 23 | 24 | val lease : t -> Dhcp_wire.pkt option 25 | (** [lease t] will return [Some lease] if [t] has succeeded in 26 | * completing a lease transaction with some server. 27 | * Note that the library has no sense of the passage of time, so expiration 28 | * is not considered; there is no guarantee that [Some lease] is still 29 | * valid on the network. The caller is responsible for keeping track of 30 | * the time at which the lease was obtained, and renewing the lease when 31 | * necessary. 32 | * If [t] hasn't yet completed a lease transaction, [None] will be returned. *) 33 | 34 | val renew : t -> [`Response of t * Dhcp_wire.pkt | `Noop] 35 | (** [renew t] returns either a [`Response] with the next state and suggested action 36 | * of the client attempting to renew [t]'s lease, 37 | * or [`Noop] if [t] does not have a lease and therefore can't be renewed. *) 38 | -------------------------------------------------------------------------------- /client/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dhcp_client) 3 | (public_name charrua-client) 4 | (libraries charrua cstruct ipaddr macaddr)) 5 | -------------------------------------------------------------------------------- /client/lwt/dhcp_client_lwt.ml: -------------------------------------------------------------------------------- 1 | let src = Logs.Src.create "dhcp_client_lwt" 2 | module Log = (val Logs.src_log src : Logs.LOG) 3 | 4 | module Make (Net : Mirage_net.S) = struct 5 | open Lwt.Infix 6 | 7 | type lease = Dhcp_wire.pkt 8 | 9 | type t = lease Lwt_stream.t 10 | 11 | let connect ?(renew = true) 12 | ?xid 13 | ?(requests : Dhcp_wire.option_code list option) net = 14 | (* listener needs to occasionally check to see whether the state has advanced, 15 | * and if not, start a new attempt at a lease transaction *) 16 | let sleep_interval = Duration.of_sec 4 in 17 | let header_size = Ethernet.Packet.sizeof_ethernet in 18 | let size = Net.mtu net + header_size in 19 | 20 | let xid = match xid with 21 | | None -> Randomconv.int32 Mirage_crypto_rng.generate 22 | | Some xid -> xid 23 | in 24 | let (client, dhcpdiscover) = Dhcp_client.create ?requests xid (Net.mac net) in 25 | let c = ref client in 26 | 27 | let rec do_renew c t = 28 | Mirage_sleep.ns @@ Duration.of_sec t >>= fun () -> 29 | match Dhcp_client.renew c with 30 | | `Noop -> Log.debug (fun f -> f "Can't renew this lease; won't try"); Lwt.return_unit 31 | | `Response (c, pkt) -> 32 | Log.debug (fun f -> f "attempted to renew lease: %a" Dhcp_client.pp c); 33 | Net.write net ~size (Dhcp_wire.pkt_into_buf pkt) >>= function 34 | | Error e -> 35 | Log.err (fun f -> f "Failed to write lease renewal request: %a" Net.pp_error e); 36 | Lwt.return_unit 37 | | Ok () -> 38 | do_renew c t (* ideally t would come from the new lease... *) 39 | in 40 | let rec get_lease push dhcpdiscover = 41 | Log.debug (fun f -> f "Sending DHCPDISCOVER..."); 42 | Net.write net ~size (Dhcp_wire.pkt_into_buf dhcpdiscover) >>= function 43 | | Error e -> 44 | Log.err (fun f -> f "Failed to write initial lease discovery request: %a" Net.pp_error e); 45 | Lwt.return_unit 46 | | Ok () -> 47 | Mirage_sleep.ns sleep_interval >>= fun () -> 48 | match Dhcp_client.lease !c with 49 | | Some _lease -> Lwt.return_unit 50 | | None -> 51 | let xid = Randomconv.int32 Mirage_crypto_rng.generate in 52 | let (client, dhcpdiscover) = Dhcp_client.create ?requests xid (Net.mac net) in 53 | c := client; 54 | Log.info (fun f -> f "Timeout expired without a usable lease! Starting over..."); 55 | Log.debug (fun f -> f "New lease attempt: %a" Dhcp_client.pp !c); 56 | get_lease push dhcpdiscover 57 | in 58 | let listen push () = 59 | Net.listen net ~header_size (fun buf -> 60 | match Dhcp_client.input !c buf with 61 | | `Noop -> 62 | Log.debug (fun f -> f "No action! State is %a" Dhcp_client.pp !c); 63 | Lwt.return_unit 64 | | `Response (s, action) -> begin 65 | Net.write net ~size (Dhcp_wire.pkt_into_buf action) >>= function 66 | | Error e -> 67 | Log.err (fun f -> f "Failed to write lease transaction response: %a" Net.pp_error e); 68 | Lwt.return_unit 69 | | Ok () -> 70 | Log.debug (fun f -> f "State advanced! Now %a" Dhcp_client.pp s); 71 | c := s; 72 | Lwt.return_unit 73 | end 74 | | `New_lease (s, l) -> 75 | let open Dhcp_wire in 76 | (* a lease is obtained! Note it, and replace the current listener *) 77 | Log.info (fun f -> f "Lease obtained! IP: %a, routers: %a" 78 | Ipaddr.V4.pp l.yiaddr 79 | (Fmt.list Ipaddr.V4.pp) (collect_routers l.options)); 80 | push @@ Some l; 81 | c := s; 82 | match renew with 83 | | true -> 84 | Mirage_sleep.ns @@ Duration.of_sec 1800 >>= fun () -> 85 | do_renew !c 1800 86 | | false -> 87 | push None; 88 | Lwt.return_unit 89 | ) 90 | in 91 | let lease_wrapper (push : Dhcp_wire.pkt option -> unit) () = 92 | Lwt.pick [ 93 | (listen push () >|= function 94 | | Error _ | Ok () -> push None (* if canceled, the stream should end *) 95 | ); 96 | get_lease push dhcpdiscover; 97 | ] 98 | in 99 | let (s, push) = Lwt_stream.create () in 100 | Lwt.async (fun () -> lease_wrapper push ()); 101 | Lwt.return s 102 | end 103 | -------------------------------------------------------------------------------- /client/lwt/dhcp_client_lwt.mli: -------------------------------------------------------------------------------- 1 | module Make (Net : Mirage_net.S) : sig 2 | type lease = Dhcp_wire.pkt 3 | 4 | type t = lease Lwt_stream.t 5 | 6 | val connect : ?renew:bool -> ?xid:Cstruct.uint32 -> 7 | ?requests:Dhcp_wire.option_code list -> Net.t -> t Lwt.t 8 | (** [connect renew ~xid requests net] starts a DHCP client communicating 9 | over the network interface [net]. The client will attempt to get a DHCP 10 | lease at least once, and will return any leases obtained in the stream 11 | returned by [connect]. If [renew] is true, which it is by default, 12 | the client will attempt to renew the lease according to the logic in 13 | RFC2131. If [renew] is false, the client will cancel its listener and end 14 | the stream once the first lease has been obtained. *) 15 | end 16 | -------------------------------------------------------------------------------- /client/lwt/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dhcp_client_lwt) 3 | (public_name charrua-client.lwt) 4 | (modules dhcp_client_lwt) 5 | (libraries charrua lwt charrua-client cstruct ipaddr mirage-sleep 6 | mirage-crypto-rng mirage-net duration fmt logs randomconv)) 7 | -------------------------------------------------------------------------------- /client/mirage/dhcp_client_mirage.ml: -------------------------------------------------------------------------------- 1 | let src = Logs.Src.create "dhcp_client_mirage" 2 | module Log = (val Logs.src_log src : Logs.LOG) 3 | 4 | let config_of_lease lease = 5 | let open Dhcp_wire in 6 | (* ipv4_config expects a single IP address and the information 7 | needed to construct a prefix. It can optionally use one router. *) 8 | let address = lease.yiaddr in 9 | match Dhcp_wire.find_subnet_mask lease.options with 10 | | None -> 11 | Log.info (fun f -> f "Lease obtained with no subnet mask; discarding it"); 12 | Log.debug (fun f -> f "Unusable lease: %a" Dhcp_wire.pp_pkt lease); 13 | None 14 | | Some subnet -> 15 | match Ipaddr.V4.Prefix.of_netmask ~netmask:subnet ~address with 16 | | Error `Msg msg -> 17 | Log.info (fun f -> f "Invalid address and netmask combination %s, discarding" msg); 18 | None 19 | | Ok network -> 20 | let valid_routers = Dhcp_wire.collect_routers lease.options in 21 | match valid_routers with 22 | | [] -> Some (network, None) 23 | | hd::_ -> Some (network, Some hd) 24 | 25 | module Make (Net : Mirage_net.S) = struct 26 | open Lwt.Infix 27 | 28 | type t = (Ipaddr.V4.Prefix.t * Ipaddr.V4.t option) Lwt_stream.t 29 | 30 | let connect ?(requests : Dhcp_wire.option_code list option) net = 31 | let module Lwt_client = Dhcp_client_lwt.Make(Net) in 32 | Lwt_client.connect ~renew:false ?requests net >>= fun lease_stream -> 33 | Lwt.return @@ Lwt_stream.filter_map config_of_lease lease_stream 34 | end 35 | -------------------------------------------------------------------------------- /client/mirage/dhcp_client_mirage.mli: -------------------------------------------------------------------------------- 1 | module Make (Network : Mirage_net.S) : sig 2 | type t = (Ipaddr.V4.Prefix.t * Ipaddr.V4.t option) Lwt_stream.t 3 | val connect : ?requests:Dhcp_wire.option_code list 4 | -> Network.t -> t Lwt.t 5 | (** [connect ?requests net] attempts to use [net] to obtain a valid 6 | DHCP lease containing the DHCP option codes listed in [request]. 7 | If [request] is not specified, [connect] uses the default values 8 | provided by the upstream Dhcp_client implementation, which are 9 | a small set useful in establishing ipv4 connectivity. 10 | [connect] does not time out; it will terminate on send/receive 11 | errors or when a lease is obtained. 12 | *) 13 | end 14 | -------------------------------------------------------------------------------- /client/mirage/dhcp_ipv4.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | module Make (Network : Mirage_net.S) (E : Ethernet.S) (Arp : Arp.S) = struct 4 | (* for now, just wrap a static ipv4 *) 5 | module DHCP = Dhcp_client_mirage.Make(Network) 6 | include Static_ipv4.Make(E)(Arp) 7 | let connect net ethernet arp = 8 | DHCP.connect net >>= fun dhcp -> 9 | Lwt_stream.last_new dhcp >>= fun (cidr, gateway) -> 10 | connect ~cidr ?gateway ethernet arp 11 | end 12 | -------------------------------------------------------------------------------- /client/mirage/dhcp_ipv4.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2010 Anil Madhavapeddy 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 | module Make (Network : Mirage_net.S) (E : Ethernet.S) (Arp : Arp.S) : sig 18 | include Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t and type prefix = Ipaddr.V4.Prefix.t 19 | val connect : Network.t -> E.t -> Arp.t -> t Lwt.t 20 | (** Connect to an ipv4 device using information from a DHCP lease. *) 21 | end 22 | -------------------------------------------------------------------------------- /client/mirage/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dhcp_client_mirage) 3 | (public_name charrua-client.mirage) 4 | (libraries charrua-client.lwt ipaddr mirage-mtime mirage-crypto-rng 5 | mirage-sleep mirage-net logs ethernet arp.mirage tcpip) 6 | (wrapped false)) 7 | -------------------------------------------------------------------------------- /docs/TODO_RFC7844.md: -------------------------------------------------------------------------------- 1 | * Add tests for the new options 2 | * Add a variable ``Anonymize`` in the configuration that will ignore other options when building the packet 3 | * Implement a MAC address randomization tool 4 | * Some higher level tool should enforce MAC address randomization when ``Anomize`` is used 5 | * Not related to RFC7844 but in order to behave like most of clients do (and to minimize leaking which is the client being used): 6 | * implement retransmisions and timeouts according to RFC2132 7 | * implement RENEW and REBIND (following RFC2132) 8 | 9 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.4) 2 | (name charrua) 3 | (using menhir 2.0) 4 | -------------------------------------------------------------------------------- /lib/dhcp_wire.mli: -------------------------------------------------------------------------------- 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 | (** {2 DHCP general data} *) 18 | 19 | val client_port : int 20 | (** DHCP client port [68] *) 21 | 22 | val server_port : int 23 | (** DHCP server port [67] *) 24 | 25 | (** {2 DHCP header opcodes} *) 26 | 27 | type op = 28 | | BOOTREQUEST 29 | | BOOTREPLY 30 | 31 | (** Conversions of {! op}s. *) 32 | 33 | val int_to_op : int -> op option 34 | 35 | val int_to_op_exn : int -> op (** @raise Invalid_argument if [v < 0 || v > 255] *) 36 | 37 | val op_to_int : op -> int 38 | 39 | val op_to_string : op -> string 40 | 41 | (** {2 DHCP message type option values} *) 42 | 43 | type msgtype = 44 | | DHCPDISCOVER 45 | | DHCPOFFER 46 | | DHCPREQUEST 47 | | DHCPDECLINE 48 | | DHCPACK 49 | | DHCPNAK 50 | | DHCPRELEASE 51 | | DHCPINFORM 52 | | DHCPFORCERENEW 53 | | DHCPLEASEQUERY 54 | | DHCPLEASEUNASSIGNED 55 | | DHCPLEASEUNKNOWN 56 | | DHCPLEASEACTIVE 57 | | DHCPBULKLEASEQUERY 58 | | DHCPLEASEQUERYDONE 59 | 60 | (** Conversions of {! msgtype}s. *) 61 | 62 | val msgtype_to_int : msgtype -> int 63 | val int_to_msgtype : int -> msgtype option 64 | val int_to_msgtype_exn : int -> msgtype 65 | (** @raise Invalid_argument if not a valid {! msgtype} value *) 66 | 67 | val msgtype_to_string : msgtype -> string 68 | 69 | (** {2 DHCP option codes (names only, for use in parameter requests)} *) 70 | 71 | type option_code = 72 | | PAD 73 | | SUBNET_MASK 74 | | TIME_OFFSET 75 | | ROUTERS 76 | | DNS_SERVERS 77 | | LOG_SERVERS 78 | | LPR_SERVERS 79 | | HOSTNAME 80 | | BOOTFILE_SIZE 81 | | DOMAIN_NAME 82 | | SWAP_SERVER 83 | | ROOT_PATH 84 | | EXTENSION_PATH 85 | | IPFORWARDING 86 | | NLSR 87 | | POLICY_FILTERS 88 | | MAX_DATAGRAM 89 | | DEFAULT_IP_TTL 90 | | INTERFACE_MTU 91 | | ALL_SUBNETS_LOCAL 92 | | BROADCAST_ADDR 93 | | PERFORM_ROUTER_DISC 94 | | ROUTER_SOL_ADDR 95 | | STATIC_ROUTES 96 | | TRAILER_ENCAPSULATION 97 | | ARP_CACHE_TIMO 98 | | ETHERNET_ENCAPSULATION 99 | | TCP_DEFAULT_TTL 100 | | TCP_KEEPALIVE_INTERVAL 101 | | NIS_DOMAIN 102 | | NIS_SERVERS 103 | | NTP_SERVERS 104 | | VENDOR_SPECIFIC 105 | | NETBIOS_NAME_SERVERS 106 | | NETBIOS_DATAGRAM_DISTRIB_SERVERS 107 | | NETBIOS_NODE 108 | | NETBIOS_SCOPE 109 | | XWINDOW_FONT_SERVERS 110 | | XWINDOW_DISPLAY_MANAGERS 111 | | REQUEST_IP 112 | | IP_LEASE_TIME 113 | | OPTION_OVERLOAD 114 | | MESSAGE_TYPE 115 | | SERVER_IDENTIFIER 116 | | PARAMETER_REQUESTS 117 | | MESSAGE 118 | | MAX_MESSAGE 119 | | RENEWAL_T1 120 | | REBINDING_T2 121 | | VENDOR_CLASS_ID 122 | | CLIENT_ID 123 | | NIS_PLUS_DOMAIN 124 | | NIS_PLUS_SERVERS 125 | | TFTP_SERVER_NAME 126 | | BOOTFILE_NAME 127 | | MOBILE_IP_HOME_AGENT 128 | | SMTP_SERVERS 129 | | POP3_SERVERS 130 | | NNTP_SERVERS 131 | | IRC_SERVERS 132 | | USER_CLASS 133 | | RAPID_COMMIT 134 | | CLIENT_FQDN 135 | | RELAY_AGENT_INFORMATION 136 | | CLIENT_SYSTEM 137 | | CLIENT_NDI 138 | | UUID_GUID 139 | | PCODE 140 | | TCODE 141 | | IPV6ONLY 142 | | SUBNET_SELECTION 143 | | DOMAIN_SEARCH 144 | | SIP_SERVERS 145 | | CLASSLESS_STATIC_ROUTE 146 | | VI_VENDOR_INFO 147 | | MISC_150 148 | | PRIVATE_CLASSLESS_STATIC_ROUTE 149 | | WEB_PROXY_AUTO_DISC 150 | | END 151 | | OTHER of int 152 | (** The type of a dhcp parameter request, these are all the values according to 153 | {{:https://www.iana.org/assignments/bootp-dhcp-parameters/bootp-dhcp-parameters.xhtml}iana} 154 | *) 155 | 156 | (** Conversions of DHCP {! option_code}s. *) 157 | 158 | val int_to_option_code : int -> option_code option 159 | val int_to_option_code_exn : int -> option_code 160 | val option_code_to_int : option_code -> int 161 | val option_code_to_string : option_code -> string 162 | 163 | (** {2 DHCP hardware type} *) 164 | 165 | type htype = 166 | | Ethernet_10mb 167 | | Other 168 | 169 | (** Conversions of {!htype}. *) 170 | 171 | val htype_to_string : htype -> string 172 | 173 | (** {2 DHCP header flags} *) 174 | 175 | type flags = 176 | | Broadcast 177 | | Unicast 178 | 179 | (** Conversions of {!flags}. *) 180 | 181 | val flags_to_string : flags -> string 182 | 183 | (** {2 DHCP Client identifier} *) 184 | 185 | type client_id = 186 | | Hwaddr of Macaddr.t 187 | | Id of int * string 188 | (** A client_id is usually a mac address from a {! dhcp_option}, 189 | but it can also be an opaque string. See {! client_id_of_pkt}. *) 190 | 191 | (** Conversions of {! client_id}. *) 192 | 193 | val client_id_to_string : client_id -> string 194 | val string_to_client_id : string -> client_id option 195 | 196 | (** {2 DHCP options} *) 197 | 198 | type dhcp_option = 199 | | Pad (* code 0 *) 200 | | Subnet_mask of Ipaddr.V4.t (* code 1 *) 201 | | Time_offset of int32 (* code 2 *) 202 | | Routers of Ipaddr.V4.t list (* code 3 *) 203 | | Dns_servers of Ipaddr.V4.t list (* code 6 *) 204 | | Log_servers of Ipaddr.V4.t list (* code 7 *) 205 | | Lpr_servers of Ipaddr.V4.t list (* code 9 *) 206 | | Hostname of string (* code 12 *) 207 | | Bootfile_size of int (* code 13 *) 208 | | Domain_name of string (* code 15 *) 209 | | Swap_server of Ipaddr.V4.t (* code 16 *) 210 | | Root_path of string (* code 17 *) 211 | | Extension_path of string (* code 18 *) 212 | | Ipforwarding of bool (* code 19 *) 213 | | Nlsr of bool (* code 20 *) 214 | | Policy_filters of Ipaddr.V4.Prefix.t list (* code 21 *) 215 | | Max_datagram of int (* code 22 *) 216 | | Default_ip_ttl of int (* code 23 *) 217 | | Interface_mtu of int (* code 26 *) 218 | | All_subnets_local of bool (* code 27 *) 219 | | Broadcast_addr of Ipaddr.V4.t (* code 28 *) 220 | | Perform_router_disc of bool (* code 31 *) 221 | | Router_sol_addr of Ipaddr.V4.t (* code 32 *) 222 | | Static_routes of (Ipaddr.V4.t * Ipaddr.V4.t) list (* code 33 *) 223 | | Trailer_encapsulation of bool (* code 34 *) 224 | | Arp_cache_timo of int32 (* code 35 *) 225 | | Ethernet_encapsulation of bool (* code 36 *) 226 | | Tcp_default_ttl of int (* code 37 *) 227 | | Tcp_keepalive_interval of int32 (* code 38 *) 228 | | Nis_domain of string (* code 40 *) 229 | | Nis_servers of Ipaddr.V4.t list (* code 41 *) 230 | | Ntp_servers of Ipaddr.V4.t list (* code 42 *) 231 | | Vendor_specific of string (* code 43 *) 232 | | Netbios_name_servers of Ipaddr.V4.t list(* code 44 *) 233 | | Netbios_datagram_distrib_servers of Ipaddr.V4.t list (* code 45 *) 234 | | Netbios_node of int (* code 46 *) 235 | | Netbios_scope of string (* code 47 *) 236 | | Xwindow_font_servers of Ipaddr.V4.t list(* code 48 *) 237 | | Xwindow_display_managers of Ipaddr.V4.t list (* code 49 *) 238 | | Request_ip of Ipaddr.V4.t (* code 50 *) 239 | | Ip_lease_time of int32 (* code 51 *) 240 | | Option_overload of int (* code 52 *) 241 | | Message_type of msgtype (* code 53 *) 242 | | Server_identifier of Ipaddr.V4.t (* code 54 *) 243 | | Parameter_requests of option_code list (* code 55 *) 244 | | Message of string (* code 56 *) 245 | | Max_message of int (* code 57 *) 246 | | Renewal_t1 of int32 (* code 58 *) 247 | | Rebinding_t2 of int32 (* code 59 *) 248 | | Vendor_class_id of string (* code 60 *) 249 | | Client_id of client_id (* code 61 *) 250 | | Nis_plus_domain of string (* code 64 *) 251 | | Nis_plus_servers of Ipaddr.V4.t list (* code 65 *) 252 | | Tftp_server_name of string (* code 66 *) 253 | | Bootfile_name of string (* code 67 *) 254 | | Mobile_ip_home_agent of Ipaddr.V4.t list(* code 68 *) 255 | | Smtp_servers of Ipaddr.V4.t list (* code 69 *) 256 | | Pop3_servers of Ipaddr.V4.t list (* code 70 *) 257 | | Nntp_servers of Ipaddr.V4.t list (* code 71 *) 258 | | Irc_servers of Ipaddr.V4.t list (* code 74 *) 259 | | User_class of string (* code 77 *) 260 | | Rapid_commit (* code 80 *) 261 | | Client_fqdn of string (* code 81 *) 262 | | Relay_agent_information of string (* code 82 *) 263 | | Client_system of string (* code 93 *) 264 | | Client_ndi of string (* code 94 *) 265 | | Uuid_guid of string (* code 97 *) 266 | | Pcode of string (* code 100 *) 267 | | Tcode of string (* code 101 *) 268 | | IPv6_only of int32 (* code 108 *) 269 | | Subnet_selection of Ipaddr.V4.t (* code 118 *) 270 | | Domain_search of string (* code 119 *) 271 | | Sip_servers of string (* code 120 *) 272 | | Classless_static_route of string (* code 121 *) (* XXX current, use better type *) 273 | | Vi_vendor_info of string (* code 125 *) 274 | | Misc_150 of string (* code 150 *) 275 | | Private_classless_static_route of string(* code 249 *) (* XXX current, use better type *) 276 | | Web_proxy_auto_disc of string (* code 252 *) 277 | | End (* code 255 *) 278 | | Other of int * string (* int * string *) 279 | (** Not all options are currently implemented. *) 280 | 281 | (** Conversions of {! dhcp_option}. *) 282 | 283 | val dhcp_option_to_string : dhcp_option -> string 284 | 285 | val buf_of_options : Cstruct.t -> dhcp_option list -> Cstruct.t 286 | val options_of_buf : Cstruct.t -> int -> dhcp_option list 287 | 288 | val find_option : (dhcp_option -> 'b option) -> dhcp_option list -> 'b option 289 | (** [find_option f l] finds the first option where [f] evaluates to [Some] value 290 | on list [l] *) 291 | 292 | val collect_options : ('a -> 'b list option) -> 'a list -> 'b list 293 | (** [collect_options f l] collects all options where [f] evaluates to [Some] 294 | value on list [l], this is useful for list options like [Routers], if 295 | multiple list options are found, the resulting list is flattened. *) 296 | 297 | val collect_dns_servers : dhcp_option list -> Ipaddr.V4.t list 298 | val collect_irc_servers : dhcp_option list -> Ipaddr.V4.t list 299 | val collect_log_servers : dhcp_option list -> Ipaddr.V4.t list 300 | val collect_lpr_servers : dhcp_option list -> Ipaddr.V4.t list 301 | val collect_netbios_datagram_distrib_servers : dhcp_option list -> Ipaddr.V4.t list 302 | val collect_netbios_name_servers : dhcp_option list -> Ipaddr.V4.t list 303 | val collect_nis_plus_servers : dhcp_option list -> Ipaddr.V4.t list 304 | val collect_nis_servers : dhcp_option list -> Ipaddr.V4.t list 305 | val collect_ntp_servers : dhcp_option list -> Ipaddr.V4.t list 306 | val find_parameter_requests : dhcp_option list -> option_code list option 307 | val collect_policy_filters : dhcp_option list -> Ipaddr.V4.Prefix.t list 308 | val collect_routers : dhcp_option list -> Ipaddr.V4.t list 309 | val collect_static_routes : dhcp_option list -> (Ipaddr.V4.t * Ipaddr.V4.t) list 310 | val collect_xwindow_display_managers : dhcp_option list -> Ipaddr.V4.t list 311 | val collect_xwindow_font_servers : dhcp_option list -> Ipaddr.V4.t list 312 | val find_all_subnets_local : dhcp_option list -> bool option 313 | val find_arp_cache_timo : dhcp_option list -> int32 option 314 | val find_bootfile_name : dhcp_option list -> string option 315 | val find_bootfile_size : dhcp_option list -> int option 316 | val find_broadcast_addr : dhcp_option list -> Ipaddr.V4.t option 317 | val find_classless_static_route : dhcp_option list -> string option 318 | val find_client_fqdn : dhcp_option list -> string option 319 | val find_client_id : dhcp_option list -> client_id option 320 | val find_client_ndi : dhcp_option list -> string option 321 | val find_client_system : dhcp_option list -> string option 322 | val find_default_ip_ttl : dhcp_option list -> int option 323 | val find_domain_name : dhcp_option list -> string option 324 | val find_domain_search : dhcp_option list -> string option 325 | val find_ethernet_encapsulation : dhcp_option list -> bool option 326 | val find_extension_path : dhcp_option list -> string option 327 | val find_hostname : dhcp_option list -> string option 328 | val find_interface_mtu : dhcp_option list -> int option 329 | val find_ip_lease_time : dhcp_option list -> int32 option 330 | val find_ipforwarding : dhcp_option list -> bool option 331 | val find_max_datagram : dhcp_option list -> int option 332 | val find_max_message : dhcp_option list -> int option 333 | val find_message : dhcp_option list -> string option 334 | val find_message_type : dhcp_option list -> msgtype option 335 | val find_misc_150 : dhcp_option list -> string option 336 | val collect_mobile_ip_home_agent : dhcp_option list -> Ipaddr.V4.t list 337 | val find_netbios_node : dhcp_option list -> int option 338 | val find_netbios_scope : dhcp_option list -> string option 339 | val find_nis_domain : dhcp_option list -> string option 340 | val find_nis_plus_domain : dhcp_option list -> string option 341 | val find_nlsr : dhcp_option list -> bool option 342 | val collect_nntp_servers : dhcp_option list -> Ipaddr.V4.t list 343 | val find_option_overload : dhcp_option list -> int option 344 | val find_pcode : dhcp_option list -> string option 345 | val find_perform_router_disc : dhcp_option list -> bool option 346 | val collect_pop3_servers : dhcp_option list -> Ipaddr.V4.t list 347 | val find_rapid_commit : dhcp_option list -> dhcp_option option 348 | val find_rebinding_t2 : dhcp_option list -> int32 option 349 | val find_relay_agent_information : dhcp_option list -> string option 350 | val find_renewal_t1 : dhcp_option list -> int32 option 351 | val find_request_ip : dhcp_option list -> Ipaddr.V4.t option 352 | val find_root_path : dhcp_option list -> string option 353 | val find_router_sol_addr : dhcp_option list -> Ipaddr.V4.t option 354 | val find_server_identifier : dhcp_option list -> Ipaddr.V4.t option 355 | val find_sip_servers : dhcp_option list -> string option 356 | val collect_smtp_servers : dhcp_option list -> Ipaddr.V4.t list 357 | val find_subnet_mask : dhcp_option list -> Ipaddr.V4.t option 358 | val find_subnet_selection : dhcp_option list -> Ipaddr.V4.t option 359 | val find_swap_server : dhcp_option list -> Ipaddr.V4.t option 360 | val find_tcode : dhcp_option list -> string option 361 | val find_ipv6only : dhcp_option list -> int32 option 362 | val find_tcp_default_ttl : dhcp_option list -> int option 363 | val find_tcp_keepalive_interval : dhcp_option list -> int32 option 364 | val find_tftp_server_name : dhcp_option list -> string option 365 | val find_time_offset : dhcp_option list -> int32 option 366 | val find_trailer_encapsulation : dhcp_option list -> bool option 367 | val find_user_class : dhcp_option list -> string option 368 | val find_uuid_guid : dhcp_option list -> string option 369 | val find_vendor_class_id : dhcp_option list -> string option 370 | val find_vendor_specific : dhcp_option list -> string option 371 | val find_vi_vendor_info : dhcp_option list -> string option 372 | val find_web_proxy_auto_disc : dhcp_option list -> string option 373 | val find_private_classless_static_route : dhcp_option list -> string option 374 | val find_other : int -> dhcp_option list -> (int * string) option 375 | val collect_other : int -> dhcp_option list -> (int * string) list 376 | 377 | (** {2 DHCP Packet - fixed-length fields, plus a variable-length list of options} *) 378 | 379 | type pkt = { 380 | srcmac : Macaddr.t; 381 | dstmac : Macaddr.t; 382 | srcip : Ipaddr.V4.t; 383 | dstip : Ipaddr.V4.t; 384 | srcport : int; 385 | dstport : int; 386 | op : op; 387 | htype : htype; 388 | hlen : int; 389 | hops : int; 390 | xid : int32; 391 | secs : int; 392 | flags : flags; 393 | ciaddr : Ipaddr.V4.t; 394 | yiaddr : Ipaddr.V4.t; 395 | siaddr : Ipaddr.V4.t; 396 | giaddr : Ipaddr.V4.t; 397 | chaddr : Macaddr.t; 398 | sname : string; 399 | file : string; 400 | options : dhcp_option list; 401 | } 402 | 403 | (** Conversions for {! pkt}. *) 404 | 405 | val pkt_of_buf : Cstruct.t -> int -> (pkt, string) result 406 | val buf_of_pkt : pkt -> Cstruct.t 407 | val pkt_into_buf : pkt -> Cstruct.t -> int 408 | 409 | val pp_pkt : pkt Fmt.t 410 | 411 | val client_id_of_pkt : pkt -> client_id 412 | 413 | (** Helpers. *) 414 | 415 | val is_dhcp : Cstruct.t -> int -> bool 416 | (** [is_dhcp buf len] is true if [buf] is an Ethernet frame containing an IPv4 417 | header, UDP header, and DHCP packet. *) 418 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dhcp_wire) 3 | (public_name charrua) 4 | (libraries cstruct ethernet tcpip.ipv4 tcpip.udp ipaddr macaddr fmt ohex)) 5 | -------------------------------------------------------------------------------- /sample/dhcpd.conf: -------------------------------------------------------------------------------- 1 | # 2 | # DHCP server options. 3 | # See dhcpd.conf(5) and dhcpd(8) for more information. 4 | # 5 | 6 | # Network: 192.168.1.0/255.255.255.0 7 | # Domain name: charrua 8 | # Name servers: 192.168.1.1 9 | # Default router: 192.168.1.1 10 | # Addresses: 192.168.1.70 - 192.168.1.100 11 | # 12 | option domain-name "charrua"; 13 | 14 | subnet 192.168.1.0 netmask 255.255.255.0 { 15 | option routers 192.168.1.1; 16 | option domain-name-servers 192.168.1.1; 17 | 18 | range 192.168.1.70 192.168.1.100; 19 | 20 | host montevideo { 21 | hardware ethernet 00:1d:72:80:e9:10; 22 | fixed-address 192.168.1.10; 23 | } 24 | 25 | host garra { 26 | hardware ethernet 00:1d:e0:06:74:11; 27 | fixed-address 192.168.1.11; 28 | } 29 | 30 | } 31 | 32 | # Network: 192.168.2.0/255.255.255.0 33 | # Domain name: minuanes 34 | # Name servers: 192.168.2.1 35 | # Default router: 192.168.2.1 36 | # Addresses: 192.168.2.50 - 192.168.2.100 37 | # 38 | 39 | 40 | #subnet 192.168.2.0 netmask 255.255.255.0 { 41 | # option routers 192.168.2.1; 42 | # option domain-name-servers 192.168.2.1; 43 | # range 192.168.2.50 192.168.2.100; 44 | #} 45 | -------------------------------------------------------------------------------- /server/ast.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 | type host = { 18 | hostname : string; 19 | options : Dhcp_wire.dhcp_option list; 20 | fixed_addr : Ipaddr.V4.t option; 21 | hw_addr : Macaddr.t; 22 | } 23 | 24 | type subnet = { 25 | network : Ipaddr.V4.Prefix.t; 26 | range : (Ipaddr.V4.t * Ipaddr.V4.t) option; 27 | options : Dhcp_wire.dhcp_option list; 28 | hosts : host list; 29 | default_lease_time : int32 option; 30 | max_lease_time : int32 option; 31 | } 32 | 33 | type t = { 34 | subnets : subnet list; 35 | options : Dhcp_wire.dhcp_option list; 36 | default_lease_time : int32; 37 | max_lease_time : int32; 38 | } 39 | -------------------------------------------------------------------------------- /server/dhcp_lexer.mll: -------------------------------------------------------------------------------- 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 | { 18 | open Lexing 19 | open Dhcp_parser 20 | 21 | let choke _lexbuf s = 22 | invalid_arg s 23 | 24 | } 25 | let white = [' ' '\t']+ 26 | let newline = '\r' | '\n' | "\r\n" 27 | let comment = '#'+ 28 | (* A naive regex, we'll double check later with Ipaddr module *) 29 | let ip = ['0' - '9']+ '.' ['0' - '9']+ '.' ['0' - '9']+ '.' ['0' - '9']+ 30 | (* No repetition in ocamllex :-( *) 31 | let macaddr = ['a' - 'f' 'A' - 'F' '0' - '9'] ['a' - 'f' 'A' - 'F' '0' - '9'] ':' 32 | ['a' - 'f' 'A' - 'F' '0' - '9'] ['a' - 'f' 'A' - 'F' '0' - '9'] ':' 33 | ['a' - 'f' 'A' - 'F' '0' - '9'] ['a' - 'f' 'A' - 'F' '0' - '9'] ':' 34 | ['a' - 'f' 'A' - 'F' '0' - '9'] ['a' - 'f' 'A' - 'F' '0' - '9'] ':' 35 | ['a' - 'f' 'A' - 'F' '0' - '9'] ['a' - 'f' 'A' - 'F' '0' - '9'] ':' 36 | ['a' - 'f' 'A' - 'F' '0' - '9'] ['a' - 'f' 'A' - 'F' '0' - '9'] 37 | let word = ['a'-'z' 'A'-'Z' '0'-'9' '_' '-'] ['a'-'z' 'A'-'Z' '0'-'9' '_' '-']* 38 | let integer = ['0' - '9']+ 39 | 40 | rule lex = parse 41 | | white { lex lexbuf } 42 | | newline { new_line lexbuf; lex lexbuf } 43 | | ip as ip { IP(Ipaddr.V4.of_string_exn ip) } 44 | | macaddr as mac { MACADDR(Macaddr.of_string_exn mac) } 45 | | '"' { lex_string (Buffer.create 17) lexbuf } 46 | | ',' { COMMA } 47 | | ';' { SCOLON } 48 | | '{' { LBRACKET } 49 | | '}' { RBRACKET } 50 | | "default-lease-time" { DEFAULTLEASETIME } 51 | | "domain-name" { DOMAINNAME } 52 | | "domain-name-servers" { DOMAINNAMESERVERS } 53 | | "ethernet" { ETHERNET } 54 | | "fixed-address" { FIXEDADDRESS } 55 | | "hardware" { HARDWARE } 56 | | "host" { HOST } 57 | | "max-lease-time" { MAXLEASETIME } 58 | | "netmask" { NETMASK } 59 | | "option" { OPTION } 60 | | "range" { RANGE } 61 | | "routers" { ROUTERS } 62 | | "subnet" { SUBNET } 63 | | comment { lex_comment lexbuf; lex lexbuf } 64 | | integer as integer { INTEGER(int_of_string integer) } 65 | | word as word { WORD(word) } 66 | | _ { choke lexbuf "Invalid syntax" } 67 | | eof { EOF } 68 | 69 | and lex_comment = parse 70 | | eof { () } 71 | | newline { new_line lexbuf } 72 | | _ { lex_comment lexbuf } 73 | 74 | and lex_string buf = parse 75 | | '"' { STRING (Buffer.contents buf) } 76 | | '\\' '/' { Buffer.add_char buf '/'; lex_string buf lexbuf } 77 | | '\\' '\\' { Buffer.add_char buf '\\'; lex_string buf lexbuf } 78 | | '\\' 'b' { Buffer.add_char buf '\b'; lex_string buf lexbuf } 79 | | '\\' 'f' { Buffer.add_char buf '\012'; lex_string buf lexbuf } 80 | | '\\' 'n' { Buffer.add_char buf '\n'; lex_string buf lexbuf } 81 | | '\\' 'r' { Buffer.add_char buf '\r'; lex_string buf lexbuf } 82 | | '\\' 't' { Buffer.add_char buf '\t'; lex_string buf lexbuf } 83 | | [^ '"' '\\']+ 84 | { Buffer.add_string buf (Lexing.lexeme lexbuf); 85 | lex_string buf lexbuf 86 | } 87 | | _ { choke lexbuf "Illegal string character" } 88 | | eof { choke lexbuf "String is not terminated" } 89 | -------------------------------------------------------------------------------- /server/dhcp_parser.mly: -------------------------------------------------------------------------------- 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 | %{ 18 | type statement = 19 | | Range of Ipaddr.V4.t * Ipaddr.V4.t 20 | | Dhcp_option of Dhcp_wire.dhcp_option 21 | | Hw_eth of Macaddr.t 22 | | Fixed_addr of Ipaddr.V4.t 23 | | Default_lease_time of int32 24 | | Max_lease_time of int32 25 | 26 | let choke s = invalid_arg s 27 | 28 | %} 29 | 30 | %token IP 31 | %token MACADDR 32 | %token STRING 33 | %token COMMA 34 | %token DEFAULTLEASETIME 35 | %token DOMAINNAME 36 | %token DOMAINNAMESERVERS 37 | %token EOF 38 | %token ETHERNET 39 | %token FIXEDADDRESS 40 | %token HARDWARE 41 | %token HOST 42 | %token INTEGER 43 | %token LBRACKET 44 | %token MAXLEASETIME 45 | %token NETMASK 46 | %token OPTION 47 | %token RANGE 48 | %token RBRACKET 49 | %token ROUTERS 50 | %token SCOLON 51 | %token SUBNET 52 | %token WORD 53 | 54 | %start main 55 | %% 56 | 57 | main: 58 | | s = statement; ss = statements; sub = subnet; subs = subnets; EOF { 59 | let statements = s :: ss in 60 | let subnets = sub :: subs in 61 | (* Now extract the options from the statements *) 62 | let () = List.iter (function 63 | | Dhcp_option _o -> () 64 | | Default_lease_time _t -> () 65 | | Max_lease_time _t -> () 66 | | _ -> choke "Only dhcp options and default|max-lease-time \ 67 | are allowed in the global section") 68 | statements 69 | in 70 | let options = Util.filter_map (function 71 | | Dhcp_option o -> Some o 72 | | _ -> None) 73 | statements 74 | in 75 | let default_lease_time = 76 | match (Util.find_map (function 77 | | Default_lease_time t -> Some t 78 | | _ -> None) 79 | statements) 80 | with | Some time -> time 81 | | None -> Int32.of_int (60 * 60 * 60) (* 1h *) 82 | in 83 | let max_lease_time = 84 | match (Util.find_map (function 85 | | Max_lease_time t -> Some t 86 | | _ -> None) 87 | statements) 88 | with | Some time -> time 89 | | None -> Int32.of_int (60 * 60 * 60 * 24) (* 24h *) 90 | in 91 | { Ast.subnets; options; default_lease_time; max_lease_time } 92 | } 93 | 94 | ips: 95 | | ip = IP { [ip] } 96 | | ip = IP; COMMA; ips = ips { ip :: ips } 97 | 98 | statements: 99 | | (* empty *) { [] } 100 | | s = statement; ss = statements { s :: (List.rev ss) } 101 | 102 | statement: 103 | | OPTION; DOMAINNAME; v = STRING; SCOLON { Dhcp_option (Dhcp_wire.Domain_name v)} 104 | | OPTION; DOMAINNAMESERVERS; ips = ips; SCOLON { Dhcp_option (Dhcp_wire.Dns_servers ips) } 105 | | OPTION; ROUTERS; ips = ips; SCOLON { Dhcp_option (Dhcp_wire.Routers ips) } 106 | | RANGE; v1 = IP; v2 = IP; SCOLON { 107 | if Int32.compare (Ipaddr.V4.to_int32 v1) (Ipaddr.V4.to_int32 v2) >= 0 then 108 | choke "Invalid `range` statement, must be `low high`"; 109 | Range (v1, v2) 110 | } 111 | | HARDWARE; ETHERNET; mac = MACADDR; SCOLON { Hw_eth mac } 112 | | FIXEDADDRESS; v = IP; SCOLON { Fixed_addr v } 113 | | DEFAULTLEASETIME; v = INTEGER; SCOLON { Default_lease_time (Int32.of_int v) } 114 | | MAXLEASETIME; v = INTEGER; SCOLON { Max_lease_time (Int32.of_int v) } 115 | 116 | subnets: 117 | | (* empty *) { [] } 118 | | sub = subnet; subs = subnets { sub :: (List.rev subs) } 119 | 120 | subnet: 121 | | SUBNET; address = IP; NETMASK; netmask = IP; LBRACKET; 122 | statements = statements; hosts = hosts; RBRACKET { 123 | let network = 124 | try Ipaddr.V4.Prefix.of_netmask_exn ~netmask ~address with 125 | Ipaddr.Parse_error (a, b) -> choke (a ^ ": " ^ b) 126 | in 127 | (* Catch statements that don't make sense in a subnet *) 128 | let () = List.iter (function 129 | | Hw_eth _ | Fixed_addr _ -> 130 | choke "`hardware` and `fixed-address` belong to `host` context, not subnet" 131 | | _ -> ()) 132 | statements 133 | in 134 | (* First find the range statement, XXX ignoring if multiple *) 135 | let range = Util.find_map (function 136 | | Range (v1, v2) -> Some (v1, v2) 137 | | _ -> None) 138 | statements |> (function 139 | | Some (v1, v2) -> (v1, v2) 140 | | None -> choke ("Missing `range` statement for subnet " ^ 141 | (Ipaddr.V4.to_string address))) 142 | in 143 | let options = Util.filter_map (function 144 | | Dhcp_option o -> Some o 145 | | _ -> None) 146 | statements 147 | in 148 | let default_lease_time = 149 | (Util.find_map (function Default_lease_time t -> Some t | _ -> None) 150 | statements) 151 | in 152 | let max_lease_time = 153 | (Util.find_map (function Max_lease_time t -> Some t | _ -> None) 154 | statements) 155 | in 156 | { Ast.network; range = Some range; options; hosts; default_lease_time; max_lease_time } 157 | } 158 | 159 | hosts: 160 | | (* empty *) { [] } 161 | | host = host; hosts = hosts { host :: hosts } 162 | 163 | host: 164 | | HOST; hostname = WORD; LBRACKET; statements = statements; RBRACKET { 165 | let () = List.iter (function 166 | | Range _ -> choke "Range is invalid in host context" 167 | | _ -> ()) 168 | statements 169 | in 170 | let options = Util.filter_map (function 171 | | Dhcp_option o -> Some o 172 | | _ -> None) 173 | statements 174 | in 175 | let fixed_addr = Util.find_map (function 176 | | Fixed_addr fa -> Some fa 177 | | _ -> None) 178 | statements 179 | in 180 | let hw_addr = Util.find_map (function 181 | | Hw_eth he -> Some he 182 | | _ -> None) 183 | statements 184 | in 185 | let hw_addr = 186 | Util.some_or_f hw_addr 187 | (fun () -> choke "Missing hardware ethernet statement." ) 188 | in 189 | { Ast.hostname; options; fixed_addr; hw_addr } 190 | } 191 | -------------------------------------------------------------------------------- /server/dhcp_server.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015-2017 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 | module Config = struct 18 | type host = { 19 | hostname : string; 20 | options : Dhcp_wire.dhcp_option list; 21 | fixed_addr : Ipaddr.V4.t option; 22 | hw_addr : Macaddr.t; 23 | } 24 | 25 | type t = { 26 | options : Dhcp_wire.dhcp_option list; 27 | hostname : string; 28 | default_lease_time : int32; 29 | max_lease_time : int32; 30 | ip_addr : Ipaddr.V4.t; 31 | mac_addr : Macaddr.t; 32 | network : Ipaddr.V4.Prefix.t; 33 | range : (Ipaddr.V4.t * Ipaddr.V4.t) option; 34 | hosts : host list; 35 | } 36 | 37 | let t1_time_ratio = 0.5 38 | let t2_time_ratio = 0.8 39 | 40 | let lease_time_good config time = time <= config.max_lease_time 41 | 42 | let sanity_check config = 43 | (* Check if fixed addresses make sense *) 44 | List.iter (fun host -> 45 | match host.fixed_addr with 46 | | None -> () 47 | | Some addr -> 48 | if not (Ipaddr.V4.Prefix.mem addr config.network) then 49 | invalid_arg (Printf.sprintf "Fixed address %s does not \ 50 | belong to subnet %s" 51 | (Ipaddr.V4.to_string addr) 52 | (Ipaddr.V4.Prefix.to_string config.network)) 53 | else match config.range with 54 | | None -> () 55 | | Some range -> 56 | if Util.addr_in_range addr range then 57 | let low = fst range in 58 | let high = snd range in 59 | invalid_arg (Printf.sprintf "Fixed address %s must be \ 60 | outside of range %s:%s" 61 | (Ipaddr.V4.to_string addr) 62 | (Ipaddr.V4.to_string low) 63 | (Ipaddr.V4.to_string high))) 64 | config.hosts; 65 | config 66 | 67 | let make 68 | ?(hostname = "charrua-dhcp-server") 69 | ?(default_lease_time = 60 * 60 * 2) (* 2 hours *) 70 | ?(max_lease_time = 60 * 60 * 24) (* 24 hours *) 71 | ?(hosts = []) 72 | ~addr_tuple 73 | ~network 74 | ~range 75 | ~options 76 | () = 77 | 78 | let open Dhcp_wire in 79 | (* Try to ensure the user doesn't pass bad options *) 80 | let () = 81 | List.iter (function 82 | | Subnet_mask _ | Renewal_t1 _ | Rebinding_t2 _ | Client_id _ 83 | | Ip_lease_time _ | End | Pad | Request_ip _ | Parameter_requests _ 84 | as option -> 85 | invalid_arg (Printf.sprintf "option %s is not allowed" 86 | (dhcp_option_to_string option)) 87 | | _ -> ()) 88 | options 89 | in 90 | (* Prepend a Subnet_mask, since we can always infer that from the network, 91 | the user doesn't need to specify, it must always come first in case there 92 | is a Router option later on RFC2132 3.3 *) 93 | let options = Subnet_mask (Ipaddr.V4.Prefix.netmask network) :: options in 94 | let ip_addr = fst addr_tuple in 95 | let mac_addr = snd addr_tuple in 96 | sanity_check { 97 | options; 98 | hostname; 99 | default_lease_time = Int32.of_int default_lease_time; 100 | max_lease_time = Int32.of_int max_lease_time; 101 | ip_addr; 102 | mac_addr; 103 | network; 104 | range; 105 | hosts; 106 | } 107 | 108 | let config_of_ast addr_tuple (ast : Ast.t) = 109 | let ip_addr = fst addr_tuple in 110 | let mac_addr = snd addr_tuple in 111 | let subnets = ast.Ast.subnets in 112 | let subnet = List.find 113 | (fun s -> Ipaddr.V4.Prefix.mem ip_addr s.Ast.network) 114 | subnets 115 | in 116 | let hosts = List.map (fun h -> 117 | { hostname = h.Ast.hostname; 118 | options = h.Ast.options; 119 | fixed_addr = h.Ast.fixed_addr; 120 | hw_addr = h.Ast.hw_addr; 121 | }) subnet.Ast.hosts 122 | in 123 | let default_lease_time = Util.some_or_default 124 | subnet.Ast.default_lease_time ast.Ast.default_lease_time 125 | in 126 | let max_lease_time = Util.some_or_default 127 | subnet.Ast.max_lease_time ast.Ast.max_lease_time 128 | in 129 | let network = subnet.Ast.network in 130 | 131 | (* Prepend a Subnet_mask, since we can always infer that from the network, 132 | the user doesn't need to specify, it must always come first in case there 133 | is a Router option later on, RFC2132 3.3. subnet.Ast.options must come 134 | first, this way we make sure we hit the more specific option when 135 | searching for a single entry. *) 136 | let options = Dhcp_wire.Subnet_mask (Ipaddr.V4.Prefix.netmask network) :: 137 | (subnet.Ast.options @ ast.Ast.options) 138 | in 139 | sanity_check { 140 | options; 141 | hostname = "charrua-dhcp-server"; (* XXX Implement server-name option. *) 142 | default_lease_time; 143 | max_lease_time; 144 | ip_addr; 145 | mac_addr; 146 | network = subnet.Ast.network; 147 | range = subnet.Ast.range; 148 | hosts = hosts; 149 | } 150 | 151 | let parse configtxt addr_tuple = 152 | let choke lex s = 153 | let open Lexing in 154 | let pos = lex.lex_curr_p in 155 | let str = Printf.sprintf "%s at line %d around `%s`" 156 | s pos.pos_lnum (Lexing.lexeme lex) 157 | in 158 | invalid_arg str 159 | in 160 | let lex = Lexing.from_string configtxt in 161 | let ast = 162 | try Dhcp_parser.main Dhcp_lexer.lex lex with 163 | | Dhcp_parser.Error -> choke lex "Parser Error" 164 | | Invalid_argument e -> choke lex e 165 | in 166 | config_of_ast addr_tuple ast 167 | 168 | end 169 | 170 | module Lease = struct 171 | module Client_id = struct 172 | open Dhcp_wire 173 | 174 | type t = client_id 175 | 176 | let compare a b = 177 | match a, b with 178 | | Hwaddr maca, Hwaddr macb -> Macaddr.compare maca macb 179 | | Id (htype, ida), Id (htype', idb) -> 180 | begin match compare htype htype' with 181 | | 0 -> String.compare ida idb 182 | | x -> x 183 | end 184 | | Id _, Hwaddr _ -> -1 185 | | Hwaddr _, Id _ -> 1 186 | end 187 | 188 | module Addr_map = Map.Make(Ipaddr.V4) 189 | module Lease_map = Map.Make(Client_id) 190 | 191 | (* Lease (dhcp bindings) operations *) 192 | type t = { 193 | tm_start : int32; 194 | tm_end : int32; 195 | addr : Ipaddr.V4.t; 196 | client_id : Dhcp_wire.client_id; 197 | } 198 | 199 | let to_string lease = 200 | "start " ^ Int32.to_string lease.tm_start ^ 201 | " end " ^ Int32.to_string lease.tm_end ^ 202 | " addr " ^ Ipaddr.V4.to_string lease.addr ^ 203 | " client id " ^ Dhcp_wire.client_id_to_string lease.client_id 204 | 205 | (* Database, collection of leases *) 206 | type database = { 207 | lease_map : t Lease_map.t; 208 | addr_map : Client_id.t Addr_map.t; 209 | } 210 | 211 | let update_db lease_map addr_map = 212 | { lease_map; addr_map } 213 | 214 | let make_db () = update_db Lease_map.empty Addr_map.empty 215 | 216 | let db_to_list db = Lease_map.fold (fun _id lease l -> lease :: l) db.lease_map [] 217 | 218 | let db_equal db1 db2 = 219 | (Lease_map.equal (fun l1 l2 -> l1 = l2) db1.lease_map db2.lease_map) 220 | && 221 | (Addr_map.equal (fun a1 a2 -> a1 = a2) db1.addr_map db2.addr_map) 222 | 223 | let make client_id addr ~duration ~now = 224 | let tm_start = now in 225 | let tm_end = Int32.add tm_start duration in 226 | { tm_start; tm_end; addr; client_id } 227 | 228 | let make_fixed mac addr ~duration ~now = 229 | make (Dhcp_wire.Hwaddr mac) addr ~duration ~now 230 | 231 | let timeleft lease ~now = 232 | let left = Int32.sub lease.tm_end now in 233 | if left < Int32.zero then Int32.zero else left 234 | 235 | let timeleft_exn lease ~now = 236 | let left = timeleft lease ~now in 237 | if left = Int32.zero then invalid_arg "No time left for lease" else left 238 | 239 | let timeleft3 lease t1_ratio t2_ratio ~now = 240 | let left = Int32.to_float (timeleft lease ~now) in 241 | (Int32.of_float left, 242 | Int32.of_float (left *. t1_ratio), 243 | Int32.of_float (left *. t2_ratio)) 244 | 245 | let extend lease ~now = 246 | let original = Int32.sub lease.tm_end lease.tm_start in 247 | make lease.client_id lease.addr ~duration:original ~now 248 | 249 | let expired lease ~now = timeleft lease ~now = Int32.zero 250 | 251 | let sanity_check db = 252 | assert (Addr_map.cardinal db.addr_map = Lease_map.cardinal db.lease_map); 253 | Lease_map.iter (fun client_id lease -> 254 | assert (client_id = (Addr_map.find lease.addr db.addr_map))) 255 | db.lease_map; 256 | Addr_map.iter (fun addr client_id -> 257 | let lease = Lease_map.find client_id db.lease_map in 258 | assert (lease.client_id = client_id); 259 | assert (lease.addr = addr)) 260 | db.addr_map; 261 | db 262 | 263 | let garbage_collect db ~now = 264 | let lease_map = Lease_map.filter 265 | (fun _ lease -> not (expired lease ~now)) 266 | db.lease_map 267 | in 268 | let addr_map = Addr_map.filter 269 | (fun _ client_id -> Lease_map.mem client_id lease_map) 270 | db.addr_map 271 | in 272 | update_db lease_map addr_map |> sanity_check 273 | 274 | let lease_of_client_id client_id db = Util.find_some @@ fun () -> 275 | Lease_map.find client_id db.lease_map 276 | 277 | let lease_of_addr addr db = Util.find_some @@ fun () -> 278 | Addr_map.find addr db.addr_map 279 | 280 | let remove lease db = 281 | update_db 282 | (Lease_map.remove lease.client_id db.lease_map) 283 | (Addr_map.remove lease.addr db.addr_map) 284 | 285 | let replace lease db = 286 | (* remove possible old one first *) 287 | let db = 288 | match Lease_map.find_opt lease.client_id db.lease_map with 289 | | None -> db 290 | | Some old_lease -> remove old_lease db 291 | in 292 | update_db 293 | (Lease_map.add lease.client_id lease db.lease_map) 294 | (Addr_map.add lease.addr lease.client_id db.addr_map) 295 | 296 | let lease_to_string l = 297 | Int32.to_string l.tm_start ^ "," ^ Int32.to_string l.tm_end ^ "," ^ 298 | Ipaddr.V4.to_string l.addr ^ "," ^ Dhcp_wire.client_id_to_string l.client_id 299 | 300 | let lease_of_string s = 301 | match String.split_on_char ',' s with 302 | | tm_start :: tm_end :: addr :: client_id -> 303 | (match Int32.of_string_opt tm_start, Int32.of_string_opt tm_end, Ipaddr.V4.of_string addr, Dhcp_wire.string_to_client_id (String.concat "," client_id) with 304 | | Some tm_start, Some tm_end, Ok addr, Some client_id -> 305 | Some { tm_start ; tm_end ; addr ; client_id } 306 | | _ -> None) 307 | | _ -> None 308 | 309 | let db_to_string db = 310 | Lease_map.bindings db.lease_map |> 311 | List.map (fun (cid, lease) -> 312 | Dhcp_wire.client_id_to_string cid ^ ":" ^ lease_to_string lease 313 | ) |> String.concat "\n" 314 | 315 | let db_of_string s = 316 | let entries = String.split_on_char '\n' s in 317 | let things = 318 | List.fold_left (fun acc entry -> 319 | match acc with 320 | | None -> None 321 | | Some acc -> 322 | (match String.split_on_char ':' entry with 323 | | client_id :: lease -> 324 | (match Dhcp_wire.string_to_client_id client_id, lease_of_string (String.concat ":" lease) with 325 | | Some cid, Some lease -> 326 | Some ((cid, lease) :: acc) 327 | | _ -> None) 328 | | _ -> None)) 329 | (Some []) entries 330 | in 331 | match things with 332 | | Some l -> 333 | List.fold_left (fun db (cid, lease) -> 334 | assert (cid = lease.client_id); 335 | replace lease db) (make_db ()) l 336 | | None -> assert false 337 | 338 | let addr_allocated addr db = 339 | Util.true_if_some @@ lease_of_addr addr db 340 | 341 | let addr_free addr db = not (addr_allocated addr db) 342 | 343 | (* 344 | * We try to use the last 4 bytes of the mac address as a hint for the ip 345 | * address, if that fails, we try a linear search. 346 | *) 347 | let get_usable_addr id db range = 348 | match range with 349 | | None -> None 350 | | Some range -> 351 | let low_ip, high_ip = range in 352 | let low_32 = Ipaddr.V4.to_int32 low_ip in 353 | let high_32 = Ipaddr.V4.to_int32 high_ip in 354 | if (Int32.compare low_32 high_32) > 0 then 355 | invalid_arg "invalid range, must be (low * high)"; 356 | let hint_ip = 357 | let v = match id with 358 | | Dhcp_wire.Id (_, _s) -> Int32.of_int 1805 (* XXX who cares *) 359 | | Dhcp_wire.Hwaddr hw -> 360 | let s = String.sub (Macaddr.to_octets hw) 2 4 in 361 | let b0 = Int32.shift_left (Char.code s.[3] |> Int32.of_int) 0 in 362 | let b1 = Int32.shift_left (Char.code s.[2] |> Int32.of_int) 8 in 363 | let b2 = Int32.shift_left (Char.code s.[1] |> Int32.of_int) 16 in 364 | let b3 = Int32.shift_left (Char.code s.[0] |> Int32.of_int) 24 in 365 | Int32.zero |> Int32.logor b0 |> Int32.logor b1 |> 366 | Int32.logor b2 |> Int32.logor b3 367 | in 368 | Int32.rem v (Int32.sub (Int32.succ high_32) low_32) |> 369 | Int32.abs |> 370 | Int32.add low_32 |> 371 | Ipaddr.V4.of_int32 372 | in 373 | let rec linear_loop off = 374 | let ip = Ipaddr.V4.of_int32 (Int32.add low_32 off) in 375 | if addr_free ip db then 376 | Some ip 377 | else if off = high_32 then 378 | None 379 | else 380 | linear_loop (Int32.succ off) 381 | in 382 | if addr_free hint_ip db then 383 | Some hint_ip 384 | else 385 | linear_loop Int32.zero 386 | 387 | end 388 | 389 | module Input = struct 390 | open Config 391 | open Dhcp_wire 392 | 393 | let bad_packet fmt = Printf.ksprintf (fun s -> invalid_arg s) fmt 394 | 395 | type result = 396 | | Silence 397 | | Update of Lease.database 398 | | Reply of Dhcp_wire.pkt * Lease.database 399 | | Warning of string 400 | | Error of string 401 | 402 | let host_of_mac config mac = Util.find_some @@ 403 | fun () -> List.find (fun host -> host.hw_addr = mac) config.hosts 404 | 405 | let fixed_addr_of_mac config mac = 406 | match host_of_mac config mac with 407 | | Some host -> if host.hw_addr = mac then host.fixed_addr else None 408 | | None -> None 409 | 410 | let _options_of_mac config mac = 411 | match host_of_mac config mac with 412 | | Some host -> host.options 413 | | None -> [] 414 | 415 | let find_lease config client_id mac db ~now = 416 | match (fixed_addr_of_mac config mac) with 417 | | Some fixed_addr -> Some (Lease.make_fixed mac fixed_addr ~duration:config.default_lease_time ~now), true 418 | | None -> Lease.lease_of_client_id client_id db, false 419 | 420 | let good_address config mac addr _db = 421 | match (fixed_addr_of_mac config mac) with 422 | (* If this is a fixed address, it's good if mac matches ip. *) 423 | | Some fixed_addr -> addr = fixed_addr 424 | | None -> (match config.range with 425 | | None -> false 426 | | Some range -> Util.addr_in_range addr range) 427 | 428 | let make_reply config reqpkt 429 | ~ciaddr ~yiaddr ~siaddr ~giaddr options = 430 | let op = BOOTREPLY in 431 | let htype = Ethernet_10mb in 432 | let hlen = 6 in 433 | let hops = 0 in 434 | let xid = reqpkt.xid in 435 | let secs = 0 in 436 | let flags = reqpkt.flags in 437 | let chaddr = reqpkt.chaddr in 438 | let sname = config.hostname in 439 | let file = "" in 440 | (* Build the frame header *) 441 | let dstport = if giaddr = Ipaddr.V4.unspecified then 442 | client_port 443 | else 444 | server_port 445 | in 446 | let srcport = server_port in 447 | let srcmac = config.mac_addr in 448 | let dstmac, dstip = match (find_message_type options) with 449 | | None -> failwith "make_reply: No msgtype in options" 450 | | Some m -> match m with 451 | | DHCPNAK -> if giaddr <> Ipaddr.V4.unspecified then 452 | (reqpkt.srcmac, giaddr) 453 | else 454 | (Macaddr.broadcast, Ipaddr.V4.broadcast) 455 | | DHCPOFFER | DHCPACK -> 456 | if giaddr <> Ipaddr.V4.unspecified then 457 | (reqpkt.srcmac, giaddr) 458 | else if ciaddr <> Ipaddr.V4.unspecified then 459 | (reqpkt.srcmac, ciaddr) 460 | else if flags = Unicast then 461 | (reqpkt.srcmac, yiaddr) 462 | else 463 | (Macaddr.broadcast, Ipaddr.V4.broadcast) 464 | | _ -> invalid_arg ("Can't send message type " ^ msgtype_to_string m) 465 | in 466 | let srcip = config.ip_addr in 467 | { srcmac; dstmac; srcip; dstip; srcport; dstport; 468 | op; htype; hlen; hops; xid; secs; flags; 469 | ciaddr; yiaddr; siaddr; giaddr; chaddr; sname; file; 470 | options } 471 | 472 | let for_us config pkt = 473 | pkt.dstport = Dhcp_wire.server_port 474 | && 475 | pkt.srcport = Dhcp_wire.client_port 476 | && 477 | (pkt.dstmac = config.mac_addr || 478 | pkt.dstmac = Macaddr.broadcast) 479 | && 480 | (pkt.dstip = config.ip_addr || 481 | pkt.dstip = Ipaddr.V4.broadcast) 482 | 483 | let valid_pkt pkt = 484 | if pkt.op <> BOOTREQUEST then 485 | false 486 | else if pkt.htype <> Ethernet_10mb then 487 | false 488 | else if pkt.hlen <> 6 then 489 | false 490 | else if pkt.hops <> 0 then 491 | false 492 | else 493 | true 494 | 495 | (* might be slow O(preqs * options) *) 496 | let replies_of_options options preqs = 497 | (* Sort parameter requests to guarantee ordering. *) 498 | let preqs = 499 | List.sort 500 | (fun a b -> compare (option_code_to_int a) (option_code_to_int b)) 501 | preqs 502 | in 503 | let unassigned_options = 504 | List.filter (function Other (_ ,_) -> true | _ -> false) 505 | options 506 | in 507 | (* matches multiple options *) 508 | let m fn fnr = 509 | match fn options with 510 | | [] -> None 511 | | l -> Some (fnr l) 512 | in 513 | (* matches the first single option *) 514 | let s fn fnr = 515 | match fn options with 516 | | Some x -> Some (fnr x) 517 | | None -> None 518 | in 519 | let consider = function 520 | | SUBNET_MASK -> s find_subnet_mask (fun x -> Subnet_mask x) 521 | | TIME_OFFSET -> s find_time_offset (fun x -> Time_offset x) 522 | | ROUTERS -> m collect_routers (fun x -> Routers x) 523 | | DNS_SERVERS -> m collect_dns_servers (fun x -> Dns_servers x) 524 | | LOG_SERVERS -> m collect_log_servers (fun x -> Log_servers x) 525 | | LPR_SERVERS -> m collect_lpr_servers (fun x -> Lpr_servers x) 526 | | HOSTNAME -> s find_hostname (fun x -> Hostname x) 527 | | BOOTFILE_SIZE -> s find_bootfile_size (fun x -> Bootfile_size x) 528 | | DOMAIN_NAME -> s find_domain_name (fun x -> Domain_name x) 529 | | SWAP_SERVER -> s find_swap_server (fun x -> Swap_server x) 530 | | ROOT_PATH -> s find_root_path (fun x -> Root_path x) 531 | | EXTENSION_PATH -> s find_extension_path (fun x -> Extension_path x) 532 | | IPFORWARDING -> s find_ipforwarding (fun x -> Ipforwarding x) 533 | | NLSR -> s find_nlsr (fun x -> Nlsr x) 534 | | POLICY_FILTERS -> m collect_policy_filters (fun x -> Policy_filters x) 535 | | MAX_DATAGRAM -> s find_max_datagram (fun x -> Max_datagram x) 536 | | DEFAULT_IP_TTL -> s find_default_ip_ttl (fun x -> Default_ip_ttl x) 537 | | INTERFACE_MTU -> s find_interface_mtu (fun x -> Interface_mtu x) 538 | | ALL_SUBNETS_LOCAL -> s find_all_subnets_local (fun x -> All_subnets_local x) 539 | | BROADCAST_ADDR -> s find_broadcast_addr (fun x -> Broadcast_addr x) 540 | | PERFORM_ROUTER_DISC -> 541 | s find_perform_router_disc (fun x -> Perform_router_disc x) 542 | | ROUTER_SOL_ADDR -> s find_router_sol_addr (fun x -> Router_sol_addr x) 543 | | STATIC_ROUTES -> m collect_static_routes (fun x -> Static_routes x) 544 | | TRAILER_ENCAPSULATION -> 545 | s find_trailer_encapsulation (fun x -> Trailer_encapsulation x) 546 | | ARP_CACHE_TIMO -> s find_arp_cache_timo (fun x -> Arp_cache_timo x) 547 | | ETHERNET_ENCAPSULATION -> 548 | s find_ethernet_encapsulation (fun x -> Ethernet_encapsulation x) 549 | | TCP_DEFAULT_TTL -> s find_tcp_default_ttl (fun x -> Tcp_default_ttl x) 550 | | TCP_KEEPALIVE_INTERVAL -> 551 | s find_tcp_keepalive_interval (fun x -> Tcp_keepalive_interval x) 552 | | NIS_DOMAIN -> s find_nis_domain (fun x -> Nis_domain x) 553 | | NIS_SERVERS -> m collect_nis_servers (fun x -> Nis_servers x) 554 | | NTP_SERVERS -> m collect_ntp_servers (fun x -> Ntp_servers x) 555 | | VENDOR_SPECIFIC -> s find_vendor_specific (fun x -> Vendor_specific x) 556 | | NETBIOS_NAME_SERVERS -> 557 | m collect_netbios_name_servers (fun x -> Netbios_name_servers x) 558 | | NETBIOS_DATAGRAM_DISTRIB_SERVERS -> 559 | m collect_netbios_datagram_distrib_servers 560 | (fun x -> Netbios_datagram_distrib_servers x) 561 | | NETBIOS_NODE -> s find_netbios_node (fun x -> Netbios_node x) 562 | | NETBIOS_SCOPE -> s find_netbios_scope (fun x -> Netbios_scope x) 563 | | XWINDOW_FONT_SERVERS -> 564 | m collect_xwindow_font_servers (fun x -> Xwindow_font_servers x) 565 | | XWINDOW_DISPLAY_MANAGERS -> 566 | m collect_xwindow_display_managers (fun x -> Xwindow_display_managers x) 567 | | REQUEST_IP -> None (* Previously included *) 568 | | IP_LEASE_TIME -> None (* Previously included *) 569 | | OPTION_OVERLOAD -> s find_option_overload (fun x -> Option_overload x) 570 | | MESSAGE_TYPE -> None (* Senseless *) 571 | | SERVER_IDENTIFIER -> None (* Previously included *) 572 | | PARAMETER_REQUESTS -> None (* Senseless *) 573 | | MESSAGE -> s find_message (fun x -> Message x) 574 | | MAX_MESSAGE -> s find_max_message (fun x -> Max_message x) 575 | | RENEWAL_T1 -> None (* Previously included *) 576 | | REBINDING_T2 -> None (* Previously included *) 577 | | VENDOR_CLASS_ID -> s find_vendor_class_id (fun x -> Vendor_class_id x) 578 | | CLIENT_ID -> None (* Senseless *) 579 | | NIS_PLUS_DOMAIN -> s find_nis_plus_domain (fun x -> Nis_plus_domain x) 580 | | NIS_PLUS_SERVERS -> 581 | m collect_nis_plus_servers (fun x -> Nis_plus_servers x) 582 | | TFTP_SERVER_NAME -> s find_tftp_server_name (fun x -> Tftp_server_name x) 583 | | BOOTFILE_NAME -> s find_bootfile_name (fun x -> Bootfile_name x) 584 | | MOBILE_IP_HOME_AGENT -> 585 | m collect_mobile_ip_home_agent (fun x -> Mobile_ip_home_agent x) 586 | | SMTP_SERVERS -> m collect_smtp_servers (fun x -> Smtp_servers x) 587 | | POP3_SERVERS -> m collect_pop3_servers (fun x -> Pop3_servers x) 588 | | NNTP_SERVERS -> m collect_nntp_servers (fun x -> Nntp_servers x) 589 | | IRC_SERVERS -> m collect_irc_servers (fun x -> Irc_servers x) 590 | | USER_CLASS -> s find_user_class (fun x -> User_class x) 591 | | RAPID_COMMIT -> s find_rapid_commit (fun _ -> Rapid_commit) 592 | | CLIENT_FQDN -> s find_client_fqdn (fun x -> Client_fqdn x) 593 | | RELAY_AGENT_INFORMATION -> 594 | s find_relay_agent_information (fun x -> Relay_agent_information x) 595 | | CLIENT_SYSTEM -> s find_client_system (fun x -> Client_system x) 596 | | CLIENT_NDI -> s find_client_ndi (fun x -> Client_ndi x) 597 | | UUID_GUID -> s find_uuid_guid (fun x -> Uuid_guid x) 598 | | PCODE -> s find_pcode (fun x -> Pcode x) 599 | | TCODE -> s find_tcode (fun x -> Tcode x) 600 | | IPV6ONLY -> s find_ipv6only (fun x -> IPv6_only x) 601 | | SUBNET_SELECTION -> s find_subnet_selection (fun x -> Subnet_selection x) 602 | | DOMAIN_SEARCH -> s find_domain_search (fun x -> Domain_search x) 603 | | SIP_SERVERS -> s find_sip_servers (fun x -> Sip_servers x) 604 | | CLASSLESS_STATIC_ROUTE -> 605 | s find_classless_static_route (fun x -> Classless_static_route x) 606 | | VI_VENDOR_INFO -> s find_vi_vendor_info (fun x -> Vi_vendor_info x) 607 | | MISC_150 -> s find_misc_150 (fun x -> Misc_150 x) 608 | | WEB_PROXY_AUTO_DISC -> 609 | s find_web_proxy_auto_disc (fun x -> Web_proxy_auto_disc x) 610 | | PRIVATE_CLASSLESS_STATIC_ROUTE -> 611 | s find_private_classless_static_route (fun x -> Private_classless_static_route x) 612 | | OTHER code -> 613 | find_option 614 | (function Other (c, _s) as u when c = code -> Some u | _ -> None) 615 | unassigned_options 616 | | PAD | END -> None (* Senseless *) 617 | in 618 | Util.filter_map consider preqs 619 | 620 | let collect_replies config mac preqs = 621 | match host_of_mac config mac with 622 | | Some host -> replies_of_options (host.options @ config.options) preqs 623 | | None -> replies_of_options config.options preqs 624 | 625 | let collect_replies_test = collect_replies 626 | 627 | let input_decline config db pkt now = 628 | let msgtype = match find_message_type pkt.options with 629 | | Some msgtype -> msgtype_to_string msgtype 630 | | None -> failwith "Unexpected message type" 631 | in 632 | let ourip = config.ip_addr in 633 | let reqip = find_request_ip pkt.options in 634 | let sidip = find_server_identifier pkt.options in 635 | let client_id = client_id_of_pkt pkt in 636 | match sidip with 637 | | None -> bad_packet "%s without server identifier" msgtype 638 | | Some sidip -> 639 | if ourip <> sidip then 640 | Silence (* not for us *) 641 | else 642 | match reqip with 643 | | None -> bad_packet "%s without request ip" msgtype 644 | | Some _reqip -> (* check if the lease is actually his *) 645 | let lease, fixed_lease = 646 | find_lease config client_id pkt.chaddr db ~now in 647 | match lease with 648 | | None -> Silence (* lease is unowned, ignore *) 649 | | Some lease -> 650 | Update ( 651 | if not fixed_lease then 652 | Lease.remove lease db 653 | else 654 | db) 655 | 656 | let input_release config db pkt now = 657 | let msgtype = match find_message_type pkt.options with 658 | | Some msgtype -> msgtype_to_string msgtype 659 | | None -> failwith "Unexpected message type" 660 | in 661 | let ourip = config.ip_addr in 662 | let sidip = find_server_identifier pkt.options in 663 | let client_id = client_id_of_pkt pkt in 664 | match sidip with 665 | | None -> bad_packet "%s without server identifier" msgtype 666 | | Some sidip -> 667 | if ourip <> sidip then 668 | Silence (* not for us *) 669 | else 670 | let lease, fixed_lease = 671 | find_lease config client_id pkt.chaddr db ~now in 672 | match lease with 673 | | None -> Silence (* lease is unowned, ignore *) 674 | | Some lease -> 675 | Update 676 | (if not fixed_lease && pkt.ciaddr = lease.addr then 677 | Lease.remove lease db 678 | else 679 | db) 680 | 681 | let input_inform config db pkt = 682 | if pkt.ciaddr = Ipaddr.V4.unspecified then 683 | bad_packet "DHCPINFORM without ciaddr" 684 | else 685 | let ourip = config.ip_addr in 686 | let options = 687 | let open Util in 688 | cons (Message_type DHCPACK) @@ 689 | cons (Server_identifier ourip) @@ 690 | cons_if_some_f (find_vendor_class_id pkt.options) 691 | (fun vid -> Vendor_class_id vid) @@ 692 | match (find_parameter_requests pkt.options) with 693 | | Some preqs -> collect_replies config pkt.chaddr preqs 694 | | None -> [] 695 | in 696 | let pkt = make_reply config pkt 697 | ~ciaddr:pkt.ciaddr ~yiaddr:Ipaddr.V4.unspecified 698 | ~siaddr:ourip ~giaddr:pkt.giaddr options 699 | in 700 | Reply (pkt, db) 701 | 702 | let input_request config db pkt now = 703 | let client_id = client_id_of_pkt pkt in 704 | let lease, fixed_lease = find_lease config client_id pkt.chaddr db ~now in 705 | let ourip = config.ip_addr in 706 | let reqip = find_request_ip pkt.options in 707 | let sidip = find_server_identifier pkt.options in 708 | let nak ?msg () = 709 | let open Util in 710 | let options = 711 | cons (Message_type DHCPNAK) @@ 712 | cons (Server_identifier ourip) @@ 713 | cons_if_some_f msg (fun msg -> Message msg) @@ 714 | cons_if_some_f (find_client_id pkt.options) 715 | (fun id -> Client_id id) @@ 716 | cons_if_some_f (find_vendor_class_id pkt.options) 717 | (fun vid -> Vendor_class_id vid) [] 718 | in 719 | let pkt = make_reply config pkt 720 | ~ciaddr:Ipaddr.V4.unspecified ~yiaddr:Ipaddr.V4.unspecified 721 | ~siaddr:Ipaddr.V4.unspecified ~giaddr:pkt.giaddr options 722 | in 723 | Reply (pkt, db) 724 | in 725 | let ack lease = 726 | let open Util in 727 | let lease = Lease.extend lease ~now in 728 | let lease_time, t1, t2 = 729 | Lease.timeleft3 lease Config.t1_time_ratio Config.t2_time_ratio ~now 730 | in 731 | let options = 732 | cons (Message_type DHCPACK) @@ 733 | cons (Ip_lease_time lease_time) @@ 734 | cons (Renewal_t1 t1) @@ 735 | cons (Rebinding_t2 t2) @@ 736 | cons (Server_identifier ourip) @@ 737 | cons_if_some_f (find_vendor_class_id pkt.options) 738 | (fun vid -> Vendor_class_id vid) @@ 739 | match (find_parameter_requests pkt.options) with 740 | | Some preqs -> collect_replies config pkt.chaddr preqs 741 | | None -> [] 742 | in 743 | let reply = make_reply config pkt 744 | ~ciaddr:pkt.ciaddr ~yiaddr:lease.Lease.addr 745 | ~siaddr:ourip ~giaddr:pkt.giaddr options 746 | in 747 | if not fixed_lease then 748 | let () = assert (lease.Lease.client_id = client_id) in 749 | Reply (reply, Lease.replace lease db) 750 | else 751 | Reply (reply, db) 752 | in 753 | match sidip, reqip, lease with 754 | | Some sidip, Some reqip, _ -> (* DHCPREQUEST generated during SELECTING state *) 755 | if sidip <> ourip then (* is it for us ? *) 756 | Silence 757 | else if pkt.ciaddr <> Ipaddr.V4.unspecified then (* violates RFC2131 4.3.2 *) 758 | Warning "Bad DHCPREQUEST, ciaddr is not 0" 759 | else if not (good_address config pkt.chaddr reqip db) then 760 | nak ~msg:"Requested address is not in subnet range" () 761 | else 762 | (match lease with 763 | | Some lease -> 764 | if lease.Lease.addr <> reqip then 765 | nak ~msg:"Requested address is incorrect" () 766 | else 767 | ack lease 768 | | None -> 769 | if (Lease.addr_allocated reqip db) then 770 | nak ~msg:"Requested address is allocated" () 771 | else 772 | ack (Lease.make client_id reqip 773 | ~duration:config.default_lease_time ~now)) 774 | | None, Some reqip, Some lease -> (* DHCPREQUEST @ INIT-REBOOT state *) 775 | if pkt.ciaddr <> Ipaddr.V4.unspecified then (* violates RFC2131 4.3.2 *) 776 | bad_packet "Bad DHCPREQUEST, ciaddr is not 0" 777 | (* TODO check if it's in the correct network when giaddr <> 0 *) 778 | else if pkt.giaddr = Ipaddr.V4.unspecified && 779 | not (good_address config pkt.chaddr reqip db) then 780 | nak ~msg:"Requested address is not in subnet range" () 781 | else if lease.Lease.addr <> reqip then 782 | nak ~msg:"Requested address is incorrect" () 783 | else 784 | Silence 785 | | None, None, Some lease -> (* DHCPREQUEST @ RENEWING/REBINDING state *) 786 | if pkt.ciaddr = Ipaddr.V4.unspecified then (* violates RFC2131 4.3.2 renewal *) 787 | bad_packet "Bad DHCPREQUEST, ciaddr is not 0" 788 | else if lease.Lease.addr <> pkt.ciaddr then 789 | nak ~msg:"Requested address is incorrect" () 790 | else 791 | ack lease 792 | | _ -> Silence 793 | 794 | let discover_addr config lease db pkt = 795 | let id = client_id_of_pkt pkt in 796 | match lease with 797 | (* Handle the case where we have a lease *) 798 | | Some lease -> Some lease.Lease.addr 799 | | None -> match (find_request_ip pkt.options) with 800 | | Some req_addr -> 801 | if (good_address config pkt.chaddr req_addr db) && 802 | (Lease.addr_free req_addr db) then 803 | Some req_addr 804 | else 805 | Lease.get_usable_addr id db config.range 806 | | None -> Lease.get_usable_addr id db config.range 807 | 808 | let discover_lease_time config lease _db pkt now = 809 | match (find_ip_lease_time pkt.options) with 810 | | Some ip_lease_time -> 811 | if Config.lease_time_good config ip_lease_time then 812 | ip_lease_time 813 | else 814 | config.default_lease_time 815 | | None -> match lease with 816 | | None -> config.default_lease_time 817 | | Some lease -> if Lease.expired lease ~now then 818 | config.default_lease_time 819 | else 820 | Lease.timeleft lease ~now 821 | 822 | let input_discover config db pkt now = 823 | (* RFC section 4.3.1 *) 824 | (* Figure out the ip address *) 825 | let id = client_id_of_pkt pkt in 826 | let lease, _fixed_lease = find_lease config id pkt.chaddr db ~now in 827 | let ourip = config.ip_addr in 828 | let addr = discover_addr config lease db pkt in 829 | (* Figure out the lease lease_time *) 830 | let lease_time = discover_lease_time config lease db pkt now in 831 | match addr with 832 | | None -> Warning "No ips left to offer" 833 | | Some addr -> 834 | let open Util in 835 | (* Start building the options *) 836 | let t1 = Int32.of_float 837 | (Config.t1_time_ratio *. (Int32.to_float lease_time)) in 838 | let t2 = Int32.of_float 839 | (Config.t2_time_ratio *. (Int32.to_float lease_time)) in 840 | let options = 841 | cons (Message_type DHCPOFFER) @@ 842 | cons (Ip_lease_time lease_time) @@ 843 | cons (Renewal_t1 t1) @@ 844 | cons (Rebinding_t2 t2) @@ 845 | cons (Server_identifier ourip) @@ 846 | cons_if_some_f (find_vendor_class_id pkt.options) 847 | (fun vid -> Vendor_class_id vid) @@ 848 | match (find_parameter_requests pkt.options) with 849 | | Some preqs -> 850 | collect_replies config pkt.chaddr preqs 851 | | None -> [] 852 | in 853 | let pkt = make_reply config pkt 854 | ~ciaddr:Ipaddr.V4.unspecified ~yiaddr:addr 855 | ~siaddr:ourip ~giaddr:pkt.giaddr options 856 | in 857 | Reply (pkt, db) 858 | 859 | let input_pkt config db pkt time = 860 | try 861 | if not (for_us config pkt) then 862 | Silence 863 | else if valid_pkt pkt then 864 | match find_message_type pkt.options with 865 | | Some DHCPDISCOVER -> input_discover config db pkt time 866 | | Some DHCPREQUEST -> input_request config db pkt time 867 | | Some DHCPDECLINE -> input_decline config db pkt time 868 | | Some DHCPRELEASE -> input_release config db pkt time 869 | | Some DHCPINFORM -> input_inform config db pkt 870 | | None -> bad_packet "Malformed packet: no dhcp msgtype" 871 | | Some m -> Warning ("Unhandled msgtype " ^ msgtype_to_string m) 872 | else 873 | bad_packet "Invalid packet" 874 | with 875 | | Invalid_argument e -> Error e 876 | end 877 | -------------------------------------------------------------------------------- /server/dhcp_server.mli: -------------------------------------------------------------------------------- 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 | (** A DHCP server is composed of two sub-modules: {! Config} and {! Input}. The 18 | former deals with building a suitable configuration for using with the 19 | later. 20 | 21 | {e %%VERSION%% - {{:%%PKG_HOMEPAGE%% }homepage}} 22 | *) 23 | 24 | (** {2 DHCP Server Configuration } *) 25 | 26 | module Config : sig 27 | 28 | type host = { 29 | hostname : string; 30 | options : Dhcp_wire.dhcp_option list; 31 | fixed_addr : Ipaddr.V4.t option; 32 | hw_addr : Macaddr.t; 33 | } 34 | (** {! host} config section entry. *) 35 | 36 | type t = { 37 | options : Dhcp_wire.dhcp_option list; 38 | hostname : string; 39 | default_lease_time : int32; 40 | max_lease_time : int32; 41 | ip_addr : Ipaddr.V4.t; 42 | mac_addr : Macaddr.t; 43 | network : Ipaddr.V4.Prefix.t; 44 | range : (Ipaddr.V4.t * Ipaddr.V4.t) option; 45 | hosts : host list; 46 | } 47 | (** Server configuration *) 48 | 49 | val parse : string -> (Ipaddr.V4.t * Macaddr.t) -> t 50 | (** [parse cf (addr * mac)] Creates a server configuration by parsing [cf] as an 51 | ISC dhcpd.conf file, currently only the options at [sample/dhcpd.conf] are 52 | supported. [addr] and [mac] are the prefix address and mac address to be 53 | used for building replies, it must match one subnet section in [cf]. 54 | Raises Not_found if the (addr * mac) tuple does not match any network 55 | section. *) 56 | 57 | val make : 58 | ?hostname:string -> 59 | ?default_lease_time:int -> 60 | ?max_lease_time:int -> 61 | ?hosts:host list -> 62 | addr_tuple:Ipaddr.V4.t * Macaddr.t -> 63 | network:Ipaddr.V4.Prefix.t -> 64 | range:(Ipaddr.V4.t * Ipaddr.V4.t) option -> 65 | options:Dhcp_wire.dhcp_option list -> 66 | unit -> t 67 | 68 | end 69 | 70 | (** {2 DHCP Leases (bindings) } *) 71 | 72 | module Lease : sig 73 | type t = { 74 | tm_start : int32; 75 | tm_end : int32; 76 | addr : Ipaddr.V4.t; 77 | client_id : Dhcp_wire.client_id; 78 | } 79 | 80 | val make : Dhcp_wire.client_id -> Ipaddr.V4.t -> duration:int32 -> now:int32 -> t 81 | val make_fixed : Macaddr.t -> Ipaddr.V4.t -> duration:int32 -> now:int32 -> t 82 | val timeleft : t -> now:int32 -> int32 83 | val timeleft_exn : t -> now:int32 -> int32 84 | val timeleft3 : t -> float -> float -> now:int32 -> int32 * int32 * int32 85 | val extend : t -> now:int32 -> t 86 | val expired : t -> now:int32 -> bool 87 | val to_string : t -> string 88 | 89 | type database 90 | 91 | val make_db : unit -> database 92 | val db_to_string : database -> string 93 | val db_of_string : string -> database 94 | val db_to_list : database -> t list 95 | val db_equal : database -> database -> bool 96 | val garbage_collect : database -> now:int32 -> database 97 | val remove : t -> database -> database 98 | val replace : t -> database -> database 99 | val lease_of_client_id : Dhcp_wire.client_id -> database -> t option 100 | val lease_of_addr : Ipaddr.V4.t -> database -> Dhcp_wire.client_id option 101 | val addr_allocated : Ipaddr.V4.t -> database -> bool 102 | val addr_free : Ipaddr.V4.t -> database -> bool 103 | val get_usable_addr : 104 | Dhcp_wire.client_id -> database -> 105 | (Ipaddr.V4.t * Ipaddr.V4.t) option -> Ipaddr.V4.t option 106 | 107 | end 108 | 109 | (** {2 DHCP Input Packet Logic } *) 110 | 111 | module Input : sig 112 | 113 | (** The logic for handling a DHCP input packet is pure, the module does not 114 | perform any IO, it only returns a possible reply packet or event to be 115 | logged. 116 | 117 | A typical server main loop would do its own IO for receiving a packet, 118 | then input with {! Input.input_pkt} and send out the resulting reply. *) 119 | 120 | type result = 121 | | Silence (** Input packet didn't belong to us, normal nop event.*) 122 | | Update of Lease.database (** Lease database update. *) 123 | | Reply of Dhcp_wire.pkt * Lease.database 124 | (** Reply packet to be sent back and the corresponding lease database to be 125 | used in case the sent of the reply pkt is successfull *) 126 | | Warning of string (** An odd event, could be logged. *) 127 | | Error of string (** Input packet is invalid, or some other error ocurred. *) 128 | (** The result of [input_pkt]. *) 129 | 130 | val for_us : Config.t -> Dhcp_wire.pkt -> bool 131 | (** Check the packet headers, true if the packet is destined for us. *) 132 | 133 | val input_pkt : Config.t -> Lease.database -> Dhcp_wire.pkt -> int32 -> result 134 | (** [input_pkt config lease_db pkt time] Inputs packet [pkt], lease_db 135 | is the current lease database state, the resulting action should be 136 | performed by the caller, normally a [Reply] packet is returned and should be 137 | sent back. [time] is a int32 representing time as monotonic seconds. *) 138 | 139 | val collect_replies_test : Config.t -> Macaddr.t -> 140 | Dhcp_wire.option_code list -> Dhcp_wire.dhcp_option list 141 | (** Internal function exported for regression tests. Don't use this. *) 142 | 143 | end 144 | -------------------------------------------------------------------------------- /server/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name dhcp_server) 3 | (public_name charrua-server) 4 | (private_modules dhcp_lexer dhcp_parser ast util) 5 | (libraries ipaddr macaddr charrua)) 6 | 7 | (menhir (modules dhcp_parser)) 8 | 9 | (ocamllex dhcp_lexer) 10 | -------------------------------------------------------------------------------- /server/util.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 find_map f t = 18 | let rec loop = function 19 | | [] -> None 20 | | x :: l -> 21 | match f x with 22 | | None -> loop l 23 | | Some _ as r -> r 24 | in 25 | loop t 26 | 27 | let filter_map f l = 28 | List.rev @@ 29 | List.fold_left (fun a v -> match f v with Some v' -> v'::a | None -> a) [] l 30 | 31 | let finalize f g = 32 | try 33 | let x = f () in 34 | g (); 35 | x 36 | with exn -> 37 | g (); 38 | raise exn 39 | 40 | let some_or_default x d = match x with Some x -> x | None -> d 41 | let some_or_f x f = match x with Some x -> x | None -> f () 42 | let some_or_invalid x s = some_or_f x (fun () -> invalid_arg s) 43 | let some_or_fail x s = some_or_f x (fun () -> failwith s) 44 | let find_some f = try Some (f ()) with Not_found -> None 45 | let true_if_some x = match x with Some _ -> true | None -> false 46 | 47 | let cons v tl = v :: tl 48 | let cons_if p v tl = if p then v :: tl else tl 49 | let cons_if_some v tl = match v with Some v -> v :: tl | None -> tl 50 | let cons_if_some_f v fnr tl = match v with Some x -> fnr x :: tl | None -> tl 51 | 52 | let addr_in_range addr range = 53 | let low_ip, high_ip = range in 54 | let low_32 = Ipaddr.V4.to_int32 low_ip in 55 | let high_32 = Ipaddr.V4.to_int32 high_ip in 56 | let addr_32 = Ipaddr.V4.to_int32 addr in 57 | addr_32 >= low_32 && addr_32 <= high_32 58 | -------------------------------------------------------------------------------- /test/client/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_client) 3 | (package charrua-client) 4 | (libraries cstruct-unix alcotest charrua-client charrua-server 5 | mirage-crypto-rng mirage-crypto-rng.unix)) 6 | -------------------------------------------------------------------------------- /test/client/lwt/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_client_lwt) 3 | (package charrua-client) 4 | (libraries cstruct-unix alcotest charrua-client.lwt lwt.unix 5 | mirage-crypto-rng.unix)) 6 | -------------------------------------------------------------------------------- /test/client/lwt/test_client_lwt.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | (* additional tests for time- and network-dependent code *) 4 | module No_net = struct 5 | type error = Mirage_net.Net.error 6 | let pp_error = Mirage_net.Net.pp_error 7 | type stats = Mirage_net.stats 8 | type t = { mac : Macaddr.t; mutable packets : Cstruct.t list } 9 | let disconnect _ = Lwt.return_unit 10 | let write t ~size fillf = 11 | let buf = Cstruct.create size in 12 | let l = fillf buf in 13 | assert (l <= size); 14 | let b = Cstruct.sub buf 0 l in 15 | t.packets <- t.packets @ [b]; 16 | Lwt.return_ok () 17 | let listen _ ~header_size:_ _ = Lwt.return_ok () 18 | let mac t = t.mac 19 | let mtu _t = 1500 20 | let reset_stats_counters _ = () 21 | let get_stats_counters _ = { 22 | Mirage_net.rx_bytes = 0L; 23 | tx_bytes = 0L; 24 | rx_pkts = 0l; 25 | tx_pkts = 0l; 26 | } 27 | let connect ~mac () = { packets = []; mac } 28 | let get_packets t = t.packets 29 | end 30 | 31 | let keep_trying () = 32 | Lwt_main.run @@ ( 33 | Mirage_crypto_rng_unix.use_default (); 34 | let module Client = Dhcp_client_lwt.Make(No_net) in 35 | let net = No_net.connect ~mac:(Macaddr.of_string_exn "c0:ff:ee:c0:ff:ee") () in 36 | let test = 37 | Client.connect net >>= Lwt_stream.get >|= function 38 | | Some _ -> Alcotest.fail "got a lease from a nonfunctioning network somehow" 39 | | None -> () 40 | in 41 | Lwt.pick [ 42 | test; 43 | Lwt.pause () >>= function () -> 44 | (Alcotest.(check bool) "sent >1 packet" true (List.length (No_net.get_packets net) > 1); Lwt.return_unit) 45 | ] 46 | ) 47 | 48 | let () = 49 | Alcotest.run "lwt client tests" [ 50 | "timeouts", [ 51 | "more than one dhcpdiscover is sent", `Quick, keep_trying; 52 | ] 53 | ] 54 | -------------------------------------------------------------------------------- /test/client/test_client.ml: -------------------------------------------------------------------------------- 1 | let cstruct = Alcotest.of_pp Cstruct.hexdump_pp 2 | 3 | let msgtype = 4 | let module M = struct 5 | type t = Dhcp_wire.msgtype 6 | let pp fmt m = Format.fprintf fmt "%s" (Dhcp_wire.msgtype_to_string m) 7 | let equal p q = (compare p q) = 0 8 | end in 9 | (module M : Alcotest.TESTABLE with type t = M.t) 10 | 11 | module Defaults = struct 12 | let client_mac = Macaddr.of_string_exn "00:16:3e:ba:eb:ba" 13 | let server_mac = Macaddr.of_string_exn "00:16:3e:00:00:00" 14 | let server_ip = Ipaddr.V4.of_string_exn "192.168.1.1" 15 | let server_network = Ipaddr.V4.Prefix.make 24 server_ip 16 | let range = Some (Ipaddr.V4.of_string_exn "192.168.1.15", Ipaddr.V4.of_string_exn "192.168.1.65") 17 | let options = [] 18 | let config = Dhcp_server.Config.make 19 | ?hostname:None ?default_lease_time:None 20 | ?max_lease_time:None ?hosts:None 21 | ~addr_tuple:(server_ip, server_mac) 22 | ~network:server_network ~range ~options () 23 | let empty_db = Dhcp_server.Lease.make_db () 24 | end 25 | 26 | let random_buffer () = 27 | let sz = Randomconv.int16 Mirage_crypto_rng.generate in 28 | Cstruct.of_string (Mirage_crypto_rng.generate sz) 29 | 30 | let rec no_result t n () = 31 | if n <= 0 then () 32 | else begin 33 | let buf = random_buffer () in 34 | (* TODO: it would be better to randomize a valid DHCP message; currently 35 | * we're fuzz testing the Dhcp_wire parser's ability to handle random garbage *) 36 | let res = Dhcp_client.input t buf in 37 | Alcotest.(check bool) "no action" true (res = `Noop); 38 | no_result t (n - 1) () 39 | end 40 | 41 | let parseable buf = 42 | Alcotest.(check bool) "buffer we constructed is valid dhcp" true (Dhcp_wire.is_dhcp buf (Cstruct.length buf)) 43 | 44 | let random_xid () = Randomconv.int32 Mirage_crypto_rng.generate 45 | 46 | let start_makes_dhcp () = 47 | let (_s, pkt) = Dhcp_client.create (random_xid ()) Defaults.client_mac in 48 | (* for now, any positive result is fine *) 49 | parseable (Dhcp_wire.buf_of_pkt pkt) 50 | 51 | let client_to_selecting () = 52 | let open Defaults in 53 | let (s, pkt) = Dhcp_client.create (random_xid ()) client_mac in 54 | let buf = Dhcp_wire.buf_of_pkt pkt in 55 | let answer = Dhcp_wire.pkt_of_buf buf (Cstruct.length buf) in 56 | Alcotest.(check (result pass reject)) "input succeeds" answer answer; 57 | (s, Result.get_ok answer) 58 | 59 | let assert_reply p = 60 | let open Dhcp_server.Input in 61 | match p with 62 | | Warning s | Error s -> Alcotest.fail s 63 | | Silence -> Alcotest.fail "Silence from the server in response to a request" 64 | | Update _db -> Alcotest.fail "database update but no reply -- in our context this is likely a bug" 65 | | Reply (pkt, db) -> (pkt, db) 66 | 67 | let server_accepts_start_packet () = 68 | let open Defaults in 69 | let (_, dhcpdiscover) = client_to_selecting () in 70 | ignore @@ assert_reply @@ Dhcp_server.Input.input_pkt config empty_db dhcpdiscover 0l 71 | 72 | let server_gives_dhcpoffer () = 73 | let open Defaults in 74 | let open Dhcp_wire in 75 | let (_, dhcpdiscover) = client_to_selecting () in 76 | let (pkt, _db) = assert_reply @@ 77 | Dhcp_server.Input.input_pkt config empty_db dhcpdiscover 0l in 78 | Alcotest.(check (option msgtype)) "initial message merited a DHCPOFFER" 79 | (Some DHCPOFFER) (find_message_type pkt.options) 80 | 81 | let client_rejects_wrong_xid () = 82 | let open Defaults in 83 | let (s, answer) = client_to_selecting () in 84 | let (pkt, _db) = assert_reply @@ Dhcp_server.Input.input_pkt config empty_db answer 0l in 85 | let pkt = Dhcp_wire.({pkt with xid = Int32.add pkt.xid 1l}) in 86 | Alcotest.(check bool) "don't respond to dhcpoffer with non-matching xid" 87 | true (`Noop = Dhcp_client.input s @@ Dhcp_wire.buf_of_pkt pkt) 88 | 89 | let client_asks_dhcprequest () = 90 | let open Dhcp_wire in 91 | let open Defaults in 92 | let (s, answer) = client_to_selecting () in 93 | let (pkt, _db) = assert_reply @@ Dhcp_server.Input.input_pkt config empty_db answer 0l in 94 | match find_message_type pkt.options with 95 | | Some DHCPOFFER -> begin 96 | match Dhcp_client.input s (Dhcp_wire.buf_of_pkt pkt) with 97 | | `Noop -> Alcotest.fail "response to DHCPOFFER was silence" 98 | | `New_lease _ -> Alcotest.fail "thought a DHCPOFFER was a lease???" 99 | | `Response (_s, pkt) -> 100 | let buf = Dhcp_wire.buf_of_pkt pkt in 101 | parseable buf; 102 | let dhcprequest = Result.get_ok @@ 103 | Dhcp_wire.pkt_of_buf buf (Cstruct.length buf) in 104 | Alcotest.(check (option msgtype)) "responded to DHCPOFFER with DHCPREQUEST" 105 | (Some DHCPREQUEST) (find_message_type dhcprequest.options) 106 | end 107 | | _ -> Alcotest.fail "couldn't get a valid DHCPOFFER to attempt to send DHCPREQUEST in response to" 108 | 109 | let server_gives_dhcpack () = 110 | let open Dhcp_wire in 111 | let open Defaults in 112 | let (s, dhcpdiscover) = client_to_selecting () in 113 | let (dhcpoffer, db) = assert_reply @@ Dhcp_server.Input.input_pkt config empty_db dhcpdiscover 0l in 114 | match Dhcp_client.input s (Dhcp_wire.buf_of_pkt dhcpoffer) with 115 | | `Noop -> Alcotest.fail "couldn't get client to respond to DHCPOFFER" 116 | | `New_lease _-> Alcotest.fail "thought a DHCPOFFER was a lease" 117 | | `Response (_s, pkt) -> 118 | let buf = Dhcp_wire.buf_of_pkt pkt in 119 | let dhcprequest = Result.get_ok @@ Dhcp_wire.pkt_of_buf buf (Cstruct.length buf) in 120 | let (dhcpack, _db) = assert_reply @@ Dhcp_server.Input.input_pkt config db dhcprequest 0l in 121 | Alcotest.(check (option msgtype)) "got a DHCPACK in response to DHCPREQUEST" 122 | (Some DHCPACK) (find_message_type dhcpack.options) 123 | 124 | let client_returns_lease () = 125 | let open Dhcp_wire in 126 | let open Defaults in 127 | let (s, dhcpdiscover) = client_to_selecting () in 128 | let (dhcpoffer, db) = assert_reply @@ Dhcp_server.Input.input_pkt config empty_db dhcpdiscover 0l in 129 | match Dhcp_client.input s (Dhcp_wire.buf_of_pkt dhcpoffer) with 130 | | `Noop | `New_lease _ -> Alcotest.fail "incorrect response to DHCPOFFER" 131 | | `Response (s, pkt) -> 132 | let buf = Dhcp_wire.buf_of_pkt pkt in 133 | let dhcprequest = Result.get_ok @@ Dhcp_wire.pkt_of_buf buf (Cstruct.length buf) in 134 | let (dhcpack, _db) = assert_reply @@ Dhcp_server.Input.input_pkt config db dhcprequest 0l in 135 | Alcotest.(check (option msgtype)) "got a DHCPACK in response to DHCPREQUEST" 136 | (Some DHCPACK) (find_message_type dhcpack.options); 137 | match Dhcp_client.input s (Dhcp_wire.buf_of_pkt dhcpack) with 138 | | `Response _ -> 139 | Alcotest.fail "client wanted to send more packets after receiving DHCPACK" 140 | | `Noop -> Alcotest.fail "client disregarded its lease" 141 | | `New_lease (s, _l) -> 142 | Alcotest.(check (option pass)) "lease is held" (Some dhcpack) (Dhcp_client.lease s) 143 | 144 | let random_init n = 145 | let (s, _) = Dhcp_client.create (random_xid ()) Defaults.client_mac in 146 | "random buffer entry to INIT client", `Quick, (no_result s n) 147 | 148 | let random_selecting n = 149 | let (s, _) = client_to_selecting () in 150 | "random buffer entry to SELECTING client", `Quick, (no_result s n) 151 | 152 | let random_requesting n = 153 | let open Defaults in 154 | let (s, dhcpdiscover) = client_to_selecting () in 155 | let (pkt, _db) = assert_reply @@ Dhcp_server.Input.input_pkt config empty_db dhcpdiscover 0l in 156 | match Dhcp_client.input s (Dhcp_wire.buf_of_pkt pkt) with 157 | | `Noop | `New_lease _ -> Alcotest.fail "couldn't enter REQUESTING properly" 158 | | `Response (s, _dhcprequest) -> 159 | "random buffer entry to REQUESTING client", `Quick, (no_result s n) 160 | 161 | let random_bound n = 162 | let open Defaults in 163 | let (s, dhcpdiscover) = client_to_selecting () in 164 | let (pkt, db) = assert_reply @@ Dhcp_server.Input.input_pkt config empty_db dhcpdiscover 0l in 165 | match Dhcp_client.input s (Dhcp_wire.buf_of_pkt pkt) with 166 | | `Noop | `New_lease _ -> Alcotest.fail "couldn't enter REQUESTING properly" 167 | | `Response (s, dhcprequest) -> 168 | let buf = Dhcp_wire.buf_of_pkt dhcprequest in 169 | let dhcprequest = Result.get_ok @@ Dhcp_wire.pkt_of_buf buf (Cstruct.length buf) in 170 | let (dhcpack, _db) = assert_reply @@ Dhcp_server.Input.input_pkt config db dhcprequest 0l in 171 | match Dhcp_client.input s (Dhcp_wire.buf_of_pkt dhcpack) with 172 | | `Noop | `Response _ -> Alcotest.fail "client did not recognize DHCPACK as 173 | a new lease" 174 | | `New_lease (s, _response) -> 175 | "random buffer entry to BOUND client", `Quick, (no_result s n) 176 | 177 | let () = 178 | Mirage_crypto_rng_unix.use_default () ; 179 | let nfuzz = 100 in 180 | Alcotest.run "client tests" [ 181 | (* these tests will programmatically put [Dhcp_client.t] into a particular 182 | * state, then throw random input at it the specified number of times. *) 183 | "random input tests", [ 184 | random_init nfuzz; 185 | random_selecting nfuzz; 186 | random_requesting nfuzz; 187 | random_bound nfuzz; 188 | ]; 189 | "state progression", [ 190 | "initializing state machine generates a dhcp packet", `Quick, start_makes_dhcp; 191 | "dhcp server accepts start packet", `Quick, server_accepts_start_packet; 192 | "dhcp client doesn't accept DHCPOFFER with wrong xid", `Quick, client_rejects_wrong_xid; 193 | "dhcp server offers a lease in response to start packet", `Quick, server_gives_dhcpoffer; 194 | "dhcp client sends a dhcp packet in response to DHCPOFFER", `Quick, client_asks_dhcprequest; 195 | "dhcp server sends a DHCPACK in response to client DHCPREQUEST", `Quick, server_gives_dhcpack; 196 | "dhcp client returns lease after receiving DHCPACK", `Quick, client_returns_lease; 197 | ] 198 | ] 199 | -------------------------------------------------------------------------------- /test/dhcp.pcap: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mirage/charrua/efb8f93144176662567c5e2f6332e9ff51057d3e/test/dhcp.pcap -------------------------------------------------------------------------------- /test/dhcp2.pcap: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mirage/charrua/efb8f93144176662567c5e2f6332e9ff51057d3e/test/dhcp2.pcap -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test) 3 | (package charrua-server) 4 | (libraries cstruct-unix alcotest charrua charrua-server)) 5 | 6 | (alias 7 | (name runtest) 8 | (package charrua-server) 9 | (deps 10 | (:< test.exe) 11 | dhcp.pcap 12 | dhcp2.pcap)) 13 | -------------------------------------------------------------------------------- /test/pcap.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2012 Anil Madhavapeddy 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 | let () = Printexc.record_backtrace true 19 | 20 | let printf = Printf.printf 21 | 22 | let verbose = (Array.length Sys.argv) = 2 && Sys.argv.(1) = "-v" 23 | 24 | (*type pcap_header = { 25 | magic_number: uint32_t; (* magic number *) 26 | version_major: uint16_t; (* major version number *) 27 | version_minor: uint16_t; (* minor version number *) 28 | thiszone: uint32_t; (* GMT to local correction *) 29 | sigfigs: uint32_t; (* accuracy of timestamps *) 30 | snaplen: uint32_t; (* max length of captured packets, in octets *) 31 | network: uint32_t; (* data link type *) 32 | } *) 33 | 34 | let get_pcap_header_magic_number cs = 35 | Cstruct.LE.get_uint32 cs 0 36 | 37 | let get_pcap_header_version_major cs = 38 | Cstruct.LE.get_uint16 cs 4 39 | 40 | let get_pcap_header_version_minor cs = 41 | Cstruct.LE.get_uint16 cs 6 42 | 43 | let get_pcap_header_thiszone cs = 44 | Cstruct.LE.get_uint32 cs 8 45 | 46 | let get_pcap_header_sigfigs cs = 47 | Cstruct.LE.get_uint32 cs 12 48 | 49 | let get_pcap_header_snaplen cs = 50 | Cstruct.LE.get_uint32 cs 16 51 | 52 | let get_pcap_header_network cs = 53 | Cstruct.LE.get_uint32 cs 20 54 | 55 | let sizeof_pcap_header = 24 56 | 57 | (* type pcap_packet = { 58 | ts_sec: uint32_t; (* timestamp seconds *) 59 | ts_usec: uint32_t; (* timestamp microseconds *) 60 | incl_len: uint32_t; (* number of octets of packet saved in file *) 61 | orig_len: uint32_t; (* actual length of packet *) 62 | } *) 63 | 64 | let get_pcap_packet_ts_sec cs = 65 | Cstruct.LE.get_uint32 cs 0 66 | 67 | let get_pcap_packet_ts_usec cs = 68 | Cstruct.LE.get_uint32 cs 4 69 | 70 | let get_pcap_packet_incl_len cs = 71 | Cstruct.LE.get_uint32 cs 8 72 | 73 | let get_pcap_packet_orig_len cs = 74 | Cstruct.LE.get_uint32 cs 12 75 | 76 | let sizeof_pcap_packet = 16 77 | 78 | let test_packet p len = 79 | match (Dhcp_wire.pkt_of_buf p len) with 80 | | Error e -> failwith e 81 | | Ok pkt -> 82 | if verbose then 83 | Format.printf "DHCP: %a\n%!" Dhcp_wire.pp_pkt pkt; 84 | let buf = Dhcp_wire.buf_of_pkt pkt in 85 | match (Dhcp_wire.pkt_of_buf buf len) with 86 | | Error e -> failwith e 87 | | Ok pkt2 -> 88 | if pkt2 <> pkt then begin 89 | printf "buffers differ !\n"; 90 | printf "pcap buf:"; 91 | Cstruct.hexdump p; 92 | printf "our buf:"; 93 | Cstruct.hexdump buf; 94 | Format.printf "generated pkt:\n%a\n" Dhcp_wire.pp_pkt pkt2; 95 | failwith "Serialization bug found !" 96 | end 97 | 98 | let test_pcap_packet (hdr, pkt) = 99 | let ts_sec = get_pcap_packet_ts_sec hdr in 100 | let ts_usec = get_pcap_packet_ts_usec hdr in 101 | let incl_len = get_pcap_packet_incl_len hdr in 102 | let orig_len = get_pcap_packet_orig_len hdr in 103 | if verbose then 104 | printf "***** %lu.%lu bytes %lu (of %lu)\n%!" 105 | ts_sec ts_usec incl_len orig_len; 106 | test_packet pkt (Int32.to_int incl_len) 107 | 108 | let test_pcap_header buf = 109 | let magic = get_pcap_header_magic_number buf in 110 | let endian = 111 | match magic with 112 | |0xa1b2c3d4l -> "bigendian" 113 | |0xd4c3b2a1l -> "littlendian" 114 | |_ -> "not a pcap file" 115 | in 116 | let version_major = get_pcap_header_version_major buf in 117 | let version_minor = get_pcap_header_version_minor buf in 118 | let thiszone = get_pcap_header_thiszone buf in 119 | let sigfis = get_pcap_header_sigfigs buf in 120 | let snaplen = get_pcap_header_snaplen buf in 121 | let header_network = get_pcap_header_network buf in 122 | if verbose then begin 123 | printf "pcap_header (len %d)\n%!" sizeof_pcap_header; 124 | printf "magic_number %lx (%s)\n%!" magic endian; 125 | printf "version %d %d\n%!" version_major version_minor; 126 | printf "timezone shift %lu\n%!" thiszone; 127 | printf "timestamp accuracy %lu\n%!" sigfis; 128 | printf "snaplen %lu\n%!" snaplen; 129 | printf "lltype %lx\n%!" header_network 130 | end 131 | 132 | let parse file = 133 | if verbose then 134 | printf "parsing %s\n%!" file; 135 | let fd = Unix.(openfile file [O_RDONLY] 0) in 136 | let t = Unix_cstruct.of_fd fd in 137 | if verbose then 138 | printf "total pcap file length %d\n%!" (Cstruct.length t); 139 | 140 | let header, body = Cstruct.split t sizeof_pcap_header in 141 | if verbose then 142 | test_pcap_header header; 143 | 144 | let packets = Cstruct.iter 145 | (fun buf -> Some (sizeof_pcap_packet + Int32.to_int (get_pcap_packet_incl_len buf))) 146 | (fun buf -> buf, Cstruct.shift buf sizeof_pcap_packet) 147 | body 148 | in 149 | let num_packets = Cstruct.fold 150 | (fun a packet -> test_pcap_packet packet; (a+1)) 151 | packets 0 152 | in 153 | Unix.close fd; 154 | if verbose then 155 | printf "%s had %d packets\n\n%!" file num_packets 156 | 157 | let testfiles = ["dhcp.pcap"; "dhcp2.pcap" ] 158 | 159 | let t_pcap () = 160 | List.iter parse testfiles 161 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Christiano F. Haesbaert 3 | * Copyright (c) 2016 Gina Marie Maini 4 | * Copyright (c) 2016-2017 Mindy Preston 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | let () = Printexc.record_backtrace true 20 | 21 | let printf = Printf.printf 22 | 23 | let verbose = (Array.length Sys.argv) = 2 && Sys.argv.(1) = "-v" 24 | 25 | let tty_out = Unix.isatty Unix.stdout && Unix.getenv "TERM" <> "dumb" 26 | let colored_or_not cfmt fmt = 27 | if tty_out then (Printf.sprintf cfmt) else (Printf.sprintf fmt) 28 | let red fmt = colored_or_not ("\027[31m"^^fmt^^"\027[m") fmt 29 | let green fmt = colored_or_not ("\027[32m"^^fmt^^"\027[m") fmt 30 | let yellow fmt = colored_or_not ("\027[33m"^^fmt^^"\027[m") fmt 31 | let blue fmt = colored_or_not ("\027[36m"^^fmt^^"\027[m") fmt 32 | 33 | let ip_t = Ipaddr.V4.of_string_exn "192.168.1.1" 34 | let ip2_t = Ipaddr.V4.of_string_exn "192.168.1.2" 35 | let ip3_t = Ipaddr.V4.of_string_exn "192.168.1.3" 36 | let ip4_t = Ipaddr.V4.of_string_exn "192.168.1.4" 37 | let ip5_t = Ipaddr.V4.of_string_exn "192.168.1.5" 38 | let ip55_t = Ipaddr.V4.of_string_exn "192.168.1.55" 39 | let ip150_t = Ipaddr.V4.of_string_exn "192.168.1.150" 40 | let mac_t = Macaddr.of_string_exn "aa:aa:aa:aa:aa:aa" 41 | let mac2_t = Macaddr.of_string_exn "bb:bb:bb:bb:bb:bb" 42 | let mask_t = Ipaddr.V4.of_string_exn "255.255.255.0" 43 | let range_t = (Ipaddr.V4.of_string_exn "192.168.1.50", 44 | Ipaddr.V4.of_string_exn "192.168.1.100") 45 | 46 | let addr_in_range addr range = 47 | let low_ip, high_ip = range in 48 | let low_32 = Ipaddr.V4.to_int32 low_ip in 49 | let high_32 = Ipaddr.V4.to_int32 high_ip in 50 | let addr_32 = Ipaddr.V4.to_int32 addr in 51 | addr_32 >= low_32 && addr_32 <= high_32 52 | 53 | let assert_error x = assert (Result.is_error x) 54 | 55 | open Dhcp_wire 56 | open Dhcp_server 57 | 58 | let now = Int32.one 59 | 60 | let t_option_codes () = 61 | (* Make sure parameters 0-255 are there. *) 62 | for i = 0 to 255 do 63 | ignore (int_to_option_code_exn i) 64 | done 65 | 66 | let t_csum () = 67 | let pkt = { 68 | htype = Ethernet_10mb; 69 | hlen = 6; 70 | hops = 0; 71 | xid = 0xabad1deal; 72 | chaddr = mac_t; 73 | srcport = client_port; 74 | dstport = server_port; 75 | srcmac = mac_t; 76 | dstmac = Macaddr.broadcast; 77 | srcip = Ipaddr.V4.any; 78 | dstip = Ipaddr.V4.broadcast; 79 | op = BOOTREQUEST; 80 | secs = 0; 81 | flags = Broadcast; 82 | siaddr = Ipaddr.V4.any; 83 | ciaddr = Ipaddr.V4.any; 84 | yiaddr = Ipaddr.V4.any; 85 | giaddr = Ipaddr.V4.any; 86 | sname = ""; 87 | file = ""; 88 | options = [ Message_type DHCPREQUEST ] 89 | } in 90 | (* Corrupt every byte of the packet and assert that csum fails *) 91 | let buf = buf_of_pkt pkt in 92 | (* Skip ethernet + upper ip header *) 93 | for off = (14 + 12) to pred (Cstruct.length buf) do 94 | let evilbyte = Cstruct.get_uint8 buf off in 95 | (* Corrupt payload *) 96 | Cstruct.set_uint8 buf off (succ evilbyte); 97 | assert_error (pkt_of_buf buf (Cstruct.length buf)); 98 | (* Put back *) 99 | Cstruct.set_uint8 buf off evilbyte; 100 | done 101 | 102 | let t_long_lists () = 103 | let pkt = { 104 | htype = Ethernet_10mb; 105 | hlen = 6; 106 | hops = 0; 107 | xid = 0xabad1deal; 108 | chaddr = mac_t; 109 | srcport = client_port; 110 | dstport = server_port; 111 | srcmac = mac_t; 112 | dstmac = Macaddr.broadcast; 113 | srcip = Ipaddr.V4.any; 114 | dstip = Ipaddr.V4.broadcast; 115 | op = BOOTREQUEST; 116 | secs = 0; 117 | flags = Broadcast; 118 | siaddr = Ipaddr.V4.any; 119 | ciaddr = Ipaddr.V4.any; 120 | yiaddr = Ipaddr.V4.any; 121 | giaddr = Ipaddr.V4.any; 122 | sname = ""; 123 | file = ""; 124 | options = [ 125 | Message_type DHCPREQUEST; 126 | Dns_servers [ 127 | Ipaddr.V4.of_string_exn "1.2.3.4"; 128 | Ipaddr.V4.of_string_exn "2.3.4.5"; 129 | Ipaddr.V4.of_string_exn "3.4.5.6"; 130 | Ipaddr.V4.of_string_exn "4.5.6.7"; 131 | Ipaddr.V4.of_string_exn "5.6.7.8"; 132 | Ipaddr.V4.of_string_exn "6.7.8.9"; 133 | Ipaddr.V4.of_string_exn "220.220.220.220"; 134 | ] 135 | ] 136 | } in 137 | let serialized = buf_of_pkt pkt in 138 | match pkt_of_buf serialized (Cstruct.length serialized) with 139 | | Error e -> failwith e 140 | | Ok deserialized -> assert (pkt = deserialized) 141 | 142 | let make_simple_config = 143 | Config.make 144 | ~hostname:"Duder DHCP server!" 145 | ~default_lease_time:(60 * 60 * 1) 146 | ~max_lease_time:(60 * 60 * 10) 147 | ~addr_tuple:(ip_t, mac_t) 148 | ~network:(Ipaddr.V4.Prefix.make 24 ip_t) 149 | ~range:(Some range_t) 150 | 151 | (* Check if 3 lease timers are present and are what we expect. *) 152 | let assert_timers options = 153 | let () = match find_ip_lease_time options with 154 | | None -> failwith "no Ip_lease_time found" 155 | | Some x -> assert (x = Int32.of_int 3600) 156 | in 157 | let () = match find_renewal_t1 options with 158 | | None -> failwith "no Renewal_t1 found" 159 | | Some x -> assert (x = Int32.of_int 1800) 160 | in 161 | match find_rebinding_t2 options with 162 | | None -> failwith "no Rebinding_t2 found" 163 | | Some x -> assert (x = Int32.of_int 2880) 164 | 165 | let t_simple_config () = 166 | let config = make_simple_config ~hosts:[] ~options:[] () in 167 | assert ((List.length config.Config.options) = 1); 168 | 169 | let config = make_simple_config ~hosts:[] ~options:[Routers [ip_t; ip2_t]; ] () in 170 | assert ((List.length config.Config.options) = 2); 171 | match List.hd config.Config.options with 172 | | Subnet_mask _ -> () 173 | | _ -> failwith "Subnet mask expected as first option" 174 | 175 | let t_bad_options () = 176 | let ok = try 177 | ignore @@ make_simple_config ~hosts:[] 178 | ~options:[Renewal_t1 Int32.max_int] (); 179 | false 180 | with 181 | Invalid_argument _ -> true 182 | in 183 | if not ok then 184 | failwith "user cannot request renewal via options"; 185 | let ok = try 186 | ignore @@ make_simple_config ~hosts:[] 187 | ~options:[Rebinding_t2 Int32.max_int] (); 188 | false 189 | with 190 | Invalid_argument _ -> true 191 | in 192 | if not ok then 193 | failwith "user cannot request rebinding via options"; 194 | let ok = try 195 | ignore @@ make_simple_config ~hosts:[] 196 | ~options:[Ip_lease_time Int32.max_int] (); 197 | false 198 | with 199 | Invalid_argument _ -> true 200 | in 201 | if not ok then 202 | failwith "can't request ip lease time via options" 203 | 204 | let t_bad_junk_padding_config () = 205 | let ok = try 206 | ignore @@ make_simple_config ~hosts:[] ~options:[ 207 | Subnet_mask mask_t; 208 | End; (* Should not allow end in configuration *) 209 | Pad; (* Should not allow pad in configuration *) 210 | Client_id (Id (0, "The dude")); 211 | ] (); 212 | false 213 | with 214 | Invalid_argument _ -> true 215 | in 216 | if not ok then 217 | failwith "can't insert padding and random numbers via options" 218 | 219 | let t_collect_replies () = 220 | let config = make_simple_config ~hosts:[] 221 | ~options:[Routers [ip_t; ip2_t]; 222 | Dns_servers [ip_t]; 223 | Domain_name "wololo"; 224 | Pop3_servers [ip_t; ip2_t]; 225 | Max_message 1200] () 226 | in 227 | let requests = [DNS_SERVERS; ROUTERS; DOMAIN_NAME; 228 | POP3_SERVERS; SUBNET_MASK; MAX_MESSAGE; RENEWAL_T1] 229 | in 230 | (* RENEWAL_T1 is ignored, so replies length should be - 1 *) 231 | let replies = Dhcp_server.Input.collect_replies_test config mac_t requests in 232 | assert ((List.length replies) = ((List.length requests) - 1)); 233 | let () = match List.hd replies with 234 | | Subnet_mask _ -> () 235 | | _ -> failwith "Subnet mask expected as first option" 236 | in 237 | assert ((List.length replies) = (List.length requests) - 1); 238 | assert ((collect_routers replies) = [ip_t; ip2_t]); 239 | assert ((collect_dns_servers replies) = [ip_t]); 240 | assert ((find_domain_name replies) = Some "wololo"); 241 | assert ((collect_pop3_servers replies) = [ip_t; ip2_t]); 242 | assert ((find_max_message replies) = Some 1200) 243 | 244 | let t_host_options () = 245 | let open Dhcp_server.Config in 246 | let host = { 247 | hostname = "bubbles.trailer.park.boys"; 248 | options = [ 249 | Dns_servers [ip4_t]; 250 | Routers [ip3_t]; 251 | Dns_servers []; (* Must be ignored *) 252 | Max_message 1400; 253 | Routers [ip5_t]; 254 | Log_servers [ip5_t]; 255 | Irc_servers [ip_t]; (* Won't ask must not be present *) 256 | Other (157, "\003"); (* Won't ask must not be present *) 257 | ]; 258 | fixed_addr = None; 259 | hw_addr = mac_t 260 | } 261 | in 262 | let config = make_simple_config ~hosts:[host] 263 | ~options:[Routers [ip_t; ip2_t]; 264 | Dns_servers [ip_t]; 265 | Domain_name "wololo"; 266 | Pop3_servers [ip_t; ip2_t]; 267 | Max_message 1200] 268 | () 269 | in 270 | let requests = [DNS_SERVERS; ROUTERS; DOMAIN_NAME; 271 | POP3_SERVERS; SUBNET_MASK; MAX_MESSAGE; RENEWAL_T1; LOG_SERVERS] 272 | in 273 | let replies = Dhcp_server.Input.collect_replies_test config mac_t requests in 274 | assert ((collect_routers replies) = [ip3_t; ip5_t; ip_t; ip2_t]); 275 | assert ((collect_dns_servers replies) = [ip4_t; ip_t]); 276 | assert ((collect_log_servers replies) = [ip5_t]); 277 | assert ((collect_irc_servers replies) = []); 278 | assert ((find_other 157 replies) = None); 279 | assert ((find_max_message replies) = (Some 1400)) 280 | 281 | let discover_pkt = { 282 | srcmac = mac2_t; 283 | dstmac = mac_t; 284 | srcip = Ipaddr.V4.any; 285 | dstip = Ipaddr.V4.broadcast; 286 | srcport = client_port; 287 | dstport = server_port; 288 | op = BOOTREQUEST; 289 | htype = Ethernet_10mb; 290 | hlen = 6; 291 | hops = 0; 292 | xid = Int32.of_int 0xabacabb; 293 | secs = 0; 294 | flags = Unicast; 295 | ciaddr = Ipaddr.V4.any; 296 | yiaddr = Ipaddr.V4.any; 297 | siaddr = Ipaddr.V4.any; 298 | giaddr = Ipaddr.V4.any; 299 | chaddr = mac_t; 300 | sname = ""; 301 | file = ""; 302 | options = [ 303 | Message_type DHCPDISCOVER; 304 | Client_id (Id (0, "W.Sobchak")); 305 | Parameter_requests [ 306 | DNS_SERVERS; NIS_SERVERS; ROUTERS; DOMAIN_NAME; 307 | POP3_SERVERS; SUBNET_MASK; DEFAULT_IP_TTL; 308 | ARP_CACHE_TIMO 309 | ] 310 | ] 311 | } 312 | 313 | let t_discover fixed = 314 | let open Dhcp_server.Config in 315 | let host = { 316 | hostname = "bubbles.trailer.park.boys"; 317 | options = []; 318 | fixed_addr = Some ip150_t; 319 | hw_addr = mac_t 320 | } 321 | in 322 | let hosts = if fixed then [host] else [] in 323 | let config = make_simple_config ~hosts:hosts 324 | ~options:[Routers [ip_t; ip2_t]; 325 | Dns_servers [ip_t]; 326 | Domain_name "Shut up Donnie !"; 327 | Pop3_servers [ip_t; ip2_t]; 328 | ] 329 | () 330 | in 331 | if verbose then 332 | Format.printf "\n%s\n%a\n%!" (yellow "<>") pp_pkt discover_pkt; 333 | match Input.input_pkt config (Lease.make_db ()) discover_pkt now with 334 | | Input.Reply (reply, db) -> 335 | assert (db = (Lease.make_db ())); 336 | assert (reply.srcmac = mac_t); 337 | assert (reply.dstmac = mac2_t); 338 | assert (reply.srcip = ip_t); 339 | assert (reply.dstip <> ip_t); 340 | assert (reply.dstip <> ip2_t); 341 | assert (reply.dstip <> Ipaddr.V4.any); 342 | assert (reply.srcport = server_port); 343 | assert (reply.dstport = client_port); 344 | assert (reply.op = BOOTREPLY); 345 | assert (reply.htype = Ethernet_10mb); 346 | assert (reply.hlen = 6); 347 | assert (reply.hops = 0); 348 | assert (reply.xid = Int32.of_int 0xabacabb); 349 | assert (reply.secs = 0); 350 | assert (reply.flags = Unicast); 351 | assert (reply.ciaddr = Ipaddr.V4.any); 352 | assert (reply.yiaddr <> Ipaddr.V4.any); 353 | assert (reply.yiaddr = reply.dstip); 354 | if fixed then 355 | assert (reply.yiaddr = ip150_t) 356 | else 357 | assert (addr_in_range reply.yiaddr range_t); 358 | assert (reply.siaddr = ip_t); 359 | assert (reply.giaddr = Ipaddr.V4.any); 360 | assert (reply.sname = "Duder DHCP server!"); 361 | assert (reply.file = ""); 362 | (* 5 options are included regardless of parameter requests. *) 363 | assert ((List.length reply.options) = (5 + 5)); 364 | let () = match List.hd reply.options with 365 | | Message_type x -> assert (x = DHCPOFFER); 366 | | _ -> failwith "First option is not Message_type" 367 | in 368 | assert_timers reply.options; 369 | (* Check if both router options are present, and the order matches *) 370 | let routers = collect_routers reply.options in 371 | assert ((List.length routers) = 2); 372 | assert ((List.hd routers) = ip_t); 373 | if verbose then 374 | Format.printf "%s\n%a\n%!" (yellow "<>") pp_pkt reply; 375 | | _ -> failwith "No reply" 376 | 377 | let t_discover_range () = t_discover false 378 | let t_discover_fixed () = t_discover true 379 | 380 | let t_discover_no_range () = 381 | let config = Config.make 382 | ~hostname:"Duder DHCP server!" 383 | ~default_lease_time:(60 * 60 * 1) 384 | ~max_lease_time:(60 * 60 * 10) 385 | ~addr_tuple:(ip_t, mac_t) 386 | ~network:(Ipaddr.V4.Prefix.make 24 ip_t) 387 | ~hosts:[] 388 | ~range:None 389 | ~options:[Routers [ip_t; ip2_t]; 390 | Dns_servers [ip_t]; 391 | Domain_name "Shut up Donnie !"; 392 | Pop3_servers [ip_t; ip2_t]; 393 | ] 394 | () 395 | in 396 | if verbose then 397 | Format.printf "\n%s\n%a\n%!" (yellow "<>") pp_pkt discover_pkt; 398 | match Input.input_pkt config (Lease.make_db ()) discover_pkt now with 399 | | Dhcp_server.Input.Warning s -> if s <> "No ips left to offer" then 400 | failwith "expected string `'No ips left to offer`'" 401 | | _ -> failwith "No reply" 402 | 403 | let t_discover_no_range_fixed () = 404 | let open Dhcp_server.Config in 405 | let host = { 406 | hostname = "bubbles.trailer.park.boys"; 407 | options = []; 408 | fixed_addr = Some ip150_t; 409 | hw_addr = mac_t 410 | } 411 | in 412 | let config = Config.make 413 | ~hostname:"Duder DHCP server!" 414 | ~default_lease_time:(60 * 60 * 1) 415 | ~max_lease_time:(60 * 60 * 10) 416 | ~addr_tuple:(ip_t, mac_t) 417 | ~network:(Ipaddr.V4.Prefix.make 24 ip_t) 418 | ~hosts:[host] 419 | ~range:None 420 | ~options:[Routers [ip_t; ip2_t]; 421 | Dns_servers [ip_t]; 422 | Domain_name "Shut up Donnie !"; 423 | Pop3_servers [ip_t; ip2_t]; 424 | ] 425 | () 426 | in 427 | if verbose then 428 | Format.printf "\n%s\n%a\n%!" (yellow "<>") pp_pkt discover_pkt; 429 | match Input.input_pkt config (Lease.make_db ()) discover_pkt now with 430 | | Input.Reply (reply, db) -> 431 | assert (db = (Lease.make_db ())); 432 | assert (reply.srcmac = mac_t); 433 | assert (reply.dstmac = mac2_t); 434 | assert (reply.srcip = ip_t); 435 | assert (reply.dstip <> ip_t); 436 | assert (reply.dstip <> ip2_t); 437 | assert (reply.dstip <> Ipaddr.V4.any); 438 | assert (reply.srcport = server_port); 439 | assert (reply.dstport = client_port); 440 | assert (reply.op = BOOTREPLY); 441 | assert (reply.htype = Ethernet_10mb); 442 | assert (reply.hlen = 6); 443 | assert (reply.hops = 0); 444 | assert (reply.xid = Int32.of_int 0xabacabb); 445 | assert (reply.secs = 0); 446 | assert (reply.flags = Unicast); 447 | assert (reply.ciaddr = Ipaddr.V4.any); 448 | assert (reply.yiaddr <> Ipaddr.V4.any); 449 | assert (reply.yiaddr = reply.dstip); 450 | assert (reply.yiaddr = ip150_t); 451 | assert (reply.siaddr = ip_t); 452 | assert (reply.giaddr = Ipaddr.V4.any); 453 | assert (reply.sname = "Duder DHCP server!"); 454 | assert (reply.file = ""); 455 | (* 5 options are included regardless of parameter requests. *) 456 | assert ((List.length reply.options) = (5 + 5)); 457 | let () = match List.hd reply.options with 458 | | Message_type x -> assert (x = DHCPOFFER); 459 | | _ -> failwith "First option is not Message_type" 460 | in 461 | assert_timers reply.options; 462 | (* Check if both router options are present, and the order matches *) 463 | let routers = collect_routers reply.options in 464 | assert ((List.length routers) = 2); 465 | assert ((List.hd routers) = ip_t); 466 | if verbose then 467 | Format.printf "%s\n%a\n%!" (yellow "<>") pp_pkt reply; 468 | | _ -> failwith "No reply" 469 | 470 | let t_bad_discover () = 471 | let config = make_simple_config ~hosts:[] 472 | ~options:[Routers [ip_t; ip2_t]; 473 | Dns_servers [ip_t]; 474 | Domain_name "The Dude"; 475 | Pop3_servers [ip_t; ip2_t]; 476 | ] 477 | () 478 | in 479 | let bad_discover = { 480 | srcmac = mac2_t; 481 | dstmac = Macaddr.of_string_exn "cc:cc:cc:cc:cc:cc"; 482 | srcip = Ipaddr.V4.any; 483 | dstip = Ipaddr.V4.broadcast; 484 | srcport = client_port; 485 | dstport = server_port; 486 | op = BOOTREQUEST; 487 | htype = Ethernet_10mb; 488 | hlen = 6; 489 | hops = 0; 490 | xid = Int32.of_int 0xabacabb; 491 | secs = 0; 492 | flags = Unicast; 493 | ciaddr = Ipaddr.V4.any; 494 | yiaddr = Ipaddr.V4.any; 495 | siaddr = Ipaddr.V4.any; 496 | giaddr = Ipaddr.V4.any; 497 | chaddr = mac_t; 498 | sname = ""; 499 | file = ""; 500 | options = [ 501 | Message_type DHCPDISCOVER; 502 | Client_id (Id (0, "W.Sobchak")); 503 | Parameter_requests [ 504 | DNS_SERVERS; NIS_SERVERS; ROUTERS; DOMAIN_NAME; 505 | POP3_SERVERS; SUBNET_MASK; DEFAULT_IP_TTL; 506 | ARP_CACHE_TIMO 507 | ] 508 | ] 509 | } 510 | in 511 | match Input.input_pkt config (Lease.make_db ()) bad_discover now with 512 | | Input.Silence -> () 513 | | _ -> failwith "This packet was not for us, should be Silence" 514 | 515 | let request_nak_pkt = { 516 | srcmac = mac2_t; 517 | dstmac = mac_t; 518 | srcip = Ipaddr.V4.any; 519 | dstip = Ipaddr.V4.broadcast; 520 | srcport = client_port; 521 | dstport = server_port; 522 | op = BOOTREQUEST; 523 | htype = Ethernet_10mb; 524 | hlen = 6; 525 | hops = 0; 526 | xid = Int32.of_int 0xabacabb; 527 | secs = 0; 528 | flags = Broadcast; (* Request a broadcast answer *) 529 | ciaddr = Ipaddr.V4.any; 530 | yiaddr = Ipaddr.V4.any; 531 | siaddr = Ipaddr.V4.any; 532 | giaddr = Ipaddr.V4.any; 533 | chaddr = mac_t; 534 | sname = ""; 535 | file = ""; 536 | options = [ 537 | Message_type DHCPREQUEST; 538 | Client_id (Id (0, "The Dude")); 539 | Parameter_requests [ 540 | DNS_SERVERS; NIS_SERVERS; ROUTERS; DOMAIN_NAME; 541 | POP3_SERVERS; SUBNET_MASK; DEFAULT_IP_TTL; 542 | ARP_CACHE_TIMO 543 | ]; 544 | Request_ip ip55_t; 545 | Server_identifier ip_t; 546 | ] 547 | } 548 | 549 | 550 | let t_request_fixed () = 551 | let open Dhcp_server.Config in 552 | let host = { 553 | hostname = "bubbles.trailer.park.boys"; 554 | options = []; 555 | fixed_addr = Some ip150_t; 556 | hw_addr = mac_t 557 | } 558 | in 559 | let config = make_simple_config 560 | ~hosts:[host] 561 | ~options:[Routers [ip_t; ip2_t]; 562 | Dns_servers [ip_t]; 563 | Domain_name "Shut up Donnie !"; 564 | Pop3_servers [ip_t; ip2_t]; 565 | ] 566 | () 567 | in 568 | let request = { 569 | srcmac = mac2_t; 570 | dstmac = mac_t; 571 | srcip = Ipaddr.V4.any; 572 | dstip = Ipaddr.V4.broadcast; 573 | srcport = client_port; 574 | dstport = server_port; 575 | op = BOOTREQUEST; 576 | htype = Ethernet_10mb; 577 | hlen = 6; 578 | hops = 0; 579 | xid = Int32.of_int 0xabacabb; 580 | secs = 0; 581 | flags = Broadcast; (* Request a broadcast answer *) 582 | ciaddr = Ipaddr.V4.any; 583 | yiaddr = Ipaddr.V4.any; 584 | siaddr = Ipaddr.V4.any; 585 | giaddr = Ipaddr.V4.any; 586 | chaddr = mac_t; 587 | sname = ""; 588 | file = ""; 589 | options = [ 590 | Message_type DHCPREQUEST; 591 | Client_id (Id (0, "W.Sobchak")); 592 | Parameter_requests [ 593 | DNS_SERVERS; NIS_SERVERS; ROUTERS; DOMAIN_NAME; 594 | POP3_SERVERS; SUBNET_MASK; DEFAULT_IP_TTL; 595 | ARP_CACHE_TIMO 596 | ]; 597 | Request_ip ip150_t; 598 | Server_identifier ip_t; 599 | ] 600 | } 601 | in 602 | if verbose then 603 | Format.printf "\n%s\n%a\n%!" (yellow "<>") pp_pkt request; 604 | let db = 605 | match Input.input_pkt config (Lease.make_db ()) request now with 606 | | Input.Reply (reply, db) -> 607 | (* Fixed leases are mocked up, database should be unchanged *) 608 | assert (db = (Lease.make_db ())); 609 | let () = 610 | match Lease.lease_of_client_id (Id (0, "W.Sobchak")) db with 611 | | None -> () (* good, lease is not there. *) 612 | | Some _l -> failwith "Found a fixed lease, bad juju." 613 | in 614 | assert (reply.srcmac = mac_t); 615 | assert (reply.dstmac = Macaddr.broadcast); 616 | assert (reply.srcip = ip_t); 617 | assert (reply.dstip = Ipaddr.V4.broadcast); 618 | assert (reply.srcport = server_port); 619 | assert (reply.dstport = client_port); 620 | assert (reply.op = BOOTREPLY); 621 | assert (reply.htype = Ethernet_10mb); 622 | assert (reply.hlen = 6); 623 | assert (reply.hops = 0); 624 | assert (reply.xid = Int32.of_int 0xabacabb); 625 | assert (reply.secs = 0); 626 | assert (reply.flags = Broadcast); (* Not required by RFC2131 section 4.1 *) 627 | assert (reply.ciaddr = Ipaddr.V4.any); 628 | assert (reply.yiaddr = ip150_t); 629 | assert (reply.siaddr = ip_t); 630 | assert (reply.giaddr = Ipaddr.V4.any); 631 | assert (reply.sname = "Duder DHCP server!"); 632 | assert (reply.file = ""); 633 | (* 5 options are included regardless of parameter requests. *) 634 | assert ((List.length reply.options) = (5 + 5)); 635 | let () = match List.hd reply.options with 636 | | Message_type x -> assert (x = DHCPACK); 637 | | _ -> failwith "First option is not Message_type" 638 | in 639 | assert_timers reply.options; 640 | (* Server identifier must be there. *) 641 | assert (List.exists (function Server_identifier _ -> true | _ -> false) 642 | reply.options); 643 | (* Check if both router options are present, and the order matches *) 644 | let routers = collect_routers reply.options in 645 | assert ((List.length routers) = 2); 646 | assert ((List.hd routers) = ip_t); 647 | if verbose then 648 | Format.printf "%s\n%a\n%!" (yellow "<>") pp_pkt reply; 649 | db 650 | | _ -> failwith "No reply" 651 | in 652 | (* Build a second request from a different client, we should get a NAK. *) 653 | let request = request_nak_pkt in 654 | match Input.input_pkt config db request now with 655 | | Input.Reply (reply, odb) -> 656 | assert (db = odb); 657 | assert ((List.length reply.options) = 4); 658 | let () = match List.hd reply.options with 659 | | Message_type x -> assert (x = DHCPNAK); 660 | | _ -> failwith "First option is not Message_type" 661 | in 662 | if verbose then 663 | Format.printf "%s\n%a\n%!" (yellow "<>") pp_pkt reply; 664 | | _ -> failwith "No reply" 665 | 666 | let t_request () = 667 | let config = make_simple_config ~hosts:[] 668 | ~options:[Routers [ip_t; ip2_t]; 669 | Dns_servers [ip_t]; 670 | Domain_name "Shut up Donnie !"; 671 | Pop3_servers [ip_t; ip2_t]; 672 | ] 673 | () 674 | in 675 | let request = { 676 | srcmac = mac2_t; 677 | dstmac = mac_t; 678 | srcip = Ipaddr.V4.any; 679 | dstip = Ipaddr.V4.broadcast; 680 | srcport = client_port; 681 | dstport = server_port; 682 | op = BOOTREQUEST; 683 | htype = Ethernet_10mb; 684 | hlen = 6; 685 | hops = 0; 686 | xid = Int32.of_int 0xabacabb; 687 | secs = 0; 688 | flags = Broadcast; (* Request a broadcast answer *) 689 | ciaddr = Ipaddr.V4.any; 690 | yiaddr = Ipaddr.V4.any; 691 | siaddr = Ipaddr.V4.any; 692 | giaddr = Ipaddr.V4.any; 693 | chaddr = mac_t; 694 | sname = ""; 695 | file = ""; 696 | options = [ 697 | Message_type DHCPREQUEST; 698 | Client_id (Id (0, "W.Sobchak")); 699 | Parameter_requests [ 700 | DNS_SERVERS; NIS_SERVERS; ROUTERS; DOMAIN_NAME; 701 | POP3_SERVERS; SUBNET_MASK; DEFAULT_IP_TTL; 702 | ARP_CACHE_TIMO 703 | ]; 704 | Request_ip ip55_t; 705 | Server_identifier ip_t; 706 | ] 707 | } 708 | in 709 | if verbose then 710 | Format.printf "\n%s\n%a\n%!" (yellow "<>") pp_pkt request; 711 | let db = 712 | match Input.input_pkt config (Lease.make_db ()) request now with 713 | | Input.Reply (reply, db) -> 714 | (* Check if our new lease is there *) 715 | assert (db <> (Lease.make_db ())); 716 | assert ((List.length (Lease.db_to_list db)) = 1); 717 | if verbose then 718 | printf "lease %s\n%!" (Lease.to_string (List.hd (Lease.db_to_list db))); 719 | let () = 720 | match Lease.lease_of_client_id (Id (0, "W.Sobchak")) db with 721 | | None -> failwith "Lease not found"; 722 | | Some l -> 723 | let open Dhcp_server.Lease in 724 | assert (l.client_id = (Id (0, "W.Sobchak"))); 725 | assert (not (expired l ~now)); 726 | assert (l.tm_start <= now); 727 | assert (l.tm_end >= now); 728 | assert ((Lease.timeleft l ~now) <= (Int32.of_int 3600)); 729 | assert ((Lease.timeleft l ~now) >= (Int32.of_int 3599)); 730 | in 731 | assert (reply.srcmac = mac_t); 732 | assert (reply.dstmac = Macaddr.broadcast); 733 | assert (reply.srcip = ip_t); 734 | assert (reply.dstip = Ipaddr.V4.broadcast); 735 | assert (reply.srcport = server_port); 736 | assert (reply.dstport = client_port); 737 | assert (reply.op = BOOTREPLY); 738 | assert (reply.htype = Ethernet_10mb); 739 | assert (reply.hlen = 6); 740 | assert (reply.hops = 0); 741 | assert (reply.xid = Int32.of_int 0xabacabb); 742 | assert (reply.secs = 0); 743 | assert (reply.flags = Broadcast); (* Not required by RFC2131 section 4.1 *) 744 | assert (reply.ciaddr = Ipaddr.V4.any); 745 | assert (reply.yiaddr <> Ipaddr.V4.any); 746 | assert (addr_in_range reply.yiaddr range_t); 747 | assert (reply.siaddr = ip_t); 748 | assert (reply.giaddr = Ipaddr.V4.any); 749 | assert (reply.sname = "Duder DHCP server!"); 750 | assert (reply.file = ""); 751 | (* 5 options are included regardless of parameter requests. *) 752 | assert ((List.length reply.options) = (5 + 5)); 753 | let () = match List.hd reply.options with 754 | | Message_type x -> assert (x = DHCPACK); 755 | | _ -> failwith "First option is not Message_type" 756 | in 757 | assert_timers reply.options; 758 | (* Server identifier must be there. *) 759 | assert (List.exists (function Server_identifier _ -> true | _ -> false) 760 | reply.options); 761 | (* Check if both router options are present, and the order matches *) 762 | let routers = collect_routers reply.options in 763 | assert ((List.length routers) = 2); 764 | assert ((List.hd routers) = ip_t); 765 | if verbose then 766 | Format.printf "%s\n%a\n%!" (yellow "<>") pp_pkt reply; 767 | db 768 | | _ -> failwith "No reply" 769 | in 770 | 771 | (* Build a second request from a different client, we should get a NAK. *) 772 | let request = request_nak_pkt in 773 | match Input.input_pkt config db request now with 774 | | Input.Reply (reply, odb) -> 775 | assert (db = odb); 776 | assert ((List.length reply.options) = 4); 777 | let () = match List.hd reply.options with 778 | | Message_type x -> assert (x = DHCPNAK); 779 | | _ -> failwith "First option is not Message_type" 780 | in 781 | if verbose then 782 | Format.printf "%s\n%a\n%!" (yellow "<>") pp_pkt reply; 783 | | _ -> failwith "No reply" 784 | 785 | let t_request_no_range () = 786 | let config = Config.make 787 | ~hostname:"Duder DHCP server!" 788 | ~default_lease_time:(60 * 60 * 1) 789 | ~max_lease_time:(60 * 60 * 10) 790 | ~addr_tuple:(ip_t, mac_t) 791 | ~network:(Ipaddr.V4.Prefix.make 24 ip_t) 792 | ~hosts:[] 793 | ~range:None 794 | ~options:[Routers [ip_t; ip2_t]; 795 | Dns_servers [ip_t]; 796 | Domain_name "Shut up Donnie !"; 797 | Pop3_servers [ip_t; ip2_t]; 798 | ] 799 | () 800 | in 801 | let request = { 802 | srcmac = mac2_t; 803 | dstmac = mac_t; 804 | srcip = Ipaddr.V4.any; 805 | dstip = Ipaddr.V4.broadcast; 806 | srcport = client_port; 807 | dstport = server_port; 808 | op = BOOTREQUEST; 809 | htype = Ethernet_10mb; 810 | hlen = 6; 811 | hops = 0; 812 | xid = Int32.of_int 0xabacabb; 813 | secs = 0; 814 | flags = Broadcast; (* Request a broadcast answer *) 815 | ciaddr = Ipaddr.V4.any; 816 | yiaddr = Ipaddr.V4.any; 817 | siaddr = Ipaddr.V4.any; 818 | giaddr = Ipaddr.V4.any; 819 | chaddr = mac_t; 820 | sname = ""; 821 | file = ""; 822 | options = [ 823 | Message_type DHCPREQUEST; 824 | Client_id (Id (0, "W.Sobchak")); 825 | Parameter_requests [ 826 | DNS_SERVERS; NIS_SERVERS; ROUTERS; DOMAIN_NAME; 827 | POP3_SERVERS; SUBNET_MASK; DEFAULT_IP_TTL; 828 | ARP_CACHE_TIMO 829 | ]; 830 | Request_ip ip55_t; 831 | Server_identifier ip_t; 832 | ] 833 | } 834 | in 835 | if verbose then 836 | Format.printf "\n%s\n%a\n%!" (yellow "<>") pp_pkt request; 837 | match Input.input_pkt config (Lease.make_db ()) request now with 838 | | Dhcp_server.Input.Reply (reply, db) -> 839 | assert (db = (Lease.make_db ())); 840 | assert ((List.length reply.options) = 4); 841 | let () = match List.hd reply.options with 842 | | Message_type x -> assert (x = DHCPNAK); 843 | | _ -> failwith "First option is not Message_type" 844 | in 845 | let () = match find_message reply.options with 846 | | None -> failwith "No nice message for NAK" 847 | | Some m -> assert (m = "Requested address is not in subnet range") 848 | in () 849 | | _ -> failwith "Unexpected reply" 850 | 851 | let t_request_no_range_fixed () = 852 | let open Dhcp_server.Config in 853 | let host = { 854 | hostname = "bubbles.trailer.park.boys"; 855 | options = []; 856 | fixed_addr = Some ip150_t; 857 | hw_addr = mac_t 858 | } 859 | in 860 | let config = Config.make 861 | ~hostname:"Duder DHCP server!" 862 | ~default_lease_time:(60 * 60 * 1) 863 | ~max_lease_time:(60 * 60 * 10) 864 | ~addr_tuple:(ip_t, mac_t) 865 | ~network:(Ipaddr.V4.Prefix.make 24 ip_t) 866 | ~hosts:[host] 867 | ~range:None 868 | ~options:[Routers [ip_t; ip2_t]; 869 | Dns_servers [ip_t]; 870 | Domain_name "Shut up Donnie !"; 871 | Pop3_servers [ip_t; ip2_t]; 872 | ] 873 | () 874 | in 875 | let request = { 876 | srcmac = mac2_t; 877 | dstmac = mac_t; 878 | srcip = Ipaddr.V4.any; 879 | dstip = Ipaddr.V4.broadcast; 880 | srcport = client_port; 881 | dstport = server_port; 882 | op = BOOTREQUEST; 883 | htype = Ethernet_10mb; 884 | hlen = 6; 885 | hops = 0; 886 | xid = Int32.of_int 0xabacabb; 887 | secs = 0; 888 | flags = Broadcast; (* Request a broadcast answer *) 889 | ciaddr = Ipaddr.V4.any; 890 | yiaddr = Ipaddr.V4.any; 891 | siaddr = Ipaddr.V4.any; 892 | giaddr = Ipaddr.V4.any; 893 | chaddr = mac_t; 894 | sname = ""; 895 | file = ""; 896 | options = [ 897 | Message_type DHCPREQUEST; 898 | Client_id (Id (0, "W.Sobchak")); 899 | Parameter_requests [ 900 | DNS_SERVERS; NIS_SERVERS; ROUTERS; DOMAIN_NAME; 901 | POP3_SERVERS; SUBNET_MASK; DEFAULT_IP_TTL; 902 | ARP_CACHE_TIMO 903 | ]; 904 | Request_ip ip150_t; 905 | Server_identifier ip_t; 906 | ] 907 | } 908 | in 909 | if verbose then 910 | Format.printf "\n%s\n%a\n%!" (yellow "<>") pp_pkt request; 911 | match Input.input_pkt config (Lease.make_db ()) request now with 912 | | Input.Reply (reply, db) -> 913 | (* Check if our new lease is there *) 914 | assert (db = (Lease.make_db ())); 915 | let () = 916 | match Lease.lease_of_client_id (Id (0, "W.Sobchak")) db with 917 | | None -> () (* good, lease is not there. *) 918 | | Some _l -> failwith "Found a fixed lease, bad juju." 919 | in 920 | assert (reply.srcmac = mac_t); 921 | assert (reply.dstmac = Macaddr.broadcast); 922 | assert (reply.srcip = ip_t); 923 | assert (reply.dstip = Ipaddr.V4.broadcast); 924 | assert (reply.srcport = server_port); 925 | assert (reply.dstport = client_port); 926 | assert (reply.op = BOOTREPLY); 927 | assert (reply.htype = Ethernet_10mb); 928 | assert (reply.hlen = 6); 929 | assert (reply.hops = 0); 930 | assert (reply.xid = Int32.of_int 0xabacabb); 931 | assert (reply.secs = 0); 932 | assert (reply.flags = Broadcast); (* Not required by RFC2131 section 4.1 *) 933 | assert (reply.ciaddr = Ipaddr.V4.any); 934 | assert (reply.yiaddr = ip150_t); 935 | assert (not (addr_in_range reply.yiaddr range_t)); 936 | assert (reply.siaddr = ip_t); 937 | assert (reply.giaddr = Ipaddr.V4.any); 938 | assert (reply.sname = "Duder DHCP server!"); 939 | assert (reply.file = ""); 940 | (* 5 options are included regardless of parameter requests. *) 941 | assert ((List.length reply.options) = (5 + 5)); 942 | let () = match List.hd reply.options with 943 | | Message_type x -> assert (x = DHCPACK); 944 | | _ -> failwith "First option is not Message_type" 945 | in 946 | assert_timers reply.options; 947 | (* Server identifier must be there. *) 948 | assert (List.exists (function Server_identifier _ -> true | _ -> false) 949 | reply.options); 950 | (* Check if both router options are present, and the order matches *) 951 | let routers = collect_routers reply.options in 952 | assert ((List.length routers) = 2); 953 | assert ((List.hd routers) = ip_t); 954 | if verbose then 955 | Format.printf "%s\n%a\n%!" (yellow "<>") pp_pkt reply 956 | | _ -> failwith "No reply" 957 | 958 | let t_db_serialization () = 959 | let lease2 = Lease.make 960 | (Id (0, "Duderino")) ip2_t ~duration:(Int32.of_int 60) ~now in 961 | let lease3 = Lease.make 962 | (Id (0, "Walter")) ip3_t ~duration:(Int32.of_int 60) ~now in 963 | let lease4 = Lease.make 964 | (Id (0, "Donnie")) ip4_t ~duration:(Int32.of_int 60) ~now in 965 | let db0 = List.fold_left 966 | (fun db lease -> Lease.replace lease db) 967 | (Lease.make_db ()) [ lease2; lease3; lease4 ] 968 | in 969 | assert (Lease.db_equal db0 (Lease.db_to_string db0 |> Lease.db_of_string)) 970 | 971 | let to_alco test () = 972 | try 973 | test (); 974 | Alcotest.(check pass "" () ()) 975 | with e -> 976 | Alcotest.(check (fail (Printexc.to_string e)) "" () ()) 977 | 978 | let alco_tests () = 979 | Alcotest.run "server tests" [ 980 | "parsing", [ 981 | "option codes", `Quick, to_alco t_option_codes; 982 | "checksum", `Quick, to_alco t_csum; 983 | "long options lists", `Quick, to_alco t_long_lists; 984 | "pcap", `Quick, to_alco Pcap.t_pcap; 985 | "simple config", `Quick, to_alco t_simple_config; 986 | "renewal_t in opts", `Quick, to_alco t_bad_options; 987 | "padding in opts", `Quick, to_alco t_bad_junk_padding_config; 988 | "collect replies", `Quick, to_alco t_collect_replies; 989 | "host options", `Quick, to_alco t_host_options; 990 | "lease database serialization", `Quick, to_alco t_db_serialization; 991 | ]; 992 | "state progression", [ 993 | "discover->offer", `Quick, to_alco t_discover_range; 994 | "discover->offer fixed", `Quick, to_alco t_discover_fixed; 995 | "discover->offer no range", `Quick, to_alco t_discover_no_range; 996 | "discover->offer no range fixed", `Quick, to_alco t_discover_no_range_fixed; 997 | "wrong mac address", `Quick, to_alco t_bad_discover; 998 | "request->ack/nak", `Quick, to_alco t_request; 999 | "request->ack/nak fixed", `Quick, to_alco t_request_fixed; 1000 | "request->ack/nak no range", `Quick, to_alco t_request_no_range; 1001 | "request->ack/nak no range fixed", `Quick, to_alco t_request_no_range_fixed; 1002 | ]; 1003 | ] 1004 | 1005 | let _ = alco_tests () 1006 | -------------------------------------------------------------------------------- /unix/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 | (* Drop privileges and chroot to _charruad home *) 23 | let go_safe user group = 24 | let (pw, _gr) = try 25 | (Unix.getpwnam user, Unix.getgrnam group) 26 | with _ -> 27 | failwith "No user and/or group _charruad found, please create them." 28 | in 29 | Unix.chroot pw.Unix.pw_dir; 30 | Unix.chdir "/"; 31 | (* Unix.setproctitle "charruad"; XXX implement me *) 32 | let ogid = Unix.getgid () in 33 | let oegid = Unix.getegid () in 34 | let ouid = Unix.getuid () in 35 | let oeuid = Unix.geteuid () in 36 | Unix.setgroups (Array.of_list [pw.Unix.pw_gid]); 37 | Unix.setgid pw.Unix.pw_gid; 38 | Unix.setuid pw.Unix.pw_uid; 39 | if ogid = pw.Unix.pw_gid || 40 | oegid = pw.Unix.pw_gid || 41 | ouid = pw.Unix.pw_uid || 42 | oeuid = pw.Unix.pw_uid then 43 | failwith "Unexpected uid or gid after dropping privileges"; 44 | (* Make sure we cant restore the old gid and uid *) 45 | let canrestore = try 46 | Unix.setuid ouid; 47 | Unix.setuid oeuid; 48 | Unix.setgid ogid; 49 | Unix.setgid oegid; 50 | true 51 | with _ -> false in 52 | if canrestore then 53 | failwith "Was able to restore UID, setuid is broken" 54 | 55 | let read_file f = 56 | let ic = open_in f in 57 | let n = in_channel_length ic in 58 | let buf = Bytes.create n in 59 | really_input ic buf 0 n; 60 | close_in ic; 61 | Bytes.to_string buf 62 | 63 | let go_daemon () = 64 | Lwt_daemon.daemonize ~syslog:false () 65 | 66 | let init_log vlevel daemon = 67 | Lwt_log_core.Section.(set_level main vlevel); 68 | Lwt_log.default := if daemon then 69 | Lwt_log.syslog 70 | ~template:"$(date) $(level) $(name)[$(pid)]: $(message)" 71 | ~facility:`Daemon 72 | ~paths:["/dev/log"; "/var/run/log"; "/var/run/syslog"] 73 | () 74 | else 75 | Lwt_log.channel 76 | ~template:"$(date) $(level): $(message)" 77 | ~close_mode:`Keep 78 | ~channel:Lwt_io.stdout 79 | () 80 | 81 | let uptime_in_sec () = 82 | Duration.to_sec (Mtime_clock.elapsed_ns ()) 83 | 84 | let maybe_gc db now gbcol = 85 | let open Lwt in 86 | if (now - gbcol) >= 60 then 87 | Lwt_log.debug "Garbage collecting..." >>= fun () -> 88 | return (Dhcp_server.Lease.garbage_collect db ~now:(Int32.of_int now), now + 60) 89 | else 90 | return (db, gbcol) 91 | 92 | let rec input config db link gbcol = 93 | let open Dhcp_server.Input in 94 | let open Lwt in 95 | 96 | Lwt_rawlink.read_packet link 97 | >>= fun buf -> 98 | let now = uptime_in_sec () in 99 | maybe_gc db now gbcol 100 | >>= fun (db, gbcol) -> 101 | let t = match Dhcp_wire.pkt_of_buf buf (Cstruct.length buf) with 102 | | Error e -> Lwt_log.error e 103 | >>= fun () -> 104 | return db 105 | | Ok pkt -> 106 | Logs.debug (fun m -> m "Received packet: %a" Dhcp_wire.pp_pkt pkt); 107 | match (input_pkt config db pkt (Int32.of_int now)) with 108 | | Silence -> return db 109 | | Update db -> return db 110 | | Reply (reply, db) -> 111 | Lwt_rawlink.send_packet link (Dhcp_wire.buf_of_pkt reply) >>= fun () -> 112 | Logs.debug (fun m -> m "Sent reply packet: %a" Dhcp_wire.pp_pkt reply); 113 | return db 114 | | Warning w -> 115 | Logs.warn (fun m -> m "%s" w); 116 | return db 117 | | Error e -> 118 | Logs.err (fun m -> m "%s" e); 119 | return db 120 | in 121 | t >>= fun db -> input config db link gbcol 122 | 123 | let ifname_of_address ip_addr interfaces = 124 | let ifnet = 125 | List.find 126 | (function _name, cidr -> 127 | Ipaddr.V4.compare ip_addr (Ipaddr.V4.Prefix.address cidr) = 0) 128 | interfaces 129 | in 130 | match ifnet with name, _ -> name 131 | 132 | let charruad () configfile group pidfile user daemonize = 133 | let open Dhcp_server.Config in 134 | let open Dhcp_server.Lease in 135 | let open Lwt in 136 | 137 | let interfaces = Tuntap.getifaddrs_v4 () in 138 | let addresses = List.map 139 | (function name, cidr -> (Ipaddr.V4.Prefix.address cidr, Tuntap.get_macaddr name)) 140 | interfaces 141 | in 142 | let configtxt = read_file configfile in 143 | (* let config = parse configtxt addresses in *) 144 | let db = make_db () in 145 | if daemonize then 146 | go_daemon (); 147 | Lwt_log.ign_notice "Charrua DHCPD starting"; 148 | (* Filter out the addresses which have networks assigned *) 149 | let threads = filter_map 150 | (fun addr_tuple -> 151 | let addr = fst addr_tuple in 152 | let s = Ipaddr.V4.to_string addr in 153 | let config = try Some (parse configtxt addr_tuple) with Not_found -> None in 154 | match config with 155 | | Some config -> 156 | Lwt_log.ign_notice_f "Found network for %s" s; 157 | (* Get a rawlink on the interface *) 158 | let ifname = ifname_of_address addr interfaces in 159 | let link = Lwt_rawlink.(open_link ~filter:(dhcp_server_filter ()) ifname) in 160 | (* Create a thread *) 161 | Some (input config db link (uptime_in_sec ())) 162 | | None -> 163 | let () = Lwt_log.ign_debug_f "No network found for %s" s in 164 | None) 165 | addresses 166 | in 167 | if List.length threads = 0 then 168 | failwith "Could not match any interface address with any network section."; 169 | (* Open pidfile before dropping priviledges *) 170 | let pidc = open_out pidfile in 171 | go_safe user group; 172 | Printf.fprintf pidc "%d" (Unix.getpid ()); 173 | close_out pidc; 174 | Lwt_main.run (Lwt.pick threads >>= fun _ -> 175 | Lwt_log.notice "Charrua DHCPD exiting") 176 | 177 | (* Parse command line and start the ball *) 178 | 179 | let setup_log style_renderer level = 180 | Fmt_tty.setup_std_outputs ?style_renderer (); 181 | Logs.set_level level; 182 | Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ()) 183 | 184 | open Cmdliner 185 | 186 | let setup_log = 187 | Term.(const setup_log 188 | $ Fmt_cli.style_renderer () 189 | $ Logs_cli.level ()) 190 | 191 | let cmd = 192 | let configfile = Arg.(value & opt string "/etc/charruad.conf" & info ["c" ; "config"] 193 | ~doc:"Configuration file path.") in 194 | let group = Arg.(value & opt string "_charruad" & info ["g" ; "group"] 195 | ~doc:"Group to run as.") in 196 | let pidfile = Arg.(value & opt string "/run/charruad.pid" & info ["p" ; "pidfile"] 197 | ~doc:"Pid file path.") in 198 | let user = Arg.(value & opt string "_charruad" & info ["u" ; "user"] 199 | ~doc:"User to run as.") in 200 | let daemonize = Arg.(value & flag & info ["D" ; "daemon"] 201 | ~doc:"Daemonize.") in 202 | Cmd.v 203 | (Cmd.info "charruad" ~version:"%%VERSION%%" ~doc:"Charrua DHCPD") 204 | Term.(const charruad $ setup_log $ configfile $ group $ pidfile $ user $ daemonize) 205 | 206 | let () = exit (Cmd.eval cmd) 207 | -------------------------------------------------------------------------------- /unix/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name charruad) 3 | (modules charruad) 4 | (public_name charruad) 5 | (package charrua-unix) 6 | (libraries charrua charrua-server lwt.unix cstruct-lwt cstruct-unix cmdliner 7 | ipaddr tuntap rawlink-lwt mtime.clock.os logs duration lwt_log fmt.cli fmt.tty logs.fmt logs.cli)) 8 | --------------------------------------------------------------------------------