Skip to content
Browse files

prototype server for signpo.st, still WIP

  • Loading branch information...
1 parent 73c51ed commit 85cd5bdb37b29f27a1b2cb7f931b187fb63d0f5a @avsm committed
Showing with 235 additions and 70 deletions.
  1. +7 −0 frost/SETUP.md
  2. +1 −1 frost/_oasis
  3. +7 −3 frost/_tags
  4. +23 −0 frost/config.ml
  5. +74 −48 frost/frost.ml
  6. +0 −12 frost/node.ml
  7. +42 −0 frost/scripts/ubuntu-interfaces
  8. +6 −4 frost/setup.ml
  9. +74 −0 frost/signal.ml
  10. +1 −2 frost/tactic.ml
View
7 frost/SETUP.md
@@ -0,0 +1,7 @@
+On the Ubuntu cloud VM:
+* `apt-get -y install bridge-utils uml-utilities`
+* Edit `/etc/ssh/sshd_config` to add "PermitTunnel=yes". Make sure "PermitRootLogin=yes" too.
+* Edit `/root/.ssh/authorized_keys` and remove the restrictions that prevent `root` from logging in with the `ubuntu` key. That is, delete everything until the `ssh-rsa` portion of the line.
+* Run the `scripts/ubuntu-interfaces` from this directory, and paste the output into `/etc/network/interfaces`
+* `/etc/init.d/networking restart` and make sure `signpost0` exists and no errors showed up on the restart.
+* Reboot the VM, just to make sure all good.
View
2 frost/_oasis
@@ -13,4 +13,4 @@ Executable frost
Custom: true
CompiledObject: best
Install: false
- BuildDepends: lwt.syntax,lwt.unix,ocamlgraph
+ BuildDepends: lwt.syntax,lwt.unix,ocamlgraph,dns,dns.server,cohttpd
View
10 frost/_tags
@@ -1,5 +1,5 @@
# OASIS_START
-# DO NOT EDIT (digest: 3a022fa7e71aadb8ae394d17cddae829)
+# DO NOT EDIT (digest: ad4d0e8d9476e69fd5244aac895d8844)
# Ignore VCS directories, you can use the same kind of rule outside
# OASIS_START/STOP if you want to exclude directories that contains
# useless stuff for the build process
@@ -17,11 +17,15 @@
<frost.{native,byte}>: pkg_ocamlgraph
<frost.{native,byte}>: pkg_lwt.unix
<frost.{native,byte}>: pkg_lwt.syntax
-<frost.{native,byte}>: pkg_froc
+<frost.{native,byte}>: pkg_dns.server
+<frost.{native,byte}>: pkg_dns
+<frost.{native,byte}>: pkg_cohttpd
<*.ml{,i}>: pkg_ocamlgraph
<*.ml{,i}>: pkg_lwt.unix
<*.ml{,i}>: pkg_lwt.syntax
-<*.ml{,i}>: pkg_froc
+<*.ml{,i}>: pkg_dns.server
+<*.ml{,i}>: pkg_dns
+<*.ml{,i}>: pkg_cohttpd
<frost.{native,byte}>: custom
# OASIS_STOP
<*.ml{,i}>: syntax_camlp4o
View
23 frost/config.ml
@@ -0,0 +1,23 @@
+(*
+ * Copyright (c) 2012 Anil Madhavapeddy <anil@recoil.org>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+let user = "avsm"
+let password = "foo"
+let signpost_number = 1
+let domain = "signpo.st"
+let ip_slash_24 = "172.16.11."
+let external_ip = "50.19.186.111"
+let external_dns = "ec2-50-19-186-111.compute-1.amazonaws.com"
View
122 frost/frost.ml
@@ -1,5 +1,5 @@
(*
- * Copyright (c) 2012 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2005-2012 Anil Madhavapeddy <anil@recoil.org>
*
* Permission to use, copy, modify, and distribute this software for any
* purpose with or without fee is hereby granted, provided that the above
@@ -14,52 +14,78 @@
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
-let test () =
- let g = Network.G.create () in
- (* Make some devices *)
- let cloud = Node.(make_node ~cap:Enabled ~name:"EC2") in
- let nat = Node.(make_node ~cap:Enabled ~name:"HomeNAT") in
- let iphone_3g = Node.(make_node ~cap:Dumb ~name:"iPhone3G") in
- let iphone_wifi = Node.(make_node ~cap:Dumb ~name:"iPhoneWifi") in
- let android_3g = Node.(make_node ~cap:Enabled ~name:"Android3G") in
- let android_wifi = Node.(make_node ~cap:Enabled ~name:"AndroidWifi") in
- let laptop = Node.(make_node ~cap:Enabled ~name:"Laptop") in
- (* And some connections between the devices *)
- let edges = Tactic.([
- nat, cloud, TCP_connect 80;
- iphone_3g, cloud, OpenVPN ();
- iphone_wifi, nat, TCP_connect 80;
- android_3g, cloud, OpenVPN ();
- android_wifi, nat, UDP_ping (53,53);
- laptop, nat, Always_fail;
- ]) in
- (* Populate the graph *)
- List.iter (Network.G.add_vertex g)
- [ cloud; nat; iphone_3g; iphone_wifi; android_3g; android_wifi];
- List.iter (fun (src,dst,ty) ->
- let t = Tactic.make_tactic ty in
- let e = Network.G.E.create src t dst in
- Network.G.add_edge_e g e
- ) edges;
- (* Dump it out in DOT format *)
- let oc = open_out "tmp.dot" in
- Network.DotOutput.output_graph oc g;
- close_out oc;
- g
+open Lwt
+open Printf
-(**
- * The evaluation loop for the network should be:
+(* The domain we are authoritative for *)
+let our_domain =
+ sprintf "d%d.%s" Config.signpost_number Config.domain
- * - Request for A to connect B results in a calculation that pull in
- * FROC behaviours when evaluating possible tactics. If any of these
- * behaviours change in the future, it will trigger a recalculation of
- * those tactics.
- *
- * - When a node joins or leaves, this may also trigger a recalculation.
- *
- * - Each tactic is an edge in the network, and has its own independent
- * thread, and when it changes state, can also trigger a recalculation.
- *
- * So, we have a graph of nodes/edges, and the main FRP
- *)
-let _ = test ()
+let our_iodine_domain =
+ let d = "d" ^ (string_of_int Config.signpost_number) in
+ [ "i"; d; Config.domain ]
+
+(* Respond with an NXDomain if record doesnt exist *)
+let nxdomain =
+ return (Some { Dns.Query.rcode=`NXDomain; aa=false;
+ answer=[]; authority=[]; additional=[] })
+
+(* Figure out the response from a query packet and its question section *)
+let get_response packet q =
+ let open Dns.Packet in
+ let module DQ = Dns.Query in
+ (* Normalise the domain names to lower case *)
+ let qnames = List.map String.lowercase q.q_name in
+ (* First, check in the static zonefile trie if the domain is present *)
+ let answer_from_trie = Dns.(Query.answer_query q.q_name q.q_type Loader.(state.db.trie)) in
+ eprintf "answer_from_trie: %s\n%!" (string_of_rcode answer_from_trie.DQ.rcode);
+ (* It's an NXDOMAIN, check if it is a dynamic DNS response, otherwise
+ * use whatever came back from the trie *)
+ match answer_from_trie.DQ.rcode with
+ |`NXDomain -> begin
+ (* For this strawman, we assume a valid query has form
+ * <src node>.<dst node>.<password>.<username>.<domain name>
+ *)
+ match qnames with
+ |src::dst::password::user::domain -> begin
+ let domain = String.concat "." domain in
+ eprintf "src:%s dst:%s pass:%s user:%s dom:%s\n%!" src dst password user domain;
+ answer_from_trie
+ end
+ |_ ->
+ eprintf "TODO: issue unknown response\n%!";
+ answer_from_trie
+ end
+ |_ -> answer_from_trie
+
+let dnsfn ~src ~dst packet =
+ let open Dns.Packet in
+ match packet.questions with
+ |[] -> eprintf "bad dns query: no questions\n%!"; return None
+ |[q] -> return (Some (get_response packet q))
+ |_ -> eprintf "dns dns query: multiple questions\n%!"; return None
+
+let dns_t () =
+ lwt fd, src = Dns_server.bind_fd ~address:"0.0.0.0" ~port:5354 in
+ let zonebuf = sprintf "
+$ORIGIN %s. ;
+$TTL 0
+
+@ IN SOA %s. hostmaster.%s. (
+ 2012011206 ; serial number YYMMDDNN
+ 28800 ; Refresh
+ 7200 ; Retry
+ 864000 ; Expire
+ 86400 ; Min TTL
+)
+
+@ A %s
+i NS %s.
+" our_domain Config.external_ip our_domain Config.external_ip Config.external_dns in
+ eprintf "%s\n%!" zonebuf;
+ Dns.Zone.load_zone [] zonebuf;
+ Dns_server.listen ~fd ~src ~dnsfn
+
+let _ =
+ let daemon_t = join [ dns_t (); Signal.http_t () ] in
+ Lwt_main.run daemon_t
View
12 frost/node.ml
@@ -14,18 +14,6 @@
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
-(**
- * Every node is a routing element that can establish links to other
- * nodes. They may be either fully Signpost-enabled, or dumb devices that
- * can only use standard network protocols.
- **)
-
-type cap =
- | Enabled (* Full signpost service present *)
- | Dumb (* Device cannot be sent instructions *)
-
-type port = int
-
(* TODO better categorisation needed (wildcard matches, etc) *)
type service =
| HTTP
View
42 frost/scripts/ubuntu-interfaces
@@ -0,0 +1,42 @@
+#!/usr/bin/env bash
+# Generate fragments for the Ubuntu interfaces file
+
+SIGNAL_BRIDGE=signpost0
+TACTIC_BRIDGE=tactic0
+SIGNAL_IP=172.16.10.1
+TACTIC_IP=172.16.11.1
+DEV="10 11 12 13 14"
+
+cat <<__HEADER
+auto $SIGNAL_BRIDGE
+iface $SIGNAL_BRIDGE inet static
+ address $SIGNAL_IP
+ netmask 255.255.255.0
+ bridge_ports none
+ bridge_fd 0
+ bridge_stp off
+
+auto $TACTIC_BRIDGE
+iface $TACTIC_BRIDGE inet static
+ address $TACTIC_IP
+ netmask 255.255.255.0
+ bridge_ports none
+ bridge_fd 0
+ bridge_stp off
+
+__HEADER
+
+for i in $DEV; do
+ cat <<__IFACE
+auto tactic$i
+iface tactic$i inet manual
+ pre-up tunctl -u ubuntu -t \$IFACE; brctl addif $TACTIC_BRIDGE \$IFACE; ifconfig \$IFACE up
+ post-down tunctl -d \$IFACE
+
+auto signpost$i
+iface signpost$i inet manual
+ pre-up tunctl -u ubuntu -t \$IFACE; brctl addif $SIGNAL_BRIDGE \$IFACE; ifconfig \$IFACE up
+ post-down tunctl -d \$IFACE
+
+__IFACE
+done
View
10 frost/setup.ml
@@ -1,7 +1,7 @@
(* setup.ml generated for the first time by OASIS v0.2.1~alpha1 *)
(* OASIS_START *)
-(* DO NOT EDIT (digest: 2224e516253169d5fd55c61700245a45) *)
+(* DO NOT EDIT (digest: d5972227faafedc3dc56ed0a65b861af) *)
(*
Regenerated by OASIS v0.2.1~alpha1
Visit http://oasis.forge.ocamlcore.org for more information and
@@ -5068,10 +5068,12 @@ let setup_t =
bs_compiled_object = Best;
bs_build_depends =
[
- FindlibPackage ("froc", None);
FindlibPackage ("lwt.syntax", None);
FindlibPackage ("lwt.unix", None);
- FindlibPackage ("ocamlgraph", None)
+ FindlibPackage ("ocamlgraph", None);
+ FindlibPackage ("dns", None);
+ FindlibPackage ("dns.server", None);
+ FindlibPackage ("cohttpd", None)
];
bs_build_tools = [ExternalTool "ocamlbuild"];
bs_c_sources = [];
@@ -5094,6 +5096,6 @@ let setup_t =
let setup () = BaseSetup.setup setup_t;;
-# 5098 "setup.ml"
+# 5100 "setup.ml"
(* OASIS_STOP *)
let () = setup ();;
View
74 frost/signal.ml
@@ -0,0 +1,74 @@
+(*
+ * Copyright (c) 2012 Anil Madhavapeddy <anil@recoil.org>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+(* Signalling HTTP server that runs over Iodine *)
+open Lwt
+open Printf
+open Cohttp
+
+module Resp = struct
+ (* respond with an error *)
+ let not_found req err =
+ let status = `Not_found in
+ let headers = [ "Cache-control", "no-cache" ] in
+ let resp = sprintf "<html><body><h1>Error</h1><p>%s</p></body></html>" err in
+ let body = [`String resp] in
+ Response.init ~body ~headers ~status ()
+
+ (* internal error *)
+ let internal_error err =
+ let status = `Internal_server_error in
+ let headers = [ "Cache-control", "no-cache" ] in
+ let resp = sprintf "<html><body><h1>Internal Server Error</h1><p>%s</p></body></html>" err in
+ let body = [`String resp] in
+ Response.init ~body ~headers ~status ()
+
+ (* dynamic response *)
+ let dyn req body =
+ let status = `OK in
+ let headers = [] in
+ Response.init ~body ~headers ~status ()
+
+ (* index page *)
+ let index req =
+ let body = [`String "Hello World"] in
+ return (dyn req body)
+
+ (* dispatch non-file URLs *)
+ let dispatch req =
+ function
+ | []
+ | ["index.html"] ->
+ index req
+ | _ ->
+ return (not_found req "dispatch")
+end
+
+(* main callback function *)
+let dispatch conn_id req =
+ let path = Cohttp.Request.path req in
+ printf "HTTP: %s %s [%s]\n%!" (Common.string_of_method (Request.meth req)) path
+ (String.concat "," (List.map (fun (h,v) -> sprintf "%s=%s" h v)
+ (Request.params_get req)));
+ let path_elem = Re_str.(split (regexp_string "/") path) in
+ lwt resp = Resp.dispatch req path_elem in
+ Cohttpd.Server.respond_with resp
+
+let http_t () =
+ let open Cohttpd.Server in
+ let port = 8080 in
+ let spec = { default_spec with callback=dispatch; port=port; auto_close=true } in
+ main spec
View
3 frost/tactic.ml
@@ -30,11 +30,10 @@ type ipsec_state = unit (* TODO *)
type tactic =
| TCP_connect of dst_port
| Always_fail (* for testing *)
-(*
+ | HTTP_connect
| UDP_ping of src_port * dst_port
| OpenVPN of openvpn_state
| IPSec of ipsec_state
-*)
(* Attempt a TCP connect out to dst:port *)

0 comments on commit 85cd5bd

Please sign in to comment.
Something went wrong with that request. Please try again.