Skip to content
Permalink
Browse files

Run `dune build @fmt` with ocamlformat.0.9

  • Loading branch information...
samoht committed Apr 2, 2019
1 parent 22cb228 commit cd10359729f910d0b4103c6ec484f79cad6a5473
Showing with 11,165 additions and 9,960 deletions.
  1. +1 −0 dune-project
  2. +48 −65 examples/custom_merge.ml
  3. +61 −69 examples/deploy.ml
  4. +14 −20 examples/irmin_git_store.ml
  5. +83 −84 examples/process.ml
  6. +11 −13 examples/push.ml
  7. +9 −11 examples/sync.ml
  8. +17 −28 examples/trees.ml
  9. +90 −94 src/irmin-chunk/irmin_chunk.ml
  10. +11 −8 src/irmin-chunk/irmin_chunk.mli
  11. +151 −139 src/irmin-fs/irmin_fs.ml
  12. +38 −31 src/irmin-fs/irmin_fs.mli
  13. +512 −446 src/irmin-git/irmin_git.ml
  14. +105 −96 src/irmin-git/irmin_git.mli
  15. +515 −576 src/irmin-graphql/server.ml
  16. +26 −16 src/irmin-graphql/server.mli
  17. +197 −177 src/irmin-http/irmin_http.ml
  18. +7 −5 src/irmin-http/irmin_http.mli
  19. +8 −16 src/irmin-http/irmin_http_common.ml
  20. +7 −10 src/irmin-http/irmin_http_common.mli
  21. +238 −247 src/irmin-http/irmin_http_server.ml
  22. +5 −8 src/irmin-http/irmin_http_server.mli
  23. +45 −46 src/irmin-mem/irmin_mem.ml
  24. +5 −5 src/irmin-mem/irmin_mem.mli
  25. +243 −207 src/irmin-mirage/irmin_mirage.ml
  26. +129 −97 src/irmin-mirage/irmin_mirage.mli
  27. +30 −28 src/irmin-test/common.ml
  28. +0 −1 src/irmin-test/irmin_test.ml
  29. +23 −18 src/irmin-test/irmin_test.mli
  30. +670 −789 src/irmin-test/store.ml
  31. +1 −2 src/irmin-unix/bin/main.ml
  32. +597 −544 src/irmin-unix/cli.ml
  33. +8 −8 src/irmin-unix/cli.mli
  34. +108 −116 src/irmin-unix/fs.ml
  35. +12 −7 src/irmin-unix/fs.mli
  36. +13 −7 src/irmin-unix/graphql.ml
  37. +9 −8 src/irmin-unix/graphql.mli
  38. +1 −1 src/irmin-unix/hook.mli
  39. +4 −9 src/irmin-unix/http.ml
  40. +6 −3 src/irmin-unix/http.mli
  41. +10 −7 src/irmin-unix/info.ml
  42. +2 −2 src/irmin-unix/info.mli
  43. +1 −0 src/irmin-unix/irmin_unix.ml
  44. +92 −102 src/irmin-unix/irmin_unix.mli
  45. +130 −145 src/irmin-unix/resolver.ml
  46. +25 −23 src/irmin-unix/resolver.mli
  47. +75 −53 src/irmin-unix/xgit.ml
  48. +96 −82 src/irmin-unix/xgit.mli
  49. +27 −28 src/irmin/bheap.ml
  50. +2 −3 src/irmin/bheap.mli
  51. +6 −8 src/irmin/branch.ml
  52. +1 −1 src/irmin/branch.mli
  53. +226 −191 src/irmin/commit.ml
  54. +15 −14 src/irmin/commit.mli
  55. +56 −34 src/irmin/conf.ml
  56. +41 −12 src/irmin/conf.mli
  57. +115 −107 src/irmin/contents.ml
  58. +31 −21 src/irmin/contents.mli
  59. +3 −4 src/irmin/diff.ml
  60. +2 −2 src/irmin/diff.mli
  61. +111 −79 src/irmin/dot.ml
  62. +10 −4 src/irmin/dot.mli
  63. +25 −21 src/irmin/hash.ml
  64. +22 −14 src/irmin/hash.mli
  65. +10 −9 src/irmin/info.ml
  66. +15 −8 src/irmin/info.mli
  67. +124 −77 src/irmin/irmin.ml
  68. +985 −900 src/irmin/irmin.mli
  69. +13 −17 src/irmin/lock.ml
  70. +6 −3 src/irmin/lock.mli
  71. +245 −243 src/irmin/merge.ml
  72. +73 −47 src/irmin/merge.mli
  73. +167 −157 src/irmin/node.ml
  74. +42 −35 src/irmin/node.mli
  75. +121 −107 src/irmin/object_graph.ml
  76. +34 −32 src/irmin/object_graph.mli
  77. +15 −16 src/irmin/path.ml
  78. +1 −1 src/irmin/path.mli
  79. +776 −371 src/irmin/s.ml
  80. +36 −31 src/irmin/slice.ml
  81. +5 −7 src/irmin/slice.mli
  82. +494 −475 src/irmin/store.ml
  83. +2 −1 src/irmin/store.mli
  84. +7 −1 src/irmin/sync.ml
  85. +3 −2 src/irmin/sync.mli
  86. +89 −102 src/irmin/sync_ext.ml
  87. +2 −2 src/irmin/sync_ext.mli
  88. +572 −578 src/irmin/tree.ml
  89. +30 −16 src/irmin/tree.mli
  90. +886 −855 src/irmin/type.ml
  91. +121 −72 src/irmin/type.mli
  92. +184 −118 src/irmin/watch.ml
  93. +46 −20 src/irmin/watch.mli
  94. +36 −26 test/irmin-chunk/test.ml
  95. +1 −0 test/irmin-chunk/test.mli
  96. +30 −20 test/irmin-chunk/test_chunk.ml
  97. +1 −4 test/irmin-fs/test.ml
  98. +5 −7 test/irmin-fs/test_fs.ml
  99. +6 −8 test/irmin-git/test.ml
  100. +62 −58 test/irmin-git/test_git.ml
  101. +1 −2 test/irmin-http/test.ml
  102. +43 −47 test/irmin-http/test_http.ml
  103. +1 −4 test/irmin-mem/test.ml
  104. +3 −1 test/irmin-mem/test_mem.ml
  105. +7 −9 test/irmin-unix/test.ml
  106. +38 −41 test/irmin-unix/test_unix.ml
  107. +645 −418 test/irmin/test.ml
