Skip to content

Commit

Permalink
Huge refactor for some new use case - WIP
Browse files Browse the repository at this point in the history
  • Loading branch information
@rixed
rixed committed Nov 11, 2018
1 parent cc93ecd commit 3cfeb84
Show file tree
Hide file tree
Showing 45 changed files with 1,462 additions and 542 deletions.
16 changes: 11 additions & 5 deletions Makefile
View file
Original file line number Diff line number Diff line change
@@ -1,13 +1,14 @@
top_srcdir = ./
PKG_NAME = robinet
SOURCES = \
tools.ml \
distribution.ml \
private.ml \
clock.ml \
log.ml \
tools.ml \
persist.ml \
peg.ml \
metric.ml \
dns.ml \
url.ml \
http.ml \
tcp.ml \
Expand All @@ -16,6 +17,8 @@ SOURCES = \
ip6.ml \
icmp.ml \
icmp6.ml \
dns.ml \
named.ml \
arp.ml \
vlan.ml \
eth.ml \
Expand All @@ -37,7 +40,9 @@ SOURCES = \

C_SOURCES = pcap_wrap.c eth_vendors.c
CLIB = libpcapw.a
LIBS = -cclib -lpcap
# libpcap elsewhere? Call make with:
# LIBS="-cclib -L/usr/local/lib -cclib -lpcap"
LIBS += -cclib -lpcap
EXAMPLES_BYTE = \
examples/arp_query.byte \
examples/tcp_test.byte \
Expand All @@ -55,7 +60,8 @@ EXAMPLES_BYTE = \
examples/capecho.byte \
examples/load_tester.byte \
examples/pcap_reorder.byte \
examples/simu_perfweb.byte
examples/simu_perfweb.byte \
examples/simu_dc_mirroring.byte

EXAMPLES_OPT = $(EXAMPLES_BYTE:.byte=.opt)
EXAMPLES = $(EXAMPLES_BYTE) $(EXAMPLES_OPT)
Expand Down Expand Up @@ -85,7 +91,7 @@ examples: $(EXAMPLES)
fi

robinet.top: $(ARCHIVE)
$(OCAMLMKTOP) -o $@ -package "findlib $(REQUIRES)" $(ARCHIVE)
$(OCAMLMKTOP) $(WARNS) -o $@ -package "findlib $(REQUIRES)" $(ARCHIVE)
@if which setcap >& /dev/null ; then \
sudo setcap cap_net_raw,cap_net_admin=eip $@ ;\
fi
Expand Down
8 changes: 4 additions & 4 deletions arp.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -24,13 +24,13 @@ open Batteries
open Bitstring
open Tools

let debug = false
let debug = true

(** {2 ARP messages} *)

(** ARP Operations Codes *)
module Op = struct
include MakePrivate(struct
include Private.Make (struct
type t = int
let to_string = function
| 1 -> "request"
Expand Down Expand Up @@ -77,7 +77,7 @@ module HwType = struct
let is_valid x = x >= 1
let repl_tag = "code"
end
include MakePrivate(Inner)
include Private.Make (Inner)
let eth = o 1
let expe_eth = o 2
let ax25 = o 3
Expand All @@ -94,7 +94,7 @@ end
(** Arp Protocol Types.
* These are used in other places as well. *)
module HwProto = struct
include MakePrivate(struct
include Private.Make (struct
type t = int
let to_string = function
| 0x0800 -> "IP"
Expand Down
125 changes: 71 additions & 54 deletions browser.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -47,15 +47,19 @@ type t = { host : Host.host_trx ;
we can reuse them if necessary. These are closed after some time,
and we do not keep more than a given number (10, specifically) *)
mutable vacant_cnxs : (Host.addr * Tcp.Port.t, vacant_cnx) Hashtbl.t ;
max_vacant_cnx : int ; max_idle_cnx : Clock.Interval.t }
max_vacant_cnx : int ;
max_idle_cnx : Clock.Interval.t ;
(* When it has been ordered to stop: *)
mutable killed : bool }

let make ?(user_agent="RobiNet") ?(max_vacant_cnx=10) ?(max_idle_cnx=Clock.Interval.sec 15.) host =
{ host = host ;
user_agent = user_agent ;
cookies = [] ;
vacant_cnxs = Hashtbl.create 7 ;
max_vacant_cnx = max_vacant_cnx ;
max_idle_cnx = max_idle_cnx }
max_idle_cnx = max_idle_cnx ;
killed = false }

(** {2 Cookies}
Expand Down Expand Up @@ -355,23 +359,25 @@ let post t ?(headers=[]) url vars cont =
let spider t max_depth start =
let fetched = Hashtbl.create 100 in
let rec aux max_depth url =
if debug then Printf.printf "Browser: spider: fetching %s with max_depth %d\n%!" (Url.to_string url) max_depth ;
Hashtbl.add fetched url true ;
get t url (function
| None -> ()
| Some (headers, body) ->
if max_depth > 1 then (
let content_type = headers_find "Content-type" headers in
if (match content_type with None -> true | Some str -> String.exists (String.lowercase str) "text/html") then (
match Html.parse body with
| Some tree ->
extract_links ~default_base:url headers tree //
(Hashtbl.mem fetched %> not) |>
List.of_enum |>
List.iter (fun url ->
Clock.asap (aux (max_depth-1)) url)
| None ->
if debug then Printf.printf "Browser: Cannot parse HTML from %s\n" (Url.to_string url)
if not t.killed then (
if debug then Printf.printf "Browser: spider: fetching %s with max_depth %d\n%!" (Url.to_string url) max_depth ;
Hashtbl.add fetched url true ;
get t url (function
| None -> ()
| Some (headers, body) ->
if max_depth > 1 then (
let content_type = headers_find "Content-type" headers in
if (match content_type with None -> true | Some str -> String.exists (String.lowercase str) "text/html") then (
match Html.parse body with
| Some tree ->
extract_links ~default_base:url headers tree //
(Hashtbl.mem fetched %> not) |>
List.of_enum |>
List.iter (fun url ->
Clock.asap (aux (max_depth-1)) url)
| None ->
if debug then Printf.printf "Browser: Cannot parse HTML from %s\n" (Url.to_string url)
)
)
)
) in
Expand All @@ -381,42 +387,54 @@ let spider t max_depth start =
let user t ?pause max_depth start =
let fetched = Hashtbl.create 100 in
let rec aux max_depth url =
if debug then Printf.printf "Browser: user: fetching %s with max_depth %d\n%!" (Url.to_string url) max_depth ;
Hashtbl.add fetched url true ;
get t url (function
| None -> ()
| Some (headers, body) ->
if max_depth > 1 then (
let content_type = headers_find "Content-type" headers in
if (match content_type with None -> true | Some str -> String.exists (String.lowercase str) "text/html") then (
(* Fetch eveything a browser would fetch at once (images, etc) *)
extract_links_simple ~same_page:true ~default_base:url headers body //
(Hashtbl.mem fetched %> not) |>
List.of_enum |>
tap (fun l -> if debug then Printf.printf "Browser: will iter on %d urls\n" (List.length l)) |>
List.iter (fun url' ->
if debug then Printf.printf "Browser: user: fetching %s for %s\n" (Url.to_string url') (Url.to_string url) ;
Clock.asap (aux (max_depth-1)) url') ;
(* fetch sequentially, depth first, a links *)
let urls = extract_links_simple ~same_page:false ~default_base:url headers body //
(Hashtbl.mem fetched %> not) in
let rec fetch_next () =
match Enum.get urls with
| None -> ()
| Some url' ->
let d = match pause with
| None -> 0.
| Some t -> Random.float (2.*.t) in
Clock.delay (Clock.Interval.o d) (fun () ->
if debug then Printf.printf "Browser: user: fetching %s after %s\n" (Url.to_string url') (Url.to_string url) ;
aux (max_depth-1) url' ;
fetch_next ()) () in
fetch_next () ;
if debug then Printf.printf "Browser: done with %s\n" (Url.to_string url)
if not t.killed then (
if debug then Printf.printf "Browser: user: fetching %s with max_depth %d\n%!" (Url.to_string url) max_depth ;
Hashtbl.add fetched url true ;
get t url (function
| None -> ()
| Some (headers, body) ->
if max_depth > 1 then (
let content_type = headers_find "Content-type" headers in
if (match content_type with None -> true | Some str -> String.exists (String.lowercase str) "text/html") then (
(* Fetch eveything a browser would fetch at once (images, etc) *)
extract_links_simple ~same_page:true ~default_base:url headers body //
(Hashtbl.mem fetched %> not) |>
List.of_enum |>
tap (fun l -> if debug then Printf.printf "Browser: will iter on %d urls\n" (List.length l)) |>
List.iter (fun url' ->
if debug then Printf.printf "Browser: user: fetching %s for %s\n" (Url.to_string url') (Url.to_string url) ;
Clock.asap (aux (max_depth-1)) url') ;
(* fetch sequentially, depth first, a links *)
(* TODO: get only one URL amongst the possible links but keep all
* encountered URL in this set of possible next links. Also,
* sleep in between 2 clicks according to the read_time
* distribution. *)
let urls = extract_links_simple ~same_page:false ~default_base:url headers body //
(Hashtbl.mem fetched %> not) in
let rec fetch_next () =
match Enum.get urls with
| None -> ()
| Some url' ->
let d = match pause with
| None -> 0.
| Some t -> Random.float (2.*.t) in
Clock.delay (Clock.Interval.o d) (fun () ->
if debug then Printf.printf "Browser: user: fetching %s after %s\n" (Url.to_string url') (Url.to_string url) ;
aux (max_depth-1) url' ;
fetch_next ()) () in
fetch_next () ;
if debug then Printf.printf "Browser: done with %s\n" (Url.to_string url)
)
)
)) in
)
) in
aux max_depth (Url.resolve Url.empty start) ;
if debug then Printf.printf "Browser: done using browser.\n%!" ;
if debug then Printf.printf "Browser: done using browser.\n%!"

let kill t k =
t.killed <- true ;
(* effective immediately: *)
k ()

module Plan =
struct
Expand All @@ -429,4 +447,3 @@ struct
allowed_urls : Str.regexp array ;
forbidden_urls : Str.regexp array } (* checked only if not allowed *)
end

12 changes: 6 additions & 6 deletions clock.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -34,7 +34,6 @@
*)
open Batteries
open Tools

let debug = false

Expand All @@ -45,7 +44,7 @@ let realtime = ref true
(** Time.t represents a given timestamp (ie. number of seconds since 1970-01-01 00:00:00 UTC. *)
module rec Time : sig
val print_date : bool ref
include PRIVATE_TYPE with type t = private float and type outer_t = float
include Private.S with type t = private float and type outer_t = float
val add : t -> Interval.t -> t
val sub : t -> t -> Interval.t
val wall_clock : unit -> t
Expand All @@ -55,7 +54,7 @@ end = struct
* Only useful if your simulation spans several days, which is uncommon. *)
let print_date = ref false

include MakePrivate(struct
include Private.Make(struct
type t = float
let to_string t =
let open Unix in
Expand Down Expand Up @@ -91,7 +90,7 @@ end
(** 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
include Private.S with type t = private float and type outer_t = float
val usec : float -> t
val msec : float -> t
val sec : float -> t
Expand All @@ -100,7 +99,7 @@ and Interval : sig
val compare : t -> t -> int
val add : t -> t -> t
end = struct
include MakePrivate(struct
include Private.Make(struct
type t = float
let to_string t =
Printf.sprintf "+%fs" t
Expand Down Expand Up @@ -181,7 +180,7 @@ let asap f x =
* You must call this after real time passes (for instance after a blocking call).
* Otherwise, time jumps from one registered event to the next. *)
let synch () =
ensure !realtime "Synch with real clock in non-realtime mode!?" ;
assert !realtime (* Synch with real clock in non-realtime mode!? *) ;
current.now <- Time.wall_clock () ;
if debug then Printf.printf "Clock: synch: set current time to %s\n%!" (Time.to_string current.now)

Expand Down Expand Up @@ -235,6 +234,7 @@ let next_event () =
* an answer from the outside world is _not_ a clock event. You should probably
* run forever whenever you communicate with the outside. *)
let run wait =
if debug then Printf.printf "clock: running the clock!\n%!" ;
while wait || not (Map.is_empty current.events) do
next_event () ;
Thread.yield ()
Expand Down
4 changes: 2 additions & 2 deletions dhcp.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -22,7 +22,7 @@ open Batteries
open Bitstring
open Tools

let debug = false
let debug = true

(** {2 Opcodes, types, etc} *)

Expand All @@ -46,7 +46,7 @@ module MsgType = struct
let is_valid x = x >= 1 && x <= 8
let repl_tag = "code"
end
include MakePrivate(Inner)
include Private.Make (Inner)

let discover = o 1
let offer = o 2
Expand Down
22 changes: 13 additions & 9 deletions dhcpd.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -29,25 +29,28 @@ let serve ?(port=Udp.Port.o 67) host ips =
let rem_cidr = ref ips in
let offers = BitHash.create 4 in
let leases = BitHash.create 8 in
let logger = Log.(make (Printf.sprintf "%s/Dhcpd" host.Host.logger.name) 50) in
let logger = host.Host.logger in
Log.(log logger Debug (lazy "dhcpd: Listening for requests...")) ;
host.Host.udp_server port (fun udp ->
udp.Udp.TRX.trx.ins.set_read (fun bits ->
Log.(log logger Debug (lazy "dhcpd: Received an UDP packet...")) ;
let src_port, dst_port = udp.Udp.TRX.get_ports () in
match Pdu.unpack bits with
| None ->
Log.(log logger Debug (lazy "Not a DHCP message, ignoring"))
Log.(log logger Debug (lazy "dhcpd: Not a DHCP message, ignoring"))
| Some ({ Pdu.op = BootRequest ; Pdu.hlen = 6 ; _ } as dhcp)
when dhcp.Pdu.htype = Arp.HwType.eth &&
dhcp.Pdu.msg_type = Some MsgType.discover ->
Log.(log logger Debug (lazy (Printf.sprintf "Received a DHCP Discover from %s" (hexstring_of_bitstring dhcp.Pdu.chaddr)))) ;
Log.(log logger Debug (lazy (Printf.sprintf "dhcpd: Received a DHCP Discover from %s" (hexstring_of_bitstring dhcp.Pdu.chaddr)))) ;
(match Enum.get !rem_cidr with
| Some offered_ip ->
(* Add this entry to our ARP cache *)
(* Add this entry to our ARP cache.
* FIXME: actually, shouldn't we wait for the ack, in case the offer is rejected!? *)
host.Host.arp_set offered_ip (Some (Eth.Addr.o dhcp.Pdu.chaddr)) ;
(* Store the offer *before* spawning the responding thread *)
BitHash.replace offers dhcp.Pdu.chaddr offered_ip ;
(* Send the offer *)
Log.(log logger Debug (lazy (Printf.sprintf "Offering IP %s to %s" (Ip.Addr.to_string offered_ip) (hexstring_of_bitstring dhcp.Pdu.chaddr)))) ;
Log.(log logger Debug (lazy (Printf.sprintf "dhcpd: Offering IP %s to %s" (Ip.Addr.to_string offered_ip) (hexstring_of_bitstring dhcp.Pdu.chaddr)))) ;
Pdu.make_offer ~mac:(host.Host.get_mac ())
~xid:dhcp.Pdu.xid offered_ip
dhcp.Pdu.client_id |>
Expand All @@ -57,16 +60,17 @@ let serve ?(port=Udp.Port.o 67) host ips =
~src_port
dst_port
| None ->
Log.(log logger Debug (lazy "No more unused IP, cannot make offer")))
Log.(log logger Debug (lazy "dhcpd: No more unused IP, cannot make offer")))
| Some ({ Pdu.op = BootRequest ; Pdu.hlen = 6 ; _ } as dhcp)
when dhcp.Pdu.htype = Arp.HwType.eth &&
dhcp.Pdu.msg_type = Some MsgType.request ->
Log.(log logger Debug (lazy (Printf.sprintf "Received a DHCP Request from %s" (hexstring_of_bitstring dhcp.Pdu.chaddr)))) ;
Log.(log logger Debug (lazy (Printf.sprintf "dhcpd: Received a DHCP Request from %s" (hexstring_of_bitstring dhcp.Pdu.chaddr)))) ;
(* Look for previous offers *)
(match BitHash.find_option offers dhcp.Pdu.chaddr with
| Some offered_ip ->
BitHash.remove offers dhcp.Pdu.chaddr ;
BitHash.replace leases dhcp.Pdu.chaddr offered_ip ;
Log.(log logger Debug (lazy "dhcpd: acking it")) ;
Pdu.make_ack ~mac:(host.Host.get_mac ())
~xid:dhcp.Pdu.xid
offered_ip dhcp.Pdu.client_id |>
Expand All @@ -75,11 +79,11 @@ let serve ?(port=Udp.Port.o 67) host ips =
~src_port
dst_port
| None ->
Log.(log logger Warning (lazy (Printf.sprintf "I never offered anythin to %s (or I fogot about it)" (Eth.Addr.to_string (Eth.Addr.o dhcp.Pdu.chaddr))))) ;
Log.(log logger Warning (lazy (Printf.sprintf "dhcpd: I never offered anything to %s (or I fogot about it)" (Eth.Addr.to_string (Eth.Addr.o dhcp.Pdu.chaddr))))) ;
(* ignore it *) ())
(* TODO: handle release & decline *)
| _ ->
Log.(log logger Debug (lazy "Ignoring DHCP message"))))
Log.(log logger Debug (lazy "dhcpd: Ignoring DHCP message"))))

(*$R serve
Clock.realtime := false ;
Expand Down
Loading

0 comments on commit 3cfeb84

Please sign in to comment.