MirageOS traceroute
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 ] |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
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