Skip to content

Commit

Permalink
Scrap rotten bits
Browse files Browse the repository at this point in the history 
Convert to latest OCaml, latest ocamldoc, latest bitstring lib, latest
qcheck, latest make and latest english.
  • Loading branch information
@rixed
rixed committed Feb 8, 2018
1 parent e48094f commit cc93ecd
Show file tree
Hide file tree
Showing 28 changed files with 485 additions and 428 deletions.
2 changes: 1 addition & 1 deletion META
View file
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
description = "poor man's network simulator"
version = "1"
requires = "bitstring bitstring.syntax batteries"
requires = "findlib bitstring bitstring.ppx batteries"
archive(byte) = "robinet.cma"
archive(native) = "robinet.cmxa"
20 changes: 11 additions & 9 deletions Makefile
View file
Original file line number Diff line number Diff line change
Expand Up @@ -60,8 +60,7 @@ EXAMPLES_BYTE = \
EXAMPLES_OPT = $(EXAMPLES_BYTE:.byte=.opt)
EXAMPLES = $(EXAMPLES_BYTE) $(EXAMPLES_OPT)

REQUIRES = bitstring bitstring.syntax batteries
SYNTAX=-syntax camlp4o
REQUIRES = bitstring bitstring.ppx batteries

include $(top_srcdir)make.common

Expand All @@ -72,21 +71,24 @@ all: robinet.top examples
run: robinet.top
rlwrap ./robinet.top -init robinet.init

$(EXAMPLES): $(ARCHIVE)
$(EXAMPLES_BYTE): $(ARCHIVE)
$(EXAMPLES_OPT): $(XARCHIVE)

$(CLIB): $(C_SOURCES:.c=.o)
$(AR) rcs $@ $^

examples: $(EXAMPLES)
@for f in $(EXAMPLES); do \
sudo setcap cap_net_raw,cap_net_admin=eip $$f ;\
done
@if which setcap >& /dev/null ; then \
for f in $(EXAMPLES); do \
sudo setcap cap_net_raw,cap_net_admin=eip $$f ;\
done ;\
fi

robinet.top: $(ARCHIVE)
$(OCAMLMKTOP) -o $@ -package "findlib,$(REQUIRES)" -linkpkg $(ARCHIVE)
sudo setcap cap_net_raw,cap_net_admin=eip $@
$(OCAMLMKTOP) -o $@ -package "findlib $(REQUIRES)" $(ARCHIVE)
@if which setcap >& /dev/null ; then \
sudo setcap cap_net_raw,cap_net_admin=eip $@ ;\
fi

