Skip to content

Instantly share code, notes, and snippets.

@hannesm

hannesm/config.ml Secret

Last active Jun 22, 2020
Embed
What would you like to do?
MirageOS traceroute
open Mirage
let host =
let doc = Key.Arg.info ~doc:"The host to trace." ["host"] in
Key.(create "host" Arg.(opt ipv4_address (Ipaddr.V4.of_string_exn "141.1.1.1") doc))
let timeout =
let doc = Key.Arg.info ~doc:"Timeout (in millisecond)" ["timeout"] in
Key.(create "timeout" Arg.(opt int 1000 doc))
let ipv4 =
let doc = Key.Arg.info ~doc:"IPv4 address" ["ipv4"] in
Key.(create "ipv4" Arg.(required ipv4 doc))
let ipv4_gateway =
let doc = Key.Arg.info ~doc:"IPv4 gateway" ["ipv4-gateway"] in
Key.(create "ipv4-gateway" Arg.(required ipv4_address doc))
let main =
let packages = [
package ~sublibs:["ipv4"; "udp"; "icmpv4"] "tcpip";
package "ethernet";
package "arp-mirage";
package "mirage-protocols";
package "mtime";
] in
foreign
~keys:[Key.abstract ipv4 ; Key.abstract ipv4_gateway ; Key.abstract host ; Key.abstract timeout]
~packages
"Unikernel.Main"
(random @-> mclock @-> time @-> network @-> job)
let () =
register "traceroute"
[ main $ default_random $ default_monotonic_clock $ default_time $ default_network ]
open Lwt.Infix
let ports_of_ttl_ts ttl ts =
let ts = Int64.div ts 100L in
let src_port = 0xffff land (Int64.(to_int (shift_right ts 11)))
and dst_port = 0xffe0 land (Int64.(to_int (shift_left ts 5))) lor (0x001f land ttl)
in
src_port, dst_port
let ttl_ts_of_ports src_port dst_port =
let ttl = 0x001f land dst_port in
let ts =
let low = Int64.of_int (dst_port lsr 5)
and high = Int64.(shift_left (of_int src_port) 11)
in
Int64.add low high
in
let ts = Int64.mul ts 100L in
ttl, ts
let log_one now ttl sent ip =
let now = Int64.(mul (logand (div now 100L) 0x7FFFFFFL) 100L) in
let duration = Mtime.Span.of_uint64_ns (Int64.sub now sent) in
Logs.info (fun m -> m "%2d %a %a" ttl Ipaddr.V4.pp ip Mtime.Span.pp duration)
module Icmp = struct
type t = {
send : int -> unit Lwt.t ;
log : int -> int64 -> Ipaddr.V4.t -> unit ;
task_done : unit Lwt.u ;
}
let connect send log task_done =
let t = { send ; log ; task_done } in
Lwt.return t
let input t ~src ~dst buf =
let open Icmpv4_packet in
match Unmarshal.of_cstruct buf with
| Error s ->
Lwt.fail_with (Fmt.strf "ICMP: error parsing message from %a: %s" Ipaddr.V4.pp src s)
| Ok (message, payload) ->
let open Icmpv4_wire in
match message.ty with
| Time_exceeded ->
begin match Ipv4_packet.Unmarshal.header_of_cstruct payload with
| Ok (pkt, off) when
pkt.Ipv4_packet.proto = Ipv4_packet.Marshal.protocol_to_int `UDP &&
Ipaddr.V4.compare pkt.Ipv4_packet.dst (Key_gen.host ()) = 0 ->
(* time exceeded -> increase ttl and send frame out *)
let src_port = Cstruct.BE.get_uint16 payload off
and dst_port = Cstruct.BE.get_uint16 payload (off + 2)
in
let ttl, sent = ttl_ts_of_ports src_port dst_port in
t.log ttl sent src;
let ttl' = succ ttl in
Logs.debug (fun m -> m "ICMP time exceeded from %a to %a, now sending with ttl %d"
Ipaddr.V4.pp src Ipaddr.V4.pp dst ttl');
t.send ttl'
| Ok (pkt, _) ->
Logs.debug (fun m -> m "unsolicited time exceeded from %a to %a (proto %X dst %a)"
Ipaddr.V4.pp src Ipaddr.V4.pp dst pkt.Ipv4_packet.proto Ipaddr.V4.pp pkt.Ipv4_packet.dst);
Lwt.return_unit
| Error e ->
Lwt.fail_with (Fmt.strf "couldn't parse ICMP time exceeded payload (IPv4) (%a -> %a) %s"
Ipaddr.V4.pp src Ipaddr.V4.pp dst e)
end
| Destination_unreachable when Ipaddr.V4.compare src (Key_gen.host ()) = 0 ->
(* reached final host *)
begin match Ipv4_packet.Unmarshal.header_of_cstruct payload with
| Ok (_, off) ->
let src_port = Cstruct.BE.get_uint16 payload off
and dst_port = Cstruct.BE.get_uint16 payload (off + 2)
in
let ttl, sent = ttl_ts_of_ports src_port dst_port in
t.log ttl sent src;
Lwt.wakeup t.task_done ();
Lwt.return_unit
| Error e ->
Lwt.fail_with (Fmt.strf "couldn't parse ICMP unreachable payload (IPv4) (%a -> %a) %s"
Ipaddr.V4.pp src Ipaddr.V4.pp dst e)
end
| ty ->
Logs.debug (fun m -> m "ICMP unknown ty %s from %a to %a: %a"
(ty_to_string ty) Ipaddr.V4.pp src Ipaddr.V4.pp dst
Cstruct.hexdump_pp payload);
Lwt.return_unit
end
module Main (R : Mirage_random.S) (M : Mirage_clock.MCLOCK) (Time : Mirage_time.S) (N : Mirage_net.S) = struct
module ETH = Ethernet.Make(N)
module ARP = Arp.Make(ETH)(Time)
module IPV4 = Static_ipv4.Make(R)(M)(ETH)(ARP)
module UDP = Udp.Make(IPV4)(R)
let to_cancel = ref None
let rec send_udp udp ttl =
(match !to_cancel with
| None -> ()
| Some t -> Lwt.cancel t ; to_cancel := None);
if ttl > 32 then
Lwt.return_unit
else
let cancel =
Lwt.catch (fun () ->
Time.sleep_ns (Duration.of_ms (Key_gen.timeout ())) >>= fun () ->
Logs.info (fun m -> m "%2d *" ttl);
send_udp udp (succ ttl))
(function Lwt.Canceled -> Lwt.return_unit | exc -> Lwt.fail exc)
in
to_cancel := Some cancel;
let src_port, dst_port = ports_of_ttl_ts ttl (M.elapsed_ns ()) in
UDP.write ~ttl ~src_port ~dst:(Key_gen.host ()) ~dst_port udp Cstruct.empty >>= function
| Ok () -> Lwt.return_unit
| Error e -> Lwt.fail_with (Fmt.strf "while sending udp frame %a" UDP.pp_error e)
let start () () () net =
let cidr = Key_gen.ipv4 ()
and gateway = Key_gen.ipv4_gateway ()
in
let log_one = fun port ip -> log_one (M.elapsed_ns ()) port ip
and t, w = Lwt.task ()
in
ETH.connect net >>= fun eth ->
ARP.connect eth >>= fun arp ->
IPV4.connect ~cidr ~gateway eth arp >>= fun ip ->
UDP.connect ip >>= fun udp ->
let send = send_udp udp in
Icmp.connect send log_one w >>= fun icmp ->
let ethif_listener =
ETH.input
~arpv4:(ARP.input arp)
~ipv4:(
IPV4.input
~tcp:(fun ~src:_ ~dst:_ _ -> Lwt.return_unit)
~udp:(fun ~src:_ ~dst:_ _ -> Lwt.return_unit)
~default:(fun ~proto ~src ~dst buf ->
match proto with
| 1 -> Icmp.input icmp ~src ~dst buf
| _ -> Lwt.return_unit)
ip)
~ipv6:(fun _ -> Lwt.return_unit)
eth
in
Lwt.async (fun () ->
N.listen net ~header_size:Ethernet_wire.sizeof_ethernet ethif_listener >|= function
| Ok () -> ()
| Error e -> Logs.err (fun m -> m "netif error %a" N.pp_error e));
send 1 >>= fun () ->
t
end
@hannesm

This comment has been minimized.

Copy link
Owner Author

@hannesm hannesm commented Jun 22, 2020

requires mirage 3.8.0 and tcpip 5.0.0 (which are not yet in opam-repository) -- due to changes to the ipv4.connect signature

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.