@@ -1,2 +1,3 @@
(lang dune 1.1)
(name irmin)
(using fmt 1.0)
@@ -1,9 +1,8 @@
let what =
"This example demonstrates custom merges on Irmin datastructures.\n\
\n\
It models log files as a sequence of lines, ordered by timestamps.\n\
\n\
The log files of `branch 1` and `branch 2` are merged by using the following \n\
"This example demonstrates custom merges on Irmin datastructures.\n\n\
It models log files as a sequence of lines, ordered by timestamps.\n\n\
The log files of `branch 1` and `branch 2` are merged by using the \
following \n\
strategy:\n\
\ - find the log file corresponding the lowest common ancestor: `lca`\n\
\ - remove the prefix `lca` from `branch 1`; this gives `l1`;\n\
@@ -21,16 +20,14 @@ let time = ref 0L
let failure fmt = Fmt.kstrf failwith fmt

(* A log entry *)
module Entry: sig
module Entry : sig
include Irmin.Type.S
val v: string -> t
val timestamp: t -> int64
end = struct

type t = {
timestamp: int64;
message : string;
}
val v : string -> t

val timestamp : t -> int64
end = struct
type t = { timestamp : int64; message : string }

let compare x y = Int64.compare x.timestamp y.timestamp

@@ -40,66 +37,64 @@ end = struct

let timestamp t = t.timestamp

let pp ppf { timestamp; message } =
Fmt.pf ppf "%04Ld: %s" timestamp message
let pp ppf { timestamp; message } = Fmt.pf ppf "%04Ld: %s" timestamp message

let of_string str =
match String.cut ~sep:": " str with
| None -> Error (`Msg ("invalid entry: " ^ str))
| Some (x, message) ->
| Some (x, message) -> (
try Ok { timestamp = Int64.of_string x; message }
with Failure e -> Error (`Msg e)
with Failure e -> Error (`Msg e) )

let t =
let open Irmin.Type in
record "entry" (fun timestamp message -> { timestamp; message })
|+ field "timestamp" int64 (fun t -> t.timestamp)
|+ field "message" string (fun t -> t.message)
|+ field "timestamp" int64 (fun t -> t.timestamp)
|+ field "message" string (fun t -> t.message)
|> sealr

let t = Irmin.Type.like ~cli:(pp, of_string) ~compare t

let t = Irmin.Type.like ~cli:(pp, of_string) ~compare t
end

(* A log file *)
module Log: sig
module Log : sig
include Irmin.Contents.S
val add: t -> Entry.t -> t
val empty: t
end = struct

val add : t -> Entry.t -> t

val empty : t
end = struct
type t = Entry.t list

let empty = []

let pp_entry = Irmin.Type.pp Entry.t
let lines ppf l = List.iter (Fmt.pf ppf "%a\n" pp_entry ) (List.rev l)

let lines ppf l = List.iter (Fmt.pf ppf "%a\n" pp_entry) (List.rev l)

let of_string str =
let lines = String.cuts ~empty:false ~sep:"\n" str in
try
List.fold_left (fun acc l ->
List.fold_left
(fun acc l ->
match Irmin.Type.of_string Entry.t l with
| Ok x -> x :: acc
| Error (`Msg e) -> failwith e
) [] lines
| Ok x -> x :: acc
| Error (`Msg e) -> failwith e )
[] lines
|> fun l -> Ok l
with Failure e ->
Error (`Msg e)
with Failure e -> Error (`Msg e)

let cli = lines, of_string
let cli = (lines, of_string)

let t = Irmin.Type.(like ~cli (list Entry.t))

let timestamp = function
| [] -> 0L
| e :: _ -> Entry.timestamp e
let timestamp = function [] -> 0L | e :: _ -> Entry.timestamp e

let newer_than timestamp file =
let rec aux acc = function
| [] -> List.rev acc
| h:: _ when Entry.timestamp h <= timestamp -> List.rev acc
| h::t -> aux (h::acc) t
| h :: _ when Entry.timestamp h <= timestamp -> List.rev acc
| h :: t -> aux (h :: acc) t
in
aux [] file

@@ -116,28 +111,26 @@ end = struct
let merge = Irmin.Merge.(option (v t merge))

let add t e = e :: t

end

module Store = Irmin_unix.Git.FS.KV(Log)
module Store = Irmin_unix.Git.FS.KV (Log)

let config = Irmin_git.config ~bare:true Config.root

let log_file = [ "local"; "debug" ]

let all_logs t =
Store.find t log_file >|= function
| None -> Log.empty
| Some l -> l
Store.find t log_file >|= function None -> Log.empty | Some l -> l

(* Persist a new entry in the log. Pretty inefficient as it
reads/writes the whole file every time. *)
let log t fmt =
Printf.ksprintf (fun message ->
Printf.ksprintf
(fun message ->
all_logs t >>= fun logs ->
let logs = Log.add logs (Entry.v message) in
Store.set_exn t ~info:(info "Adding a new entry") log_file logs
) fmt
Store.set_exn t ~info:(info "Adding a new entry") log_file logs )
fmt

let print_logs name t =
all_logs t >|= fun logs ->
@@ -147,33 +140,23 @@ let main () =
Config.init ();
Store.Repo.v config >>= fun repo ->
Store.master repo >>= fun t ->

(* populate the log with some random messages *)
Lwt_list.iter_s (fun msg ->
log t "This is my %s " msg
) [ "first"; "second"; "third"]
Lwt_list.iter_s
(fun msg -> log t "This is my %s " msg)
[ "first"; "second"; "third" ]
>>= fun () ->

Printf.printf "%s\n\n" what;

print_logs "lca" t >>= fun () ->

Store.clone ~src:t ~dst:"test" >>= fun x ->

log x "Adding new stuff to x" >>= fun () ->
log x "Adding new stuff to x" >>= fun () ->
log x "Adding more stuff to x" >>= fun () ->
log x "More. Stuff. To x." >>= fun () ->

log x "More. Stuff. To x." >>= fun () ->
print_logs "branch 1" x >>= fun () ->

log t "I can add stuff on t also" >>= fun () ->
log t "Yes. On t!" >>= fun () ->

log t "Yes. On t!" >>= fun () ->
print_logs "branch 2" t >>= fun () ->

Store.merge_into ~info:(info "Merging x into t") x ~into:t >>= function
| Ok () -> print_logs "merge" t
Store.merge_into ~info:(info "Merging x into t") x ~into:t >>= function
| Ok () -> print_logs "merge" t
| Error _ -> failwith "conflict!"

let () =
Lwt_main.run (main ())
let () = Lwt_main.run (main ())
@@ -1,6 +1,5 @@
open Lwt.Infix

module Store = Irmin_unix.Git.FS.KV(Irmin.Contents.String)
module Store = Irmin_unix.Git.FS.KV (Irmin.Contents.String)

let config =
let head = Store.Git.Reference.of_string "refs/heads/upstream" in
@@ -15,113 +14,106 @@ let info ~user msg () =
let provision repo =
Config.init ();
let provision = info ~user:"Automatic VM provisioning" in

Store.of_branch repo "upstream" >>= fun t ->

Store.Tree.empty |> fun v ->
Store.Tree.add v ["etc"; "manpath"]
"/usr/share/man\n\
/usr/local/share/man"
Store.Tree.add v [ "etc"; "manpath" ] "/usr/share/man\n/usr/local/share/man"
>>= fun v ->
Store.Tree.add v ["bin"; "sh"]
"�����XpN ������� H__PAGEZERO(__TEXT__text__TEXT [...]"
Store.Tree.add v [ "bin"; "sh" ]
"�����XpN ������� H__PAGEZERO(__TEXT__text__TEXT \
[...]"
>>= fun v ->
Store.set_tree_exn t ~info:(provision "Cloning Ubuntu 14.04 Gold Image.") [] v
Store.set_tree_exn t
~info:(provision "Cloning Ubuntu 14.04 Gold Image.")
[] v

(* 2. VM configuration. *)
let sysadmin = info ~user:"Bob the sysadmin"

let configure repo =
Store.of_branch repo "upstream" >>= fun t ->

Lwt_unix.sleep 2. >>= fun () ->
Lwt_unix.sleep 2. >>= fun () ->
Store.clone ~src:t ~dst:"dev" >>= fun t ->

Lwt_unix.sleep 2. >>= fun () ->
Store.set_exn t ~info:(sysadmin "DNS configuration") ["etc";"resolv.conf"]
"domain mydomain.com\nnameserver 128.221.130.23" >>= fun () ->

Lwt_unix.sleep 2. >>= fun () ->
Store.clone ~src:t ~dst:"prod" >>= fun _ ->
Lwt.return_unit
Lwt_unix.sleep 2. >>= fun () ->
Store.set_exn t
~info:(sysadmin "DNS configuration")
[ "etc"; "resolv.conf" ] "domain mydomain.com\nnameserver 128.221.130.23"
>>= fun () ->
Lwt_unix.sleep 2. >>= fun () ->
Store.clone ~src:t ~dst:"prod" >>= fun _ -> Lwt.return_unit

let attack repo =
let info = info ~user:"Remote connection from 132.443.12.444" in

(* 3. Attacker. *)
Store.of_branch repo "prod" >>= fun t ->

Lwt_unix.sleep 2. >>= fun () ->
Store.set_exn t ~info:(info "$ vim /etc/resolv.conf")
["etc";"resolv.conf"]
"domain mydomain.com\n\
nameserver 12.221.130.23"
Store.set_exn t
~info:(info "$ vim /etc/resolv.conf")
[ "etc"; "resolv.conf" ] "domain mydomain.com\nnameserver 12.221.130.23"
>>= fun () ->

Lwt_unix.sleep 2. >>= fun () ->
Store.set_exn t ~info:(info "$ gcc -c /tmp/sh.c -o /bin/sh")
["bin";"sh"]
"�����XpNx ������� H__PAGEZERO(__TEXT__text__TEXT [...]"
Store.set_exn t
~info:(info "$ gcc -c /tmp/sh.c -o /bin/sh")
[ "bin"; "sh" ]
"�����XpNx ������� H__PAGEZERO(__TEXT__text__TEXT \
[...]"

let revert repo =
Store.of_branch repo "prod" >>= fun prod ->
Store.of_branch repo "dev" >>= fun dev ->

Store.of_branch repo "dev" >>= fun dev ->
Store.Head.get prod >>= fun h1 ->
Store.Head.get dev >>= fun h2 ->
Store.Head.get dev >>= fun h2 ->
if h1 <> h2 then (
Printf.printf
"WARNING: the filesystem is different in dev and prod, \
intrusion detected!\n\
Reverting the production system to the dev environment.\n%!";
Lwt_unix.sleep 2. >>= fun () ->
Store.Head.set prod h2
) else
Lwt.return_unit
"WARNING: the filesystem is different in dev and prod, intrusion \
detected!\n\
Reverting the production system to the dev environment.\n\
%!";
Lwt_unix.sleep 2. >>= fun () -> Store.Head.set prod h2 )
else Lwt.return_unit

let () =
let cmd = Sys.argv.(0) in
let help () =
Printf.eprintf
"This demo models a simple deployment scenario in three phases:\n\
\n\
"This demo models a simple deployment scenario in three phases:\n\n\
\ - [%s provision] first a VM is provisioned;\n\
\ - [%s configure] then a sysadmin connects to the machine \n\
\ and install some software packages;\n\
\ - [%s attack] an attacker connects to the machine and \n\
\ injects random code.\n\
\ - [%s revert] the sysadmin revert the VM in a consistent state.\n\
\n\
\ - [%s revert] the sysadmin revert the VM in a consistent state.\n\n\
Run `irmin init -d --root=%s` and Connect your browser \n\
to http://127.0.0.1:8080/graph to see the system state evolving in \n\
real-time during the different phases.\n\
\n\
Using a VCS-style filesystem allows file modifications to be tracked, with \n\
user origin and dates. It also supports quickly reverting to a consistent \n\
real-time during the different phases.\n\n\
Using a VCS-style filesystem allows file modifications to be tracked, \
with \n\
user origin and dates. It also supports quickly reverting to a \
consistent \n\
state when needed.\n"
cmd cmd cmd cmd Config.root
in
if Array.length Sys.argv <> 2 then help ()
else match Sys.argv.(1) with

else
match Sys.argv.(1) with
| "provision" ->
Lwt_main.run (Store.Repo.v config >>= provision);
Printf.printf
"The VM is now provisioned. Run `%s configure` to simulate a sysadmin \n\
configuration.\n" cmd

Lwt_main.run (Store.Repo.v config >>= provision);
Printf.printf
"The VM is now provisioned. Run `%s configure` to simulate a \
sysadmin \n\
configuration.\n"
cmd
| "configure" ->
Lwt_main.run (Store.Repo.v config >>= configure);
Printf.printf
"The VM is now configured. Run `%s attack` to simulate an attack by an \n\
intruder.\n" cmd

Lwt_main.run (Store.Repo.v config >>= configure);
Printf.printf
"The VM is now configured. Run `%s attack` to simulate an attack by \
an \n\
intruder.\n"
cmd
| "attack" ->
Lwt_main.run (Store.Repo.v config >>= attack);
Printf.printf
"The VM has been attacked. Run `%s revert` to revert the VM state to a \
safe one.\n" cmd

| "revert" ->
Lwt_main.run (Store.Repo.v config >>= revert)

| _ -> help ()
Lwt_main.run (Store.Repo.v config >>= attack);
Printf.printf
"The VM has been attacked. Run `%s revert` to revert the VM state \
to a safe one.\n"
cmd
| "revert" -> Lwt_main.run (Store.Repo.v config >>= revert)
| _ -> help ()
Oops, something went wrong.

0 comments on commit cd10359

Please sign in to comment.
You can’t perform that action at this time.