Commit f80b0b26 authored by Vlad Dumitru's avatar Vlad Dumitru
Browse files

another big chunk of work

parent 475d901c
......@@ -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
}
......@@ -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 )
]
]
......
......@@ -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.map3 Known
D.map4 (\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.map3 Match
D.map4 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)
......
module Data.Version exposing
( Metadata, Version
, decoder
, decoder, metadataDecoder
)
import Json.Decode as D exposing (Decoder)
......
......@@ -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
......
......@@ -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"
]
]
]
]
......
......@@ -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;
}
......@@ -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
......
......@@ -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
......
......@@ -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 <