Skip to content

Instantly share code, notes, and snippets.

@hannesm
Last active June 22, 2020 10:10
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save hannesm/10ae02dbfd42568b24518fddcb39060f to your computer and use it in GitHub Desktop.
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
Copy link
Author

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