Skip to content
GitLab
Commit 4de1cbc4 authored by Vlad Dumitru's avatar Vlad Dumitru
Browse files

everything compiles, so it's commit time

parent e25f57c2
Hide whitespace changes
Inline Side-by-side
assets/src/Page/Tier.elm
View file @ 4de1cbc4
......@@ -96,7 +96,7 @@ viewTier tier =
[ viewProperties
[ ( "uuid", text tier.uuid )
, ( "key", text <| Key.toString tier.key )
, ( "branches", div [] <| (Dict.toList tier.branches |> List.map branch) )
, ( "versions", div [] <| (Dict.toList tier.branches |> List.map branch) )
]
]
]
......
assets/src/Page/Tiers.elm
View file @ 4de1cbc4
......@@ -122,9 +122,9 @@ viewTierListing selected expanded tierListing search =
let
version uuid key versionId info =
span [ class "version" ]
[ span [ class "datetime" ] [ text <| "datetime" ++ info.date ]
, span [ class "author" ] [ text <| "author" ++ info.author ]
, span [ class "comment" ] [ text <| "comment" ++ info.comment ]
[ span [ class "datetime" ] [ text info.date ]
, span [ class "author" ] [ text info.author ]
, span [ class "comment" ] [ text info.comment ]
, input
[ type_ "checkbox"
, onCheck <| Select ( uuid, versionId, key )
......
assets/style.scss
View file @ 4de1cbc4
......@@ -642,7 +642,7 @@ p.centered {
font-weight: $code-font-weight;
}
& > .author, & > .message, & > .datetime {
& > .author, & > .comment, & > .datetime {
font-size: 0.75rem;
}
......@@ -650,7 +650,7 @@ p.centered {
flex-basis: 20%;
}
& > .message {
& > .comment {
flex-basis: 50%;
}
......@@ -684,3 +684,23 @@ a.key {
margin: 0 0.25rem;
}
}
.branch {
display: flex;
flex-flow: row nowrap;
align-items: baseline;
& > .name {
font-family: $code-font-stack;
font-size: 0.75rem;
flex-basis: 10%;
flex-shrink: 0;
}
& > .version {
flex-basis: 90%;
}
width: 100%;
}
bin/action.ml
View file @ 4de1cbc4
open Core
let src = Logs.Src.create "action" ~doc:"actions"
module Log = (val Logs.src_log src : Logs.LOG)
let read_textgrid path =
......@@ -106,6 +108,7 @@ let identify_textgrid ~db ~textgrid =
let put ~db ~tiers ~tier_name ~key =
Log.info (fun m -> m "put %s -> %s" tier_name (String.concat ~sep:"/" key)) ;
let tier =
List.find tiers
~f:(fun t -> String.equal tier_name (Annotation.Tier.name t)) in
......@@ -132,6 +135,7 @@ let most_recent_version bkt versions =
Result.map doc ~f:(fun doc -> hash, doc, meta)
let update ~db ~tiers ~tier_name ~uuid =
Log.info (fun m -> m "update %s -> %s" tier_name (Uuidm.to_string uuid)) ;
let tier =
List.find tiers
~f:(fun t -> String.equal tier_name (Annotation.Tier.name t)) in
......@@ -196,24 +200,49 @@ let rec has_prefix ~prefix key =
| [], [] ->
true
let list_tiers ?prefix db =
let has_one_of_tags ?tags doc_tags =
match tags with
| Some tags -> not (Set.are_disjoint tags doc_tags)
| None -> true
let list_tiers ?prefix ?tags db =
Log.info (fun m ->
m "list_tiers prefix=%a tags=%a"
Fmt.(option ~none:(any "(none)") (list ~sep:(any "/") string)) prefix
Fmt.(option ~none:(any "(none)") (list ~sep:(any ",@ ") string)) (Option.map ~f:Set.to_list tags)) ;
let key_index =
Speechcake.Storage.list db.Speechcake.storage
|> List.map ~f:(fun uuid ->
Result.map (Speechcake.get_latest db uuid) ~f:(fun doc -> uuid, doc))
|> List.bind ~f:(function
| Ok doc -> [doc]
| Error (`Decoding_error e) -> Fmt.epr "%s@." (Decoders_yojson.Basic.Decode.string_of_error e); []
| Error (`Document_not_found n) -> Fmt.epr "document not found: %s@." n; []
| Error (`Tag_not_found t) -> Fmt.epr "tag not found: %s@." t; []
| Error (`Not_a_version_block) -> Fmt.epr "not a version block@."; []
| Error (`Block_not_found b) -> Fmt.epr "block not found: %08Lx@." b; [])
| Ok doc ->
[ doc ]
| Error (`Decoding_error e) ->
Log.err (fun m ->
m "decoding error: %s"
(Decoders_yojson.Basic.Decode.string_of_error e)) ;
[]
| Error (`Document_not_found n) ->
Log.err (fun m -> m "document not found: %s" n) ;
[]
| Error (`Tag_not_found t) ->
Log.err (fun m -> m "tag not found: %s" t) ;
[]
| Error (`Not_a_version_block) ->
Log.err (fun m -> m "not a version block") ;
[]
| Error (`Block_not_found b) ->
Log.err (fun m -> m "block not found: %08Lx" b) ;
[])
in
match prefix with
| Some prefix ->
List.filter key_index ~f:(fun doc -> has_prefix ~prefix (snd (snd doc)).key)
key_index
|> List.filter ~f:(fun doc -> has_prefix ~prefix (snd (snd doc)).Speechcake.key)
|> List.filter ~f:(fun doc -> has_one_of_tags ?tags (snd (snd doc)).Speechcake.tags)
| None ->
key_index
|> List.filter ~f:(fun doc -> has_one_of_tags ?tags (snd (snd doc)).Speechcake.tags)
(*
......
bin/codec.ml
View file @ 4de1cbc4
......@@ -10,12 +10,13 @@ let encode_uuid : Uuidm.t encoder =
let encode_key : string list encoder =
fun parts -> `String (String.concat ~sep:"/" parts)
let encode_tier_listing : (string * string list) list encoder =
let encode_tier_listing : (string * string list * (string, String.comparator_witness) Set.t) list encoder =
fun tier_listing ->
List.map tier_listing ~f:(fun (uuid, key) ->
List.map tier_listing ~f:(fun (uuid, key, tags) ->
`Assoc
[ "uuid", `String uuid
; "key", encode_key key
; "tags", `List (Set.to_list tags |> List.map ~f:(fun t -> `String t))
])
|> fun tier_listing -> `List tier_listing
......
bin/konditorei.ml
View file @ 4de1cbc4
......@@ -27,11 +27,15 @@ let cors inner_handler request =
Dream.add_header "access-control-allow-origin" "*" response
let get_tiers db ?prefix _ =
let tiers = Action.list_tiers ?prefix db in
let get_tiers db ?prefix request =
let tags =
Dream.query "tags" request
|> Option.map ~f:(String.split ~on:',')
|> Option.map ~f:(Set.of_list (module String)) in
let tiers = Action.list_tiers ?prefix ?tags db in
let body =
tiers
|> List.map ~f:(fun (uuid, (_, doc)) -> uuid, doc.Speechcake.key)
|> List.map ~f:(fun (uuid, (_, doc)) -> uuid, doc.Speechcake.key, doc.Speechcake.tags)
|> C.encode_tier_listing
|> Yojson.Safe.to_string in
Dream.json body
......@@ -213,15 +217,59 @@ let store_tier db ~tiers request =
| Error e -> (name, Error e)
end
let set_key db ~uuid ?(tag="latest") key =
let open Result.Monad_infix in
let uuid = Uuidm.to_string uuid in
Speechcake.get_tagged db uuid ~tag
>>| fun (parent, doc) ->
let doc' = { doc with key } in
let comment =
Fmt.(str "move from `%a`" (list ~sep:(any "/") string) doc.key) in
Speechcake.put ~parents:[parent] ~comment ~tag db uuid doc'
let set_key db request =
let perform ~uuid ?(tag="latest") key =
let open Result.Monad_infix in
Uuidm.of_string uuid |> Result.of_option ~error:(`Invalid_UUID uuid)
>>= fun uuid ->
Speechcake.get_tagged db (Uuidm.to_string uuid) ~tag
>>= fun (parent, doc) ->
let doc' = { doc with key } in
let comment =
Fmt.(str "move from `%a`" (list ~sep:(any "/") string) doc.key) in
Speechcake.put ~parents:[parent] ~comment ~tag db (Uuidm.to_string uuid) doc'
>>| fun version ->
Speechcake.update_key_index db.key_index key uuid ;
version
in
let open Lwt.Syntax in
let uuid = Dream.param "uuid" request in
let tag = Dream.param "tag" request in
let* key = Dream.body request in
match perform ~uuid ~tag (String.split ~on:'/' key) with
| Ok ver ->
Dream.respond ~status:`Created (Fmt.str "%08Lx" ver)
| Error e ->
Dream.json ~status:`Internal_Server_Error (json_of_error e |> Yojson.Basic.to_string)
let set_tags db request =
let perform ~uuid ?(tag="latest") tags =
let open Result.Monad_infix in
Uuidm.of_string uuid |> Result.of_option ~error:(`Invalid_UUID uuid)
>>= fun uuid ->
Speechcake.get_tagged db (Uuidm.to_string uuid) ~tag
>>= fun (parent, doc) ->
let doc' = { doc with tags } in
let comment = "change tags" in
Speechcake.put ~parents:[parent] ~comment ~tag db (Uuidm.to_string uuid) doc'
>>| fun version ->
Speechcake.update_tag_index db.tag_index uuid tags ;
version
in
let open Lwt.Syntax in
let uuid = Dream.param "uuid" request in
let tag = Dream.param "tag" request in
let* tags = Dream.body request in
let tags =
Decoders_yojson.Basic.Decode.(decode_string (list string) tags)
|> Result.map ~f:(Set.of_list (module String))
|> Result.map_error ~f:(fun e -> `Decoding_error e) in
let result = Result.bind tags ~f:(perform ~uuid ~tag) in
match result with
| Ok ver ->
Dream.respond ~status:`Created (Fmt.str "%08Lx" ver)
| Error e ->
Dream.json ~status:`Internal_Server_Error (json_of_error e |> Yojson.Basic.to_string)
let combine_named_results l =
......@@ -285,6 +333,41 @@ let get_checkout db request =
| Error e ->
Dream.respond ~status:`Bad_Request (D.string_of_error e)
let export_tier db request =
let result =
let open Result.Monad_infix in
let uuid = Dream.param "uuid" request in
let tag = Dream.param "tag" request in
Speechcake.bucket db uuid
>>= fun bucket ->
Ok (Hashtbl.to_alist (Speechcake.Storage.Bucket.versions bucket))
>>= fun versions ->
Speechcake.get_tagged db uuid ~tag
>>| fun latest -> uuid, versions, latest in
match result with
| Ok (uuid, _versions, (parent, latest)) ->
let info =
Speechcake.Info.known
~uuid:(Option.value_exn (Uuidm.of_string uuid))
~parents:[parent]
(Annotation.Tier.name latest.data) in
let tier = Speechcake.stamp info latest.data in
let body =
Speechcake.Annotation.Textgrid.Write.to_string [ None, tier ] in
Dream.respond ~status:`OK body
| Error (`Document_not_found name)
| Error (`Invalid_UUID name) ->
Dream.respond ~status:`Not_Found ("document " ^ name)
| Error (`Tag_not_found tag) ->
Dream.respond ~status:`Not_Found ("tag " ^ tag)
| Error (`Block_not_found h) ->
Dream.respond ~status:`Internal_Server_Error (Fmt.str "block not found: %08Lx" h)
| Error (`Not_a_version_block) ->
Dream.respond ~status:`Internal_Server_Error (Fmt.str "not a version block")
| Error (`Decoding_error e) ->
Dream.respond ~status:`Bad_Request (Decoders_yojson.Basic.Decode.string_of_error e)
let () =
let open Dream in
initialize_log ~level:`Debug () ;
......@@ -310,11 +393,11 @@ let () =
; get "/tier/:uuid" (list_branches db)
(* tier metadata setters *)
; put "/tier/:uuid/at/:tag/key" not_found
; put "/tier/:uuid/at/:tag/tags" not_found
; put "/tier/:uuid/head/:tag/key" (set_key db)
; put "/tier/:uuid/head/:tag/tags" (set_tags db)
(* tier -> textgrid export *)
; get "/tier/:uuid/at/:tag/export" not_found
; get "/tier/:uuid/head/:tag/export" (export_tier db)
(* check-in *)
; post "/checkin" (put_textgrid db)
......
lib/speechcake.ml
View file @ 4de1cbc4
......@@ -121,10 +121,15 @@ let unstamp (tier : Annotation.tier) =
module Uuid = struct
include Uuidm
module T = struct
include Uuidm
let sexp_of_t t = Sexp.Atom (Uuidm.to_string t)
let hash = Hashtbl.hash
let sexp_of_t t = Sexp.Atom (Uuidm.to_string t)
let hash = Hashtbl.hash
end
include T
include Comparable.Make (T)
end
......@@ -216,11 +221,25 @@ module Fingerprint = struct
end
type t =
{ storage : Storage.db
; key_index : (Key.t, Uuid.t) Hashtbl.t
{ storage : Storage.db
; 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
}
let update_key_index ki key uuid =
Hashtbl.set ki ~key ~data:uuid
let update_fingerprint_index fi fingerprint uuid =
Hashtbl.set fi ~key:fingerprint ~data:uuid
let update_tag_index ti uuid tags =
Set.to_list tags
|> List.iter ~f:(fun tag ->
Hashtbl.update ti tag ~f:(function
| Some uuids -> Set.add uuids uuid
| None -> Set.singleton (module Uuid) uuid))
let of_storage storage =
let open Result.Monad_infix in
let keys = Storage.list storage in
......@@ -228,29 +247,30 @@ let of_storage storage =
List.map keys ~f:(fun k ->
Hashtbl.find_exn storage k
|> fun bucket -> Storage.Bucket.tagged bucket "latest"
>>| fun latest -> k, latest)
>>= fun (_ver, json) -> document_of_json json
>>| fun doc -> k, doc)
|> List.filter_map ~f:Result.ok in
let key_index =
List.map documents ~f:(fun (key, (_, doc)) ->
document_of_json doc
>>= fun doc ->
Uuidm.of_string key |> Result.of_option ~error:(`Invalid_UUID key)
>>| fun uuid ->
doc.key, uuid)
|> List.filter_map ~f:Result.ok
|> Hashtbl.of_alist_exn (module Key) in
let fingerprint_index =
List.map documents ~f:(fun (key, (_, doc)) ->
document_of_json doc
>>= fun doc ->
Uuidm.of_string key |> Result.of_option ~error:(`Invalid_UUID key)
let key_index = Hashtbl.create (module Key) in
let _ = List.map documents ~f:(fun (key, doc) ->
Uuidm.of_string key
|> Result.of_option ~error:(`Invalid_UUID key)
>>| fun uuid -> update_key_index key_index doc.key uuid) in
let fingerprint_index = Hashtbl.create (module Fingerprint) in
let _ = List.map documents ~f:(fun (key, doc) ->
Uuidm.of_string key
|> Result.of_option ~error:(`Invalid_UUID key)
>>| fun uuid ->
let fp = Fingerprint.of_tier doc.data in
fp, uuid)
|> List.filter_map ~f:Result.ok
|> Hashtbl.of_alist_exn (module Fingerprint)
update_fingerprint_index fingerprint_index fp uuid) in
let tag_index = Hashtbl.create (module String) in
let _ = List.map documents ~f:(fun (key, doc) ->
Uuidm.of_string key
|> Result.of_option ~error:(`Invalid_UUID key)
>>| fun uuid ->
update_tag_index tag_index uuid doc.tags)
in
{ storage ; key_index ; fingerprint_index }
{ storage ; key_index ; fingerprint_index ; tag_index }
let pp =
let open Fmt in
......@@ -270,6 +290,7 @@ let init () =
{ storage = Storage.init ()
; key_index = Hashtbl.create (module Key)
; fingerprint_index = Hashtbl.create (module Fingerprint)
; tag_index = Hashtbl.create (module String)
}
let load path =
......
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