Skip to content
Permalink

Comparing changes

Choose two branches to see what’s changed or to start a new pull request. If you need to, you can also or learn more about diff comparisons.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also . Learn more about diff comparisons here.
base repository: mirage/mirage
Failed to load repositories. Confirm that selected base ref is valid, then try again.
Loading
base: a7bfded53112
Choose a base ref
...
head repository: mirage/mirage
Failed to load repositories. Confirm that selected head ref is valid, then try again.
Loading
compare: 6e5a82449bc2
Choose a head ref
  • 4 commits
  • 2 files changed
  • 2 contributors

Commits on Apr 16, 2015

  1. Kill the channel module

    @samoht
    samoht committed Apr 16, 2015
    Copy the full SHA
    38f6992 View commit details

  2. Rename HTTP.`Stack into HTTP.Conduit

    @samoht
    samoht committed Apr 16, 2015
    Copy the full SHA
    9fd9447 View commit details

  3. Adapt code generation to conduit.0.8.0 and mirage-http.2.2.0

    @samoht
    samoht committed Apr 16, 2015
    Copy the full SHA
    a2f80eb View commit details

  4. Merge pull request #393 from samoht/master 

    Adapt to latest changes in conduit and mirage-http
    @samoht
    samoht committed Apr 16, 2015
    Copy the full SHA
    6e5a824 View commit details
Showing with 15 additions and 85 deletions.
  1. +15 −74 lib/mirage.ml
  2. +0 −11 lib/mirage.mli
89 changes: 15 additions & 74 deletions lib/mirage.ml
View file
Original file line number Diff line number Diff line change
@@ -1545,50 +1545,6 @@ let direct_stackv4_with_static_ipv4
let socket_stackv4 console ipv4s =
impl stackv4 { STACKV4_socket.console; ipv4s } (module STACKV4_socket)

module Channel_over_TCP (V : sig type t end) = struct

type t = V.t tcp impl

let name t =
let key = "channel" ^ Impl.name t in
Name.of_key key ~base:"channel"

let module_name t =
String.capitalize (name t)

let packages _ =
[ "mirage-tcpip" ]

let libraries _ =
[ "tcpip.channel" ]

let configure t =
Impl.configure t;
append_main "module %s = Channel.Make(%s)" (module_name t) (Impl.module_name t);
newline_main ();
append_main "let %s () =" (name t);
append_main " %s () >>= function" (Impl.name t);
append_main " | `Error _ -> %s" (driver_initialisation_error (Impl.name t));
append_main " | `Ok console ->";
append_main " let flow = %s.create config in" (module_name t);
append_main " return (`Ok flow)";
newline_main ()

let clean t =
Impl.clean t

let update_path t root =
Impl.update_path t root

end

type channel = CHANNEL

let channel = Type CHANNEL

let channel_over_tcp (type v) (flow : v tcp impl) =
impl channel flow (module Channel_over_TCP (struct type t = v end))

module VCHAN_localhost = struct

type uuid = string
@@ -1923,86 +1879,71 @@ let resolver_unix_system =
module HTTP = struct

type t =
[ `Channel of channel impl
| `Stack of conduit_server * conduit impl ]
| Conduit of conduit_server * conduit impl

let name t =
let key = "http" ^ match t with
| `Channel c -> Impl.name c
| `Stack (_, c) -> Impl.name c in
| Conduit (_, c) -> Impl.name c in
Name.of_key key ~base:"http"

let module_name_core t =
String.capitalize (name t)

let module_name t =
module_name_core t ^ ".Server"
String.capitalize (name t)

let packages t =
[ "mirage-http" ] @
match t with
| `Channel c -> Impl.packages c
| `Stack (_, c) -> Impl.packages c
| Conduit (_, c) -> Impl.packages c

let libraries t =
[ "mirage-http" ] @
match t with
| `Channel c -> Impl.libraries c
| `Stack (_, c) -> Impl.libraries c
| Conduit (_, c) -> Impl.libraries c

let configure t =
begin match t with
| `Channel c ->
| Conduit (_, c) ->
Impl.configure c;
append_main "module %s = HTTP.Make(%s)" (module_name_core t) (Impl.module_name c)
| `Stack (_, c) ->
Impl.configure c;
append_main "module %s = HTTP.Make(%s)" (module_name_core t) (Impl.module_name c)
append_main "module %s = Cohttp_mirage.Server(%s.Flow)"
(module_name t) (Impl.module_name c)
end;
newline_main ();
let subname = match t with
| `Channel c -> Impl.name c
| `Stack (_,c) -> Impl.name c in
| Conduit (_,c) -> Impl.name c in
append_main "let %s () =" (name t);
append_main " %s () >>= function" subname;
append_main " | `Error _ -> %s" (driver_initialisation_error subname);
append_main " | `Ok %s ->" subname;
begin match t with
| `Channel c -> failwith "TODO"
| `Stack (m,c) ->
| Conduit (m,c) ->
append_main " let listen spec =";
append_main " let ctx = %s in" (Impl.name c);
append_main " let mode = %s in"
(match m with
|`TCP (`Port port) -> Printf.sprintf "`TCP (`Port %d)" port
|`Vchan l -> failwith "Vchan not supported yet in server"
);
append_main " %s.serve ~ctx ~mode (%s.Server.listen spec)" (Impl.module_name c) (module_name_core t);
append_main " %s.serve ~ctx ~mode (%s.listen spec)"
(Impl.module_name c) (module_name t);
append_main " in";
append_main " return (`Ok listen)";
end;
newline_main ()

let clean = function
| `Channel c -> Impl.clean c
| `Stack (_,c) -> Impl.clean c
| Conduit (_,c) -> Impl.clean c

let update_path t root =
match t with
| `Channel c -> `Channel (Impl.update_path c root)
| `Stack (m, c) -> `Stack (m, Impl.update_path c root)
| Conduit (m, c) -> Conduit (m, Impl.update_path c root)

end

type http = HTTP

let http = Type HTTP

let http_server_of_channel chan =
impl http (`Channel chan) (module HTTP)

let http_server mode conduit =
impl http (`Stack (mode, conduit)) (module HTTP)
impl http (HTTP.Conduit (mode, conduit)) (module HTTP)

type job = JOB

11 changes: 0 additions & 11 deletions lib/mirage.mli
View file
Original file line number Diff line number Diff line change
@@ -331,15 +331,6 @@ val direct_stackv4_with_dhcp:

val socket_stackv4: console impl -> Ipaddr.V4.t list -> stackv4 impl


(** {Channel configuration} *)

(** Implementation of the [V1.CHANNEL] signature. *)

type channel
val channel: channel typ
val channel_over_tcp: 'a tcp impl -> channel impl

(** {Resolver configuration} *)

type resolver
@@ -576,8 +567,6 @@ module TCPV4_socket: CONFIGURABLE
module STACKV4_direct: CONFIGURABLE
module STACKV4_socket: CONFIGURABLE

module Channel_over_TCP: functor (V : sig type t end) -> CONFIGURABLE

module HTTP: CONFIGURABLE

module Job: CONFIGURABLE