Skip to content
GitLab
Menu
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in
Toggle navigation
Menu
Open sidebar
Vlad Dumitru
speechcake
Commits
f80b0b26
Commit
f80b0b26
authored
Aug 25, 2021
by
Vlad Dumitru
Browse files
another big chunk of work
parent
475d901c
Changes
15
Hide whitespace changes
Inline
Side-by-side
assets/src/Api.elm
View file @
f80b0b26
...
...
@@ -163,3 +163,26 @@ putTags flags uuid branch tags toMsg =
,
timeout
=
Nothing
,
tracker
=
Nothing
}
postDiff
:
Flags
->
List
(
String
,
String
)
->
(
Result
Error
String
->
msg
)
->
Cmd
msg
postDiff
flags
query
toMsg
=
let
itemEncoder
(
uuid
,
ver
)
=
JE
.
object
[
(
"
uuid"
,
JE
.
string
uuid
)
,
(
"
version"
,
JE
.
string
ver
)
]
queryEncoder
=
JE
.
list
itemEncoder
in
request
{
method
=
"
POST"
,
headers
=
[]
,
url
=
url
flags
[
"
util"
,
"
diff-tiers"
]
[]
,
body
=
jsonBody
<|
queryEncoder
query
,
expect
=
expectString
toMsg
,
timeout
=
Nothing
,
tracker
=
Nothing
}
assets/src/Data/StoreRequest.elm
View file @
f80b0b26
...
...
@@ -11,7 +11,7 @@ import Data.Uuid as Uuid exposing (Uuid)
type
StoreAction
=
Overwrite
{
uuid
:
Uuid
,
key
:
Key
,
name
:
String
}
=
Overwrite
{
uuid
:
Uuid
,
key
:
Key
,
name
:
String
,
forbiddenBranches
:
List
String
,
branchName
:
String
}
|
NewBucket
{
key
:
Key
,
name
:
String
}
type
alias
StoreRequest
=
...
...
@@ -24,12 +24,13 @@ type alias StoreRequest =
encodeStoreAction
:
StoreAction
->
Value
encodeStoreAction
storeAction
=
case
storeAction
of
Overwrite
{
uuid
,
name
}
->
Overwrite
{
uuid
,
name
,
branchName
}
->
E
.
list
identity
[
E
.
string
"
overwrite"
,
E
.
object
[
(
"
uuid"
,
Uuid
.
encode
uuid
)
,
(
"
name"
,
E
.
string
name
)
,
(
"
branch"
,
E
.
string
branchName
)
]
]
...
...
assets/src/Data/TextgridInfo.elm
View file @
f80b0b26
...
...
@@ -9,6 +9,7 @@ import Json.Decode as D exposing (Decoder)
import
Data
.
Key
as
Key
exposing
(
Key
)
import
Data
.
Uuid
as
Uuid
exposing
(
Uuid
)
import
Data
.
Version
as
Version
...
...
@@ -16,11 +17,13 @@ type alias Match =
{
uuid
:
Uuid
,
key
:
Key
,
percent
:
Int
,
forbiddenBranches
:
List
String
}
type
TierInfo
=
Known
Uuid
Key
String
=
Known
{
uuid
:
Uuid
,
key
:
Key
,
version
:
String
,
forbiddenBranches
:
List
String
}
|
Fresh
(
List
Match
)
|
Exactly
{
uuid
:
Uuid
,
version
:
String
,
branch
:
Maybe
String
,
key
:
Key
,
meta
:
Version
.
Metadata
}
|
ConflictResolution
Uuid
(
List
String
)
|
Error
String
|
Merge
String
...
...
@@ -39,10 +42,21 @@ freshDecoder =
knownDecoder
:
Decoder
TierInfo
knownDecoder
=
D
.
map
3
Known
D
.
map
4
(
\
u
k
v
f
->
Known
{
uuid
=
u
,
key
=
k
,
version
=
v
,
forbiddenBranches
=
f
})
(
D
.
field
"
uuid"
Uuid
.
decoder
)
(
D
.
field
"
key"
Key
.
decoder
)
(
D
.
field
"
version"
D
.
string
)
(
D
.
field
"
forbiddenBranches"
<|
D
.
list
D
.
string
)
exactlyDecoder
:
Decoder
TierInfo
exactlyDecoder
=
D
.
map5
(
\
u
v
b
k
m
->
Exactly
{
uuid
=
u
,
version
=
v
,
branch
=
b
,
key
=
k
,
meta
=
m
})
(
D
.
field
"
uuid"
Uuid
.
decoder
)
(
D
.
at
[
"
version"
,
"
id"
]
D
.
string
)
(
D
.
maybe
(
D
.
field
"
branch"
D
.
string
))
(
D
.
field
"
key"
Key
.
decoder
)
(
D
.
at
[
"
version"
,
"
meta"
]
Version
.
metadataDecoder
)
conflictResolutionDecoder
:
Decoder
TierInfo
conflictResolutionDecoder
=
...
...
@@ -57,10 +71,11 @@ errorDecoder =
matchDecoder
:
Decoder
Match
matchDecoder
=
D
.
map
3
Match
D
.
map
4
Match
(
D
.
field
"
uuid"
Uuid
.
decoder
)
(
D
.
field
"
key"
Key
.
decoder
)
(
D
.
field
"
percent"
D
.
int
)
(
D
.
field
"
forbiddenBranches"
<|
D
.
list
D
.
string
)
decoder
:
Decoder
TextgridInfo
decoder
=
...
...
@@ -76,6 +91,7 @@ tierInfoDecoder =
case
typ
of
"
fresh"
->
freshDecoder
"
known"
->
knownDecoder
"
exactly"
->
exactlyDecoder
"
error"
->
errorDecoder
"
conflict-resolution"
->
conflictResolutionDecoder
other
->
D
.
fail
<|
"
unknown tag "
++
other
)
...
...
assets/src/Data/Version.elm
View file @
f80b0b26
module
Data
.
Version
exposing
(
Metadata
,
Version
,
decoder
,
decoder
,
metadataDecoder
)
import
Json
.
Decode
as
D
exposing
(
Decoder
)
...
...
assets/src/Page/Tiers.elm
View file @
f80b0b26
...
...
@@ -5,6 +5,7 @@ import Set exposing (Set)
import
Browser
exposing
(
Document
)
import
File
exposing
(
File
)
import
File
.
Download
import
Html
exposing
(
Html
,
a
,
button
,
div
,
h1
,
header
,
input
,
label
,
main_
,
p
,
span
,
strong
,
sup
,
table
,
text
,
thead
,
th
,
td
,
tr
)
import
Html
.
Attributes
exposing
(
class
,
disabled
,
for
,
href
,
id
,
placeholder
,
type_
)
import
Html
.
Events
exposing
(
onCheck
,
onClick
,
onInput
)
...
...
@@ -68,6 +69,8 @@ type Msg
|
ToggleTagFilter
String
Bool
|
HideTagFilter
|
ShowTagFilter
|
RequestDiff
|
GotDiff
(
Result
Error
String
)
...
...
@@ -137,6 +140,14 @@ viewHeader tagFilterShown path selectedTiers allTags selectedTags =
[
viewTierPath
path
,
h1
[]
[
text
name
,
if
selectedCount
==
2
then
button
[
class
"
green"
,
class
"
level"
,
class
"
small"
,
class
"
pull-right"
,
onClick
RequestDiff
]
[
text
"
Δ"
]
else
text
"
"
,
if
selectedCount
>
0
then
a
[
class
"
button"
...
...
@@ -294,6 +305,23 @@ incrementTagCount maybeInt =
update
:
Msg
->
Model
->
(
Model
,
Cmd
Msg
)
update
msg
model
=
case
(
msg
,
model
.
state
)
of
(
GotDiff
result
,
_
)
->
case
result
of
Ok
diff
->
(
model
,
File
.
Download
.
string
"
diff.stg"
"
text/plain"
diff
)
Err
e
->
(
{
model
|
state
=
Error
e
}
,
Cmd
.
none
)
(
RequestDiff
,
ShowingTiers
showingTiersState
)
->
(
model
,
Api
.
postDiff
model
.
flags
(
Dict
.
keys
showingTiersState
.
selected
)
GotDiff
)
(
ShowTagFilter
,
ShowingTiers
showingTiersState
)
->
(
{
model
|
state
=
ShowingTiers
{
showingTiersState
|
tagFilterShown
=
True
}
}
,
Cmd
.
none
...
...
assets/src/Page/Upload.elm
View file @
f80b0b26
...
...
@@ -5,7 +5,7 @@ import Set exposing (Set)
import
Browser
exposing
(
Document
)
import
Html
exposing
(
Attribute
,
Html
,
a
,
button
,
div
,
input
,
h1
,
header
,
label
,
p
,
span
,
strong
,
text
)
import
Html
.
Attributes
exposing
(
class
,
classList
,
href
,
placeholder
,
type_
)
import
Html
.
Attributes
exposing
(
class
,
classList
,
disabled
,
href
,
placeholder
,
type_
)
import
Html
.
Events
exposing
(
onClick
,
onInput
,
preventDefaultOn
)
import
File
exposing
(
File
)
...
...
@@ -19,6 +19,7 @@ import Data.StoreRequest exposing (StoreAction(..), StoreRequest)
import
Data
.
TextgridInfo
as
TextgridInfo
exposing
(
Match
,
TextgridInfo
,
TierInfo
)
import
Data
.
TierListing
as
TierListing
exposing
(
TierListing
)
import
Data
.
Uuid
as
Uuid
exposing
(
Uuid
(
..
))
import
Data
.
Version
as
Version
import
Api
import
Error
exposing
(
Error
)
...
...
@@ -70,6 +71,7 @@ type Msg
|
DownloadTextgrid
String
|
GetTiers
|
GotTiers
(
Result
Error
TierListing
)
|
SetBranchName
{
tierName
:
String
,
branchName
:
String
}
...
...
@@ -110,7 +112,11 @@ basesOfTierInfo tierInfo =
List
.
map
baseOfMatch
matches
|>
Set
.
fromList
TextgridInfo
.
Known
_
key
_
->
TextgridInfo
.
Known
{
key
}
->
Key
.
split
key
|>
Tuple
.
first
|>
Set
.
singleton
TextgridInfo
.
Exactly
{
key
}
->
Key
.
split
key
|>
Tuple
.
first
|>
Set
.
singleton
...
...
@@ -134,10 +140,40 @@ gotTextgridInfo { tiers, digest } =
|>
(
\
tiers_
->
ShowingInfoState
digest
allBases
Nothing
tiers_
Nothing
)
|>
ShowingInfo
updateBranchName
:
String
->
String
->
Dict
String
(
TierInfo
,
Maybe
StoreAction
)
->
Dict
String
(
TierInfo
,
Maybe
StoreAction
)
updateBranchName
tierName
branchName
=
Dict
.
update
tierName
(
\
value
->
case
value
of
Just
(
tierInfo
,
maybeStoreAction
)
->
case
maybeStoreAction
of
Just
(
Overwrite
overwriteAction
)
->
Just
(
tierInfo
,
Just
<|
Overwrite
{
overwriteAction
|
branchName
=
branchName
}
)
_
->
Just
(
tierInfo
,
maybeStoreAction
)
Nothing
->
Nothing
)
update
:
Msg
->
Model
->
(
Model
,
Cmd
Msg
)
update
msg
model
=
case
msg
of
SetBranchName
{
tierName
,
branchName
}
->
case
model
.
state
of
ShowingInfo
showingInfoState
->
(
{
model
|
state
=
ShowingInfo
{
showingInfoState
|
tiers
=
updateBranchName
tierName
branchName
showingInfoState
.
tiers
}
}
,
Cmd
.
none
)
_
->
(
model
,
Cmd
.
none
)
GetTiers
->
(
model
,
Api
.
getTiers
model
.
flags
[]
GotTiers
...
...
@@ -272,7 +308,7 @@ update msg model =
-- VIEW -----------------------------------------------------------------------
viewMatch
:
String
->
Match
->
Html
Msg
viewMatch
name
{
uuid
,
key
,
percent
}
=
viewMatch
name
{
uuid
,
key
,
percent
,
forbiddenBranches
}
=
let
colorClass
:
Int
->
Attribute
Msg
colorClass
value
=
...
...
@@ -288,6 +324,8 @@ viewMatch name { uuid, key, percent } =
{
uuid
=
uuid
,
key
=
key
,
name
=
name
,
forbiddenBranches
=
forbiddenBranches
,
branchName
=
"
"
}
in
div
[
class
"
match"
]
...
...
@@ -323,11 +361,28 @@ viewNewDestination base name =
[
text
"
Store here"
]
]
viewStoreAction
:
String
->
StoreAction
->
Html
Msg
viewStoreAction
name
storeAction
=
viewStoreAction
:
String
->
TierInfo
->
StoreAction
->
Html
Msg
viewStoreAction
name
tierInfo
storeAction
=
let
branchSelector
forbiddenBranches
=
case
(
tierInfo
,
storeAction
)
of
(
TextgridInfo
.
Fresh
_
,
Overwrite
_
)
->
[
p
[]
<|
[
text
"
You will need to specify a branch name for this new version. "
,
text
"
You can choose any name, except for the ones already in use: "
]
++
(
List
.
map
(
\
b
->
strong
[]
[
text
b
])
forbiddenBranches
|>
List
.
intersperse
(
text
"
, "
))
++
[
text
"
."
]
,
div
[
class
"
row"
]
[
input
[
type_
"
text"
,
onInput
<|
\
i
->
SetBranchName
{
tierName
=
name
,
branchName
=
i
}
]
[]
]
]
_
->
[]
in
case
storeAction
of
Overwrite
{
uuid
,
key
}
->
div
[
class
"
container"
]
Overwrite
{
uuid
,
key
,
forbiddenBranches
,
branchName
}
->
div
[
class
"
container"
]
<|
[
div
[
class
"
row"
]
[
div
[
class
"
name"
]
[
text
name
]
,
button
[
onClick
<|
InsertAction
name
Nothing
]
...
...
@@ -337,10 +392,11 @@ viewStoreAction name storeAction =
[
text
"
will update document "
,
span
[
class
"
uuid"
]
[
text
<|
Uuid
.
toString
uuid
]
,
text
"
, stored at "
,
div
[
class
"
key"
]
[
text
<|
Key
.
toString
key
]
,
span
[
class
"
key"
]
[
text
<|
Key
.
toString
key
]
,
text
"
."
]
]
++
branchSelector
forbiddenBranches
NewBucket
{
key
}
->
div
[
class
"
container"
]
...
...
@@ -357,12 +413,12 @@ viewStoreAction name storeAction =
]
viewKnownTier
:
String
->
Uuid
->
Key
->
String
->
Html
Msg
viewKnownTier
name
uuid
key
version
=
viewKnownTier
:
String
->
Uuid
->
Key
->
String
->
List
String
->
Html
Msg
viewKnownTier
name
uuid
key
version
forbiddenBranches
=
let
overwriteAction
=
InsertAction
name
(
Just
<|
Overwrite
{
uuid
=
uuid
,
key
=
key
,
name
=
name
})
(
Just
<|
Overwrite
{
uuid
=
uuid
,
key
=
key
,
name
=
name
,
forbiddenBranches
=
forbiddenBranches
,
branchName
=
"
latest"
})
in
div
[
class
"
destination-selection"
]
[
div
[
class
"
name"
]
[
text
name
]
...
...
@@ -394,12 +450,45 @@ viewFreshTier bases matches name =
List
.
map
(
viewMatch
name
)
matches
]
viewExactlyTier
:
{
uuid
:
Uuid
,
version
:
String
,
branch
:
Maybe
String
,
key
:
Key
,
meta
:
Version
.
Metadata
}
->
Html
Msg
viewExactlyTier
{
uuid
,
version
,
branch
,
key
,
meta
}
=
let
isCurrentHead
=
case
branch
of
Just
branchName
->
[
text
"
, head of branch "
,
span
[
class
"
branch"
]
[
text
branchName
]
]
Nothing
->
[]
in
div
[
class
"
container"
]
[
p
[]
[
text
"
This tier has been identified as "
,
strong
[]
[
text
<|
Key
.
toString
key
]
,
text
"
."
]
,
p
[]
<|
[
text
"
No changes have been detected since version "
,
strong
[]
[
text
version
]
,
text
"
("
,
text
meta
.
author
,
text
"
, at "
,
span
[
class
"
date"
]
[
text
meta
.
date
]
]
++
isCurrentHead
++
[
text
"
."
]
]
viewTierInfo
:
List
(
List
String
)
->
String
->
TierInfo
->
Html
Msg
viewTierInfo
bases
name
tierInfo
=
case
tierInfo
of
TextgridInfo
.
Known
uuid
key
version
->
viewKnownTier
name
uuid
key
version
TextgridInfo
.
Known
{
uuid
,
key
,
version
,
forbiddenBranches
}
->
viewKnownTier
name
uuid
key
version
forbiddenBranches
TextgridInfo
.
Fresh
matches
->
viewFreshTier
bases
matches
name
...
...
@@ -407,6 +496,9 @@ viewTierInfo bases name tierInfo =
TextgridInfo
.
Error
e
->
div
[
class
"
error"
]
[
text
e
]
TextgridInfo
.
Exactly
exactly
->
viewExactlyTier
exactly
TextgridInfo
.
ConflictResolution
uuid
versions
->
div
[
class
"
conflict-resolution"
]
[
text
"
conflict-resolution"
]
...
...
@@ -424,7 +516,7 @@ viewOptions
viewOptions
bases
(
name
,
(
tierInfo
,
maybeStoreAction
)
)
=
case
maybeStoreAction
of
Just
storeAction
->
viewStoreAction
name
storeAction
viewStoreAction
name
tierInfo
storeAction
Nothing
->
viewTierInfo
bases
name
tierInfo
...
...
@@ -492,11 +584,9 @@ viewShowingInfoState showingInfoState =
|>
List
.
map
Tuple
.
second
|>
List
.
filterMap
identity
|>
List
.
length
|>
String
.
fromInt
tierCount
=
Dict
.
size
showingInfoState
.
tiers
|>
String
.
fromInt
viewMatchInfo
=
case
Set
.
toList
showingInfoState
.
bases
of
...
...
@@ -511,8 +601,8 @@ viewShowingInfoState showingInfoState =
]
[]
,
button
[
onClick
Upload
]
[
text
"
Upload "
,
strong
[]
[
text
tierCount
]
,
text
"
tiers"
,
strong
[]
[
text
<|
String
.
fromInt
tierCount
]
,
if
tierCount
==
1
then
text
"
tier"
else
text
"
tiers"
]
]
]
...
...
@@ -521,10 +611,14 @@ viewShowingInfoState showingInfoState =
[
div
[
class
"
match-info"
]
<|
List
.
map
(
viewOptions
bases
)
<|
Dict
.
toList
showingInfoState
.
tiers
,
button
[
onClick
Synchronize
]
[
text
"
Update "
,
strong
[]
[
text
actionCount
]
,
text
"
tiers"
,
div
[
class
"
container"
]
[
div
[
class
"
row"
,
class
"
flex-pull-right"
]
[
button
[
class
"
level"
,
onClick
Synchronize
,
disabled
(
actionCount
==
0
)
]
[
text
"
Update "
,
strong
[]
[
text
<|
String
.
fromInt
actionCount
]
,
if
actionCount
==
1
then
text
"
tier"
else
text
"
tiers"
]
]
]
]
...
...
assets/style.scss
View file @
f80b0b26
...
...
@@ -403,6 +403,10 @@ button, a.button {
transition
:
0
.1s
all
;
&
.pull-right
{
margin-left
:
auto
;
}
&
.small
{
font-size
:
0
.75em
;
}
...
...
@@ -711,23 +715,8 @@ a.key {
}
.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%
;
font-family
:
$code-font-stack
;
font-size
:
0
.875rem
;
}
.tags
{
...
...
@@ -798,3 +787,8 @@ table.versions {
.tier-item
>
.row
{
align-items
:
center
;
}
.name
{
font-size
:
1
.5rem
;
font-weight
:
500
;
}
bin/action.ml
View file @
f80b0b26
...
...
@@ -96,7 +96,11 @@ let identify_textgrid ~db ~textgrid =
name
,
Error
(
`Missing_parent_info
)
|
[
parent
]
->
let
doc
=
Speechcake
.
get_at_version
db
(
Uuidm
.
to_string
uuid
)
parent
in
name
,
Result
.
map
doc
~
f
:
(
fun
doc
->
`Known
(
uuid
,
doc
.
key
,
parent
))
let
forbidden_branches
=
Option
.
value_exn
(
Speechcake
.
Storage
.
bucket
db
.
storage
(
Uuidm
.
to_string
uuid
))
|>
Speechcake
.
Storage
.
Bucket
.
branches
|>
Hashtbl
.
keys
in
name
,
Result
.
map
doc
~
f
:
(
fun
doc
->
`Known
(
uuid
,
doc
.
key
,
parent
,
forbidden_branches
))
|
parents
->
(* multiple parents means we're in a merging process *)
name
,
Ok
(
`Conflict_resolution
(
uuid
,
parents
))
end
...
...
@@ -134,7 +138,7 @@ let most_recent_version bkt versions =
let
doc
=
Speechcake
.
document_of_json
json
in
Result
.
map
doc
~
f
:
(
fun
doc
->
hash
,
doc
,
meta
)
let
update
~
db
~
tiers
~
tier_name
~
uuid
=
let
update
~
db
~
tiers
~
tier_name
~
uuid
~
branch
=
Log
.
info
(
fun
m
->
m
"update %s -> %s"
tier_name
(
Uuidm
.
to_string
uuid
))
;
let
tier
=
List
.
find
tiers
...
...
@@ -151,7 +155,7 @@ let update ~db ~tiers ~tier_name ~uuid =
>>=
fun
(
_
,
latest
)
->
let
doc
=
Speechcake
.
document
~
key
:
latest
.
Speechcake
.
key
~
tags
:
latest
.
tags
tier
in
Speechcake
.
put
db
key
~
parents
:
[]
doc
Speechcake
.
put
db
key
~
parents
:
[]
~
tag
:
branch
doc
|
Known
{
uuid
;
parents
;
name
}
->
Speechcake
.
bucket
db
(
Uuidm
.
to_string
uuid
)
>>=
fun
bucket
->
...
...
@@ -159,7 +163,7 @@ let update ~db ~tiers ~tier_name ~uuid =
>>=
fun
(
_most_recent_version
,
most_recent_doc
,
_most_recent_meta
)
->
let
doc
=
Speechcake
.
document
~
key
:
most_recent_doc
.
Speechcake
.
key
~
tags
:
most_recent_doc
.
tags
tier
in
Speechcake
.
put
~
parents
db
key
doc
Speechcake
.
put
~
parents
~
tag
:
branch
db
key
doc
|>
(
function
|
Error
(
`Conflict_set
(
tx
,
ty
))
->
let
info
=
Speechcake
.
Info
.
known
~
uuid
~
parents
in
...
...
bin/codec.ml
View file @
f80b0b26
...
...
@@ -65,8 +65,11 @@ let encode_read_error =
`String
"unhandled error"
type
tier_info
=
string
*
([
`Fresh
of
(
string
list
*
Uuidm
.
t
*
int
)
list
|
`Known
of
Uuidm
.
t
*
string
list
*
int64
string
*
([
`Fresh
of
[
`Possibly_one_of
of
(
string
list
*
Uuidm
.
t
*
int
*
string
list
)
list
|
`Exactly
of
(
Uuidm
.
t
*
int64
*
string
option
)
*
(
Storage
.
Metadata
.
t
*
Speechcake
.
document
)
]
|
`Known
of
Uuidm
.
t
*
string
list
*
int64
*
string
list
|
`Conflict_resolution
of
Uuidm
.
t
*
int64
list
]
,
[
`Invalid_UUID
of
string
...
...
@@ -76,25 +79,37 @@ type tier_info =
])
Result
.
t
let
encode_tier_info
=
let
encode_tier_match
:
(
string
list
*
Uuidm
.
t
*
int
)
encoder
=
fun
(
key
,
uuid
,
percent
)
->
let
encode_tier_match
:
(
string
list
*
Uuidm
.
t
*
int
*
string
list
)
encoder
=
fun
(
key
,
uuid
,
percent
,
forbidden_branches
)
->
`Assoc
[
"key"
,
`List
(
List
.
map
~
f
:
(
fun
part
->
`String
part
)
key
)
;
"uuid"
,
`String
(
Uuidm
.
to_string
uuid
)
;
"percent"
,
`Int
percent
;
"forbiddenBranches"
,
`List
(
List
.
map
forbidden_branches
~
f
:
(
fun
b
->
`String
b
))
]
in
function
|
name
,
Ok
(
`Fresh
matches
)
->
|
name
,
Ok
(
`Fresh
(
`Possibly_one_of
matches
)
)
->
name
,
`Assoc
[
"type"
,
`String
"fresh"
;
"matches"
,
`List
(
List
.
map
matches
~
f
:
encode_tier_match
)
]
|
name
,
Ok
(
`Known
(
uuid
,
key
,
version
))
->
|
name
,
Ok
(
`Fresh
(
`Exactly
((
uuid
,
version
,
branch
)
,
(
meta
,
doc
))))
->
name
,
`Assoc
([
"type"
,
`String
"exactly"
;
"uuid"
,
`String
(
Uuidm
.
to_string
uuid
)
;
"key"
,
`List
(
List
.
map
doc
.
Speechcake
.
key
~
f
:
(
fun
part
->
`String
part
))
;
"version"
,
`Assoc
[
"id"
,
`String
(
Fmt
.
str
"%08Lx"
version
)
;
"meta"
,
encode_version_info
meta
]
]
@
(
Option
.
to_list
(
Option
.
map
branch
~
f
:
(
fun
b
->
"branch"
,
`String
b
))))
|
name
,
Ok
(
`Known
(
uuid
,
key
,
version
,
forbidden_branches
))
->
name
,
`Assoc
[
"type"
,
`String
"known"
;
"uuid"
,
`String
(
Uuidm
.
to_string
uuid
)
;
"key"
,
`List
(
List
.
map
key
~
f
:
(
fun
part
->
`String
part
))
;
"version"
,
`String
(
Fmt
.
str
"%08Lx"
version
)
;
"forbiddenBranches"
,
`List
(
List
.
map
forbidden_branches
~
f
:
(
fun
name
->
`String
name
))
]
|
name
,
Ok
(
`Conflict_resolution
(
uuid
,
versions
))
->
name
,
`Assoc
...
...
@@ -140,7 +155,7 @@ module D = Decoders_yojson.Safe.Decode
type
'
a
decoder
=
'
a
D
.
decoder
type
store_action
=
|
Overwrite
of
{
uuid
:
Uuidm
.
t
;
name
:
string
}
|
Overwrite
of
{
uuid
:
Uuidm
.
t
;
name
:
string
;
branch
:
string
}
|
New_bucket
of
{
key
:
string
list
;
name
:
string
}
type
store_request
=
...
...
@@ -155,7 +170,8 @@ let decode_store_action : store_action decoder =
let
overwrite_decoder
=
let
*
uuid
=
field
"uuid"
uuid_decoder
in
let
*
name
=
field
"name"
string
in
succeed
(
Overwrite
{
uuid
;
name
})
in
let
*
branch
=
field
"branch"
string
in
succeed
(
Overwrite
{
uuid
;
name
;
branch
})
in
let
new_bucket_decoder
=
let
*
key
=
field
"key"
(
list
string
)
in
let
*
name
=
field
"name"
string
in
...
...
bin/konditorei.ml
View file @
f80b0b26
...
...
@@ -98,14 +98,14 @@ let get_tier db request =
Ok
(
Hashtbl
.
to_alist
(
Speechcake
.
Storage
.
Bucket
.
versions
bucket
))
>>=
fun
versions
->
Speechcake
.
get_tagged
db
uuid
~
tag
>>|
fun
<