clean-spec:
rm -f examples/*.cm[ioxa] examples/*.o $(EXAMPLES)

31 changes: 16 additions & 15 deletions arp.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -143,7 +143,7 @@ module Pdu = struct
make_reply hw_type proto_type sender_hw sender_proto (randbs 6) target_proto

let pack t =
(BITSTRING {
let%bitstring b = {|
(t.hw_type :> int) : 16 ;
(t.proto_type :> int) : 16 ;
(bitstring_length t.sender_hw)/8 : 8 ;
Expand All @@ -152,27 +152,28 @@ module Pdu = struct
t.sender_hw : -1 : bitstring ;
t.sender_proto : -1 : bitstring ;
t.target_hw : -1 : bitstring ;
t.target_proto : -1 : bitstring })

let unpack bits = bitmatch bits with
| { hw_type : 16 ;
proto_type : 16 ;
hw_len : 8 ;
proto_len : 8 ;
operation : 16 ;
sender_hw : hw_len*8 : bitstring ;
sender_proto : proto_len*8 : bitstring ;
target_hw : hw_len*8 : bitstring ;
target_proto : proto_len*8 : bitstring } ->
t.target_proto : -1 : bitstring |}
in b

let unpack bits = match%bitstring bits with
| {| hw_type : 16 ;
proto_type : 16 ;
hw_len : 8 ;
proto_len : 8 ;
operation : 16 ;
sender_hw : hw_len*8 : bitstring ;
sender_proto : proto_len*8 : bitstring ;
target_hw : hw_len*8 : bitstring ;
target_proto : proto_len*8 : bitstring |} ->
Some { hw_type = HwType.o hw_type ;
proto_type = HwProto.o proto_type ;
operation = Op.o operation ;
sender_hw ; sender_proto ;
target_hw ; target_proto }
| { _ } ->
| {| _ |} ->
err "Not ARP"
(*$Q pack
((random %> pack), dump) (fun t -> t = pack (Option.get (unpack t)))
(Q.make (fun _ -> random () |> pack)) (fun t -> t = pack (Option.get (unpack t)))
*)
(*$>*)
end
Expand Down
15 changes: 12 additions & 3 deletions clock.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -73,19 +73,23 @@ end = struct

(** Adds a time and an interval. *)
let add (t : t) (i : Interval.t) = o ((t :> float) +. (i :> float))

(** Substract two time and returns an interval. *)
let sub (a : t) (b : t) = Interval.o ((a :> float) -. (b :> float))

(** Get the current wall clock (through {Unix.gettimeofday}). *)
let wall_clock () = o (Unix.gettimeofday ())

(** Convert a timestamp to a pair of ints with seconds, microseconds *)
let to_ints (t : t) =
let t = (t :> float) in
let sec = Int.of_float t in
let usec = Int.of_float ((t -. (floor t)) *. 1_000_000.) in
sec, usec
end
(** While Interval.t reprensents a time interval.
* Both are floats internaly to match OCaml stdlib. *)

(** While Interval.t represents a time interval.
* Both are floats internally to match OCaml stdlib. *)
and Interval : sig
include PRIVATE_TYPE with type t = private float and type outer_t = float
val usec : float -> t
Expand All @@ -106,23 +110,28 @@ end = struct

(** microseconds to {Interval.t}. *)
let usec i = o (i *. 0.000001)

(** milliseconds to {Interval.t}. *)
let msec i = o (i *. 0.001)

(** seconds to {Interval.t}. *)
let sec i = o i

(** minutes to {Interval.t}. *)
let min i = o (i *. 60.)

(** hours to {Interval.t}. *)
let hour i = o (i *. 3600.)

(** Custom comparison function so that we can change time representation
* more easily in the future. *)
let compare (a : t) (b : t) = Float.compare (a :> float) (b :> float)

(** Adds two intervals. *)
let add (a : t) (b : t) = o ((a :> float) +. (b :> float))
end

(* poor man's asctime *)
(* Poor man's asctime *)
let printer oc t = BatIO.nwrite oc (Time.to_string t)

(** {2 Current running time} *)
Expand Down
112 changes: 57 additions & 55 deletions dhcp.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -95,79 +95,79 @@ struct
mutable client_id : bitstring option ;
mutable request_list : string option }

let rec unpack_options t bits = bitmatch bits with
| { 0 : 8 ;
rest : -1 : bitstring } -> unpack_options t rest
| { 255 : 8 } -> true
| { 1 : 8 ; 4 : 8 ; subnet_mask : 32 ;
rest : -1 : bitstring } ->
let rec unpack_options t bits = match%bitstring bits with
| {| 0 : 8 ;
rest : -1 : bitstring |} -> unpack_options t rest
| {| 255 : 8 |} -> true
| {| 1 : 8 ; 4 : 8 ; subnet_mask : 32 ;
rest : -1 : bitstring |} ->
t.subnet_mask <- Some (Ip.Addr.o32 subnet_mask) ;
unpack_options t rest
| { 3 : 8 ; len : 8 : check (len >= 4) ; ips : 8*len : bitstring ;
rest : -1 : bitstring } ->
| {| 3 : 8 ; len : 8 : check (len >= 4) ; ips : 8*len : bitstring ;
rest : -1 : bitstring |} ->
t.router <- Some (Ip.Addr.of_bitstring (takebits 32 ips)) ;
unpack_options t rest
| { 42 : 8 ; len : 8 : check (len >= 4) ; ips : 8*len : bitstring ;
rest : -1 : bitstring } ->
| {| 42 : 8 ; len : 8 : check (len >= 4) ; ips : 8*len : bitstring ;
rest : -1 : bitstring |} ->
t.ntp_server <- Some (Ip.Addr.of_bitstring (takebits 32 ips)) ;
unpack_options t rest
| { 69 : 8 ; len : 8 : check (len >= 4 && len land 3 = 0) ; ips : 8*len : bitstring ;
rest : -1 : bitstring } ->
| {| 69 : 8 ; len : 8 : check (len >= 4 && len land 3 = 0) ; ips : 8*len : bitstring ;
rest : -1 : bitstring |} ->
t.smtp_server <- Some (Ip.Addr.of_bitstring (takebits 32 ips)) ;
unpack_options t rest
| { 70 : 8 ; len : 8 : check (len >= 4 && len land 3 = 0) ; ips : 8*len : bitstring ;
rest : -1 : bitstring } ->
| {| 70 : 8 ; len : 8 : check (len >= 4 && len land 3 = 0) ; ips : 8*len : bitstring ;
rest : -1 : bitstring |} ->
t.pop3_server <- Some (Ip.Addr.of_bitstring (takebits 32 ips)) ;
unpack_options t rest
| { 6 : 8 ; len : 8 : check (len >= 4) ; ips : 8*len : bitstring ;
rest : -1 : bitstring } ->
| {| 6 : 8 ; len : 8 : check (len >= 4) ; ips : 8*len : bitstring ;
rest : -1 : bitstring |} ->
t.name_server <- Some (Ip.Addr.of_bitstring (takebits 32 ips)) ;
unpack_options t rest
| { 12 : 8 ; len : 8 : check (len >= 1) ; name : 8*len : string ;
rest : -1 : bitstring } ->
| {| 12 : 8 ; len : 8 : check (len >= 1) ; name : 8*len : string ;
rest : -1 : bitstring |} ->
t.client_name <- Some name ;
unpack_options t rest
| { 15 : 8 ; len : 8 : check (len >= 1) ; sfx : 8*len : string ;
rest : -1 : bitstring } ->
| {| 15 : 8 ; len : 8 : check (len >= 1) ; sfx : 8*len : string ;
rest : -1 : bitstring |} ->
t.search_sfx <- Some sfx ;
unpack_options t rest
| { 50 : 8 ; 4 : 8 ; req_ip : 32 ;
rest : -1 : bitstring } ->
| {| 50 : 8 ; 4 : 8 ; req_ip : 32 ;
rest : -1 : bitstring |} ->
t.requested_ip <- Some (Ip.Addr.o32 req_ip) ;
unpack_options t rest
| { 51 : 8 ; 4 : 8 ; lease : 32 ;
rest : -1 : bitstring } ->
| {| 51 : 8 ; 4 : 8 ; lease : 32 ;
rest : -1 : bitstring |} ->
t.lease_time <- Some lease ;
unpack_options t rest
| { 53 : 8 ; 1 : 8 ; msg_type : 8 : check (msg_type > 0 && msg_type < 9) ;
rest : -1 : bitstring } ->
| {| 53 : 8 ; 1 : 8 ; msg_type : 8 : check (msg_type > 0 && msg_type < 9) ;
rest : -1 : bitstring |} ->
t.msg_type <- Some (MsgType.o msg_type) ;
unpack_options t rest
| { 54 : 8 ; 4 : 8 ; ip : 32 ;
rest : -1 : bitstring } ->
| {| 54 : 8 ; 4 : 8 ; ip : 32 ;
rest : -1 : bitstring |} ->
t.server_id <- Some (Ip.Addr.o32 ip) ;
unpack_options t rest
| { 55 : 8 ; len : 8 : check (len > 0) ; params : 8*len : string ;
rest : -1 : bitstring } ->
| {| 55 : 8 ; len : 8 : check (len > 0) ; params : 8*len : string ;
rest : -1 : bitstring |} ->
t.request_list <- Some params ;
unpack_options t rest
| { 56 : 8 ; len : 8 : check (len > 0) ; msg : 8*len : string ;
rest : -1 : bitstring } ->
| {| 56 : 8 ; len : 8 : check (len > 0) ; msg : 8*len : string ;
rest : -1 : bitstring |} ->
t.message <- Some msg ;
unpack_options t rest
| { 61 : 8 ; len : 8 : check (len >= 2) ; id : 8*len : bitstring ;
rest : -1 : bitstring } ->
| {| 61 : 8 ; len : 8 : check (len >= 2) ; id : 8*len : bitstring ;
rest : -1 : bitstring |} ->
t.client_id <- Some id ;
unpack_options t rest
(* FIXME: IP Layer parameters setting could be interresting to get/set via DHCP.
(* FIXME: IP Layer parameters setting could be interesting to get/set via DHCP.
At least netmask *)
(* FIXME: handle option overload of file/sname fields with more options *)
| { _ : 8 ; len : 8 ; _ : 8*len ; rest : -1 : bitstring } ->
| {| _ : 8 ; len : 8 ; _ : 8*len ; rest : -1 : bitstring |} ->
unpack_options t rest
| { _ } -> false
| {| _ |} -> false

let unpack bits = bitmatch bits with
| { op : 8 : check (op = bootrequest || op = bootreply) ;
let unpack bits = match%bitstring bits with
| {| op : 8 : check (op = bootrequest || op = bootreply) ;
htype : 8 ; hlen : 8 ; hops : 8 ;
xid : 32 ; secs : 16 ;
flags : 16 : check (flags land 0x7fff = 0) ;
Expand All @@ -179,7 +179,7 @@ struct
sname : 64*8 : string ;
file : 128*8 : string ;
0x63825363l : 32 ;
options : -1 : bitstring } ->
options : -1 : bitstring |} ->
let t = { op = if op = bootrequest then BootRequest else BootReply ;
htype = Arp.HwType.o htype ; hlen ; hops ; xid ;
secs ; broadcast = flags land 0x8000 = 0x8000 ;
Expand All @@ -205,17 +205,17 @@ struct
request_list = None } in
if unpack_options t options then Some t
else err "Dhcp: Cannot decode options"
| { _ } -> err "Dhcp: Not DHCP"
| {| _ |} -> err "Dhcp: Not DHCP"

let pack_options t =
let may_pack_msgtyp t v = Option.map (fun (v : MsgType.t) -> (BITSTRING { t : 8 ; 1 : 8 ; (v :> int) : 8 })) v
and may_pack_int32 t v = Option.map (fun v -> (BITSTRING { t : 8 ; 4 : 8 ; v : 32 })) v
and may_pack_ip t v = Option.map (fun (v : Ip.Addr.t) -> (BITSTRING { t : 8 ; 4 : 8 ; (Ip.Addr.to_int32 v) : 32 })) v
and may_pack_string t v = Option.map (fun v -> (BITSTRING { t : 8 ; String.length v : 8 ; v : -1 : string })) v
and may_pack_bits t v = Option.map (fun v -> (BITSTRING { t : 8 ; bytelength v : 8 ; v : -1 : bitstring })) v
let may_pack_msgtyp t v = Option.map (fun (v : MsgType.t) -> let%bitstring b = {| t : 8 ; 1 : 8 ; (v :> int) : 8 |} in b) v
and may_pack_int32 t v = Option.map (fun v -> let%bitstring b = {| t : 8 ; 4 : 8 ; v : 32 |} in b) v
and may_pack_ip t v = Option.map (fun (v : Ip.Addr.t) -> let%bitstring b = {| t : 8 ; 4 : 8 ; (Ip.Addr.to_int32 v) : 32 |} in b) v
and may_pack_string t v = Option.map (fun v -> let%bitstring b = {| t : 8 ; String.length v : 8 ; v : -1 : string |} in b) v
and may_pack_bits t v = Option.map (fun v -> let%bitstring b = {| t : 8 ; bytelength v : 8 ; v : -1 : bitstring |} in b) v
in
List.enum [ may_pack_msgtyp 53 t.msg_type ;
may_pack_ip 1 t.subnet_mask ; (* must apear before router *)
may_pack_ip 1 t.subnet_mask ; (* must appear before router *)
may_pack_ip 3 t.router ;
may_pack_ip 42 t.ntp_server ;
may_pack_ip 69 t.smtp_server ;
Expand All @@ -229,7 +229,7 @@ struct
may_pack_string 56 t.message ;
may_pack_bits 61 t.client_id ;
may_pack_string 55 t.request_list ;
Some (BITSTRING { 255 : 8 }) ] //@
Some (let%bitstring b = {| 255 : 8 |} in b) ] //@
identity |>
List.of_enum |>
Bitstring.concat
Expand All @@ -240,7 +240,7 @@ struct
if l >= len then String.sub str 0 len
else str ^ (String.make (len-l) (Char.chr 0))
in
(BITSTRING {
let%bitstring b = {|
match t.op with BootRequest -> 1 | BootReply -> 2 : 8 ;
(t.htype :> int) : 8 ; t.hlen : 8 ; t.hops : 8 ;
t.xid : 32 ;
Expand All @@ -253,7 +253,7 @@ struct
string_extend t.sname 64 : 64*8 : string ;
string_extend t.file 128 : 128*8 : string ;
0x63825363l : 32 ;
pack_options t : -1 : bitstring })
pack_options t : -1 : bitstring |} in b

let make_base ?(mac=Eth.Addr.zero) ?xid ?name ?(yiaddr=Ip.Addr.zero) msg_type =
let xid = may_default xid (fun () -> Random.int32 Int32.max_int) in
Expand All @@ -279,9 +279,10 @@ struct

let make_discover ?(mac=Eth.Addr.zero) ?xid ?name () =
let t = make_base ~mac ?xid ?name MsgType.discover in
t.client_id <- Some (BITSTRING {
let%bitstring id = {|
(Arp.HwType.eth :> int) : 8 ;
(mac :> bitstring) : 6*8 : bitstring }) ;
(mac :> bitstring) : 6*8 : bitstring |} in
t.client_id <- Some id ;
t.request_list <- Some "\001\003\006\012\015\028\051\058\119" ;
t

Expand All @@ -292,9 +293,10 @@ struct

let make_request ?(mac=Eth.Addr.zero) ?xid ?name yiaddr server_id =
let t = make_base ~mac ?xid ?name MsgType.request in
t.client_id <- Some (BITSTRING {
let%bitstring id = {|
(Arp.HwType.eth :> int) : 8 ;
(mac :> bitstring) : 6*8 : bitstring }) ;
(mac :> bitstring) : 6*8 : bitstring |} in
t.client_id <- Some id ;
t.request_list <- Some "\001\003\006\012\015\028\051\058\119" ;
t.requested_ip <- Some yiaddr ;
t.server_id <- server_id ;
Expand All @@ -313,7 +315,7 @@ struct
make_request ~xid ~name (Ip.Addr.random ()) (if randb () then Some (Ip.Addr.random ()) else None)

(*$Q pack
((random %> pack), dump) (fun t -> t = pack (Option.get (unpack t)))
(Q.make (fun _ -> random () |> pack)) (fun t -> t = pack (Option.get (unpack t)))
*)
(*$>*)

Expand Down
Loading

0 comments on commit cc93ecd

Please sign in to comment.