Commit 737c8aac authored by Vlad Dumitru's avatar Vlad Dumitru
Browse files

working demo? maybe

parent 31cf6e2e
......@@ -4,9 +4,7 @@ open Core
module C = Codec
module D = Decoders_yojson.Safe.Decode
let repo_path = "/tmp/.cake"
let init () =
let init repo_path =
begin match Speechcake.load repo_path with
| Ok db -> db
| Error _ -> failwith "could not load"
......@@ -413,10 +411,10 @@ let diff_tiers db request =
let run_server interface port =
let run_server repo_path interface port =
let open Dream in
initialize_log ~level:`Debug () ;
let db = init () in
let db = init repo_path in
run ~interface ~port
@@ logger
@@ cors
......@@ -464,13 +462,16 @@ let cmd =
let open Cmdliner in
let open Term in
let doc = "start a Konditorei server" in
let repo_path =
let doc = "Location of the repository" in
Arg.(value & opt string "/tmp/cake" & info [ "r"; "repo" ] ~doc) in
let interface =
let doc = "Interface to listen on" in
Arg.(value & opt string "localhost" & info [ "i"; "interface" ] ~doc) in
let port =
let doc = "Port to listen on" in
Arg.(value & opt int 8080 & info [ "p"; "port" ] ~doc) in
( const run_server $ interface $ port
( const run_server $ repo_path $ interface $ port
, Term.info "konditorei" ~doc
)
......
#!/bin/bash
mkdir -p artifacts
git ls-files -z | xargs -0 tar c | \
podman run --rm -i ocamlpro/ocaml:4.12 \
sh -uexc \
'{ tar x &&
sudo apk add bash openssl-libs-static &&
opam switch create . --deps ocaml-system &&
opam exec -- dune build --profile=static;
} >&2 && tar cf _build/default/bin/*.exe' | \
tar vx -C artifacts
open Base
open Core
......@@ -125,6 +125,11 @@ module Uuid = struct
include Uuidm
let sexp_of_t t = Sexp.Atom (Uuidm.to_string t)
let t_of_sexp = function
| Sexp.Atom a -> Option.value_exn (Uuidm.of_string a)
| Sexp.List _ -> failwith "not a Uuid"
let hash = Hashtbl.hash
end
......@@ -175,7 +180,17 @@ module Key = struct
type t = string list
let pp = Fmt.(list ~sep:(any "/") string)
let sexp_of_t t = Sexp.List (List.map ~f:(fun a -> Sexp.Atom a) t)
let t_of_sexp = function
| Sexp.List elts ->
List.filter_map elts ~f:(function
| Sexp.Atom a -> Some a
| Sexp.List _ -> None)
| Sexp.Atom _ ->
failwith "not a Key"
let hash = Hashtbl.hash
let compare = List.compare String.compare
end
......@@ -187,7 +202,7 @@ end
module Fingerprint = struct
module T = struct
type t = (Int.t, Int.comparator_witness) Set.t
type t = (Int.t, Int.comparator_witness) Base.Set.t
let pp ppf t =
Set.to_list t |> Fmt.(list int ppf)
......@@ -196,6 +211,15 @@ module Fingerprint = struct
Sexp.List
(List.map (Set.to_list t) ~f:(fun x -> Sexp.Atom (Int.to_string x)))
let t_of_sexp = function
| Sexp.List elts ->
List.filter_map elts ~f:(function
| Sexp.Atom a -> Some (Int.of_string a)
| Sexp.List _ -> None)
|> Set.of_list (module Int)
| Sexp.Atom _ ->
failwith "not a Fingerprint"
let hash = Hashtbl.hash
let compare x y =
......@@ -216,7 +240,7 @@ module Fingerprint = struct
|> List.sort ~compare:Int.compare
|> List.rev
|> fun l -> List.take l n
|> Set.of_list (module Int)
|> Base.Set.of_list (module Int)
end
type t =
......@@ -224,6 +248,7 @@ type t =
; key_index : (Key.t, Uuid.t) Hashtbl.t
; fingerprint_index : (Fingerprint.t, Uuid.t) Hashtbl.t
; tag_index : (string, (Uuid.t, Uuid.comparator_witness) Set.t) Hashtbl.t
; path : string option
}
let fingerprint_size = 25
......@@ -251,7 +276,7 @@ let update_tag_index ti uuid tags =
| Some uuids -> Set.add uuids uuid
| None -> Set.singleton (module Uuid) uuid))
let of_storage storage =
let of_storage ?path storage =
let open Result.Monad_infix in
let keys = Storage.list storage in
let documents =
......@@ -281,7 +306,7 @@ let of_storage storage =
update_tag_index tag_index uuid doc.tags)
in
{ storage ; key_index ; fingerprint_index ; tag_index }
{ storage ; key_index ; fingerprint_index ; tag_index ; path }
let pp =
let open Fmt in
......@@ -297,16 +322,17 @@ let pp =
; field "fingerprint_index" (fun t -> t.fingerprint_index) pp_fingerprint_index
]
let init () =
let init ?path () =
{ storage = Storage.init ()
; key_index = Hashtbl.create (module Key)
; fingerprint_index = Hashtbl.create (module Fingerprint)
; tag_index = Hashtbl.create (module String)
; path
}
let load path =
let open Result.Monad_infix in
Storage.load path >>| of_storage
Storage.load path >>| of_storage ~path
let bucket db k =
match Storage.bucket db.storage k with
......@@ -422,6 +448,12 @@ let put ?author ?comment ?date ~parents ?(tag="latest") db k v =
Hashtbl.set db.fingerprint_index
~key:fingerprint
~data:(Option.value_exn (Uuidm.of_string k)) ;
begin match db.path with
| Some path ->
Out_channel.write_all (path ^ "/" ^ k) ~data:(Yojson.Basic.to_string (Storage.Bucket.dump bucket)) ;
Logs.info (fun m -> m "wrote %s" k)
| None -> ()
end ;
version
let identify db tier =
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment