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 = ...@@ -163,3 +163,26 @@ putTags flags uuid branch tags toMsg =
, timeout = Nothing , timeout = Nothing
, tracker = 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) ...@@ -11,7 +11,7 @@ import Data.Uuid as Uuid exposing (Uuid)
type StoreAction 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 } | NewBucket { key : Key, name: String }
type alias StoreRequest = type alias StoreRequest =
...@@ -24,12 +24,13 @@ type alias StoreRequest = ...@@ -24,12 +24,13 @@ type alias StoreRequest =
encodeStoreAction : StoreAction -> Value encodeStoreAction : StoreAction -> Value
encodeStoreAction storeAction = encodeStoreAction storeAction =
case storeAction of case storeAction of
Overwrite { uuid, name } -> Overwrite { uuid, name, branchName } ->
E.list identity E.list identity
[ E.string "overwrite" [ E.string "overwrite"
, E.object , E.object
[ ( "uuid", Uuid.encode uuid ) [ ( "uuid", Uuid.encode uuid )
, ( "name", E.string name ) , ( "name", E.string name )
, ( "branch", E.string branchName )
] ]
] ]
......
...@@ -9,6 +9,7 @@ import Json.Decode as D exposing (Decoder) ...@@ -9,6 +9,7 @@ import Json.Decode as D exposing (Decoder)
import Data.Key as Key exposing (Key) import Data.Key as Key exposing (Key)
import Data.Uuid as Uuid exposing (Uuid) import Data.Uuid as Uuid exposing (Uuid)
import Data.Version as Version
...@@ -16,11 +17,13 @@ type alias Match = ...@@ -16,11 +17,13 @@ type alias Match =
{ uuid : Uuid { uuid : Uuid
, key : Key , key : Key
, percent : Int , percent : Int
, forbiddenBranches : List String
} }
type TierInfo type TierInfo
= Known Uuid Key String = Known { uuid : Uuid, key : Key, version : String, forbiddenBranches : List String }
| Fresh (List Match) | Fresh (List Match)
| Exactly { uuid : Uuid, version : String, branch : Maybe String, key : Key, meta : Version.Metadata }
| ConflictResolution Uuid (List String) | ConflictResolution Uuid (List String)
| Error String | Error String
| Merge String | Merge String
...@@ -39,10 +42,21 @@ freshDecoder = ...@@ -39,10 +42,21 @@ freshDecoder =
knownDecoder : Decoder TierInfo knownDecoder : Decoder TierInfo
knownDecoder = 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 "uuid" Uuid.decoder)
(D.field "key" Key.decoder) (D.field "key" Key.decoder)
(D.field "version" D.string) (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 : Decoder TierInfo
conflictResolutionDecoder = conflictResolutionDecoder =
...@@ -57,10 +71,11 @@ errorDecoder = ...@@ -57,10 +71,11 @@ errorDecoder =
matchDecoder : Decoder Match matchDecoder : Decoder Match
matchDecoder = matchDecoder =
D.map3 Match D.map4 Match
(D.field "uuid" Uuid.decoder) (D.field "uuid" Uuid.decoder)
(D.field "key" Key.decoder) (D.field "key" Key.decoder)
(D.field "percent" D.int) (D.field "percent" D.int)
(D.field "forbiddenBranches" <| D.list D.string)
decoder : Decoder TextgridInfo decoder : Decoder TextgridInfo
decoder = decoder =
...@@ -76,6 +91,7 @@ tierInfoDecoder = ...@@ -76,6 +91,7 @@ tierInfoDecoder =
case typ of case typ of
"fresh" -> freshDecoder "fresh" -> freshDecoder
"known" -> knownDecoder "known" -> knownDecoder
"exactly" -> exactlyDecoder
"error" -> errorDecoder "error" -> errorDecoder
"conflict-resolution" -> conflictResolutionDecoder "conflict-resolution" -> conflictResolutionDecoder
other -> D.fail <| "unknown tag " ++ other) other -> D.fail <| "unknown tag " ++ other)
......
module Data.Version exposing module Data.Version exposing
( Metadata, Version ( Metadata, Version
, decoder , decoder, metadataDecoder
) )
import Json.Decode as D exposing (Decoder) import Json.Decode as D exposing (Decoder)
......
...@@ -5,6 +5,7 @@ import Set exposing (Set) ...@@ -5,6 +5,7 @@ import Set exposing (Set)
import Browser exposing (Document) import Browser exposing (Document)
import File exposing (File) 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 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.Attributes exposing (class, disabled, for, href, id, placeholder, type_)
import Html.Events exposing (onCheck, onClick, onInput) import Html.Events exposing (onCheck, onClick, onInput)
...@@ -68,6 +69,8 @@ type Msg ...@@ -68,6 +69,8 @@ type Msg
| ToggleTagFilter String Bool | ToggleTagFilter String Bool
| HideTagFilter | HideTagFilter
| ShowTagFilter | ShowTagFilter
| RequestDiff
| GotDiff (Result Error String)
...@@ -137,6 +140,14 @@ viewHeader tagFilterShown path selectedTiers allTags selectedTags = ...@@ -137,6 +140,14 @@ viewHeader tagFilterShown path selectedTiers allTags selectedTags =
[ viewTierPath path [ viewTierPath path
, h1 [] , h1 []
[ text name [ 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 , if selectedCount > 0 then
a a
[ class "button" [ class "button"
...@@ -294,6 +305,23 @@ incrementTagCount maybeInt = ...@@ -294,6 +305,23 @@ incrementTagCount maybeInt =
update : Msg -> Model -> ( Model, Cmd Msg ) update : Msg -> Model -> ( Model, Cmd Msg )
update msg model = update msg model =
case ( msg, model.state ) of 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 ) -> ( ShowTagFilter, ShowingTiers showingTiersState ) ->
( { model | state = ShowingTiers { showingTiersState | tagFilterShown = True } } ( { model | state = ShowingTiers { showingTiersState | tagFilterShown = True } }
, Cmd.none , Cmd.none
......
...@@ -5,7 +5,7 @@ import Set exposing (Set) ...@@ -5,7 +5,7 @@ import Set exposing (Set)
import Browser exposing (Document) import Browser exposing (Document)
import Html exposing (Attribute, Html, a, button, div, input, h1, header, label, p, span, strong, text) 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 Html.Events exposing (onClick, onInput, preventDefaultOn)
import File exposing (File) import File exposing (File)
...@@ -19,6 +19,7 @@ import Data.StoreRequest exposing (StoreAction(..), StoreRequest) ...@@ -19,6 +19,7 @@ import Data.StoreRequest exposing (StoreAction(..), StoreRequest)
import Data.TextgridInfo as TextgridInfo exposing (Match, TextgridInfo, TierInfo) import Data.TextgridInfo as TextgridInfo exposing (Match, TextgridInfo, TierInfo)
import Data.TierListing as TierListing exposing (TierListing) import Data.TierListing as TierListing exposing (TierListing)
import Data.Uuid as Uuid exposing (Uuid(..)) import Data.Uuid as Uuid exposing (Uuid(..))
import Data.Version as Version
import Api import Api
import Error exposing (Error) import Error exposing (Error)
...@@ -70,6 +71,7 @@ type Msg ...@@ -70,6 +71,7 @@ type Msg
| DownloadTextgrid String | DownloadTextgrid String
| GetTiers | GetTiers
| GotTiers (Result Error TierListing) | GotTiers (Result Error TierListing)
| SetBranchName { tierName : String, branchName : String }
...@@ -110,7 +112,11 @@ basesOfTierInfo tierInfo = ...@@ -110,7 +112,11 @@ basesOfTierInfo tierInfo =
List.map baseOfMatch matches List.map baseOfMatch matches
|> Set.fromList |> Set.fromList
TextgridInfo.Known _ key _ -> TextgridInfo.Known { key } ->
Key.split key |> Tuple.first
|> Set.singleton
TextgridInfo.Exactly { key } ->
Key.split key |> Tuple.first Key.split key |> Tuple.first
|> Set.singleton |> Set.singleton
...@@ -134,10 +140,40 @@ gotTextgridInfo { tiers, digest } = ...@@ -134,10 +140,40 @@ gotTextgridInfo { tiers, digest } =
|> (\tiers_ -> ShowingInfoState digest allBases Nothing tiers_ Nothing) |> (\tiers_ -> ShowingInfoState digest allBases Nothing tiers_ Nothing)
|> ShowingInfo |> 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 -> ( Model, Cmd Msg )
update msg model = update msg model =
case msg of 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 -> GetTiers ->
( model ( model
, Api.getTiers model.flags [] GotTiers , Api.getTiers model.flags [] GotTiers
...@@ -272,7 +308,7 @@ update msg model = ...@@ -272,7 +308,7 @@ update msg model =
-- VIEW ----------------------------------------------------------------------- -- VIEW -----------------------------------------------------------------------
viewMatch : String -> Match -> Html Msg viewMatch : String -> Match -> Html Msg
viewMatch name { uuid, key, percent } = viewMatch name { uuid, key, percent, forbiddenBranches } =
let let
colorClass : Int -> Attribute Msg colorClass : Int -> Attribute Msg
colorClass value = colorClass value =
...@@ -288,6 +324,8 @@ viewMatch name { uuid, key, percent } = ...@@ -288,6 +324,8 @@ viewMatch name { uuid, key, percent } =
{ uuid = uuid { uuid = uuid
, key = key , key = key
, name = name , name = name
, forbiddenBranches = forbiddenBranches
, branchName = ""
} }
in in
div [ class "match" ] div [ class "match" ]
...@@ -323,11 +361,28 @@ viewNewDestination base name = ...@@ -323,11 +361,28 @@ viewNewDestination base name =
[ text "Store here" ] [ text "Store here" ]
] ]
viewStoreAction : String -> StoreAction -> Html Msg viewStoreAction : String -> TierInfo -> StoreAction -> Html Msg
viewStoreAction name storeAction = 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 case storeAction of
Overwrite { uuid, key } -> Overwrite { uuid, key, forbiddenBranches, branchName } ->
div [ class "container" ] div [ class "container" ] <|
[ div [ class "row" ] [ div [ class "row" ]
[ div [ class "name" ] [ text name ] [ div [ class "name" ] [ text name ]
, button [ onClick <| InsertAction name Nothing ] , button [ onClick <| InsertAction name Nothing ]
...@@ -337,10 +392,11 @@ viewStoreAction name storeAction = ...@@ -337,10 +392,11 @@ viewStoreAction name storeAction =
[ text "will update document " [ text "will update document "
, span [ class "uuid" ] [ text <| Uuid.toString uuid ] , span [ class "uuid" ] [ text <| Uuid.toString uuid ]
, text ", stored at " , text ", stored at "
, div [ class "key" ] [ text <| Key.toString key ] , span [ class "key" ] [ text <| Key.toString key ]
, text "." , text "."
] ]
] ]
++ branchSelector forbiddenBranches
NewBucket { key } -> NewBucket { key } ->
div [ class "container" ] div [ class "container" ]
...@@ -357,12 +413,12 @@ viewStoreAction name storeAction = ...@@ -357,12 +413,12 @@ viewStoreAction name storeAction =
] ]
viewKnownTier : String -> Uuid -> Key -> String -> Html Msg viewKnownTier : String -> Uuid -> Key -> String -> List String -> Html Msg
viewKnownTier name uuid key version = viewKnownTier name uuid key version forbiddenBranches =
let let
overwriteAction = overwriteAction =
InsertAction name InsertAction name
(Just <| Overwrite { uuid = uuid, key = key, name = name }) (Just <| Overwrite { uuid = uuid, key = key, name = name, forbiddenBranches = forbiddenBranches, branchName = "latest" })
in in
div [ class "destination-selection" ] div [ class "destination-selection" ]
[ div [ class "name" ] [ text name ] [ div [ class "name" ] [ text name ]
...@@ -394,12 +450,45 @@ viewFreshTier bases matches name = ...@@ -394,12 +450,45 @@ viewFreshTier bases matches name =
List.map (viewMatch name) matches 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 : List (List String) -> String -> TierInfo -> Html Msg
viewTierInfo bases name tierInfo = viewTierInfo bases name tierInfo =
case tierInfo of case tierInfo of
TextgridInfo.Known uuid key version -> TextgridInfo.Known { uuid, key, version, forbiddenBranches } ->
viewKnownTier name uuid key version viewKnownTier name uuid key version forbiddenBranches
TextgridInfo.Fresh matches -> TextgridInfo.Fresh matches ->
viewFreshTier bases matches name viewFreshTier bases matches name
...@@ -407,6 +496,9 @@ viewTierInfo bases name tierInfo = ...@@ -407,6 +496,9 @@ viewTierInfo bases name tierInfo =
TextgridInfo.Error e -> TextgridInfo.Error e ->
div [ class "error" ] [ text e ] div [ class "error" ] [ text e ]
TextgridInfo.Exactly exactly ->
viewExactlyTier exactly
TextgridInfo.ConflictResolution uuid versions -> TextgridInfo.ConflictResolution uuid versions ->
div [ class "conflict-resolution" ] [ text "conflict-resolution" ] div [ class "conflict-resolution" ] [ text "conflict-resolution" ]
...@@ -424,7 +516,7 @@ viewOptions ...@@ -424,7 +516,7 @@ viewOptions
viewOptions bases ( name, ( tierInfo, maybeStoreAction ) ) = viewOptions bases ( name, ( tierInfo, maybeStoreAction ) ) =
case maybeStoreAction of case maybeStoreAction of
Just storeAction -> Just storeAction ->
viewStoreAction name storeAction viewStoreAction name tierInfo storeAction
Nothing -> Nothing ->
viewTierInfo bases name tierInfo viewTierInfo bases name tierInfo
...@@ -492,11 +584,9 @@ viewShowingInfoState showingInfoState = ...@@ -492,11 +584,9 @@ viewShowingInfoState showingInfoState =
|> List.map Tuple.second |> List.map Tuple.second
|> List.filterMap identity |> List.filterMap identity
|> List.length |> List.length
|> String.fromInt
tierCount = tierCount =
Dict.size showingInfoState.tiers Dict.size showingInfoState.tiers
|> String.fromInt
viewMatchInfo = viewMatchInfo =
case Set.toList showingInfoState.bases of case Set.toList showingInfoState.bases of
...@@ -511,8 +601,8 @@ viewShowingInfoState showingInfoState = ...@@ -511,8 +601,8 @@ viewShowingInfoState showingInfoState =
] [] ] []
, button [ onClick Upload ] , button [ onClick Upload ]
[ text "Upload " [ text "Upload "
, strong [] [ text tierCount ] , strong [] [ text <| String.fromInt tierCount ]
, text " tiers" , if tierCount == 1 then text " tier" else text " tiers"
] ]
] ]
] ]
...@@ -521,10 +611,14 @@ viewShowingInfoState showingInfoState = ...@@ -521,10 +611,14 @@ viewShowingInfoState showingInfoState =
[ div [ class "match-info" ] <| [ div [ class "match-info" ] <|
List.map (viewOptions bases) <| List.map (viewOptions bases) <|
Dict.toList showingInfoState.tiers Dict.toList showingInfoState.tiers
, button [ onClick Synchronize ] , div [ class "container" ]
[ text "Update " [ div [ class "row", class "flex-pull-right" ]
, strong [] [ text actionCount ] [ button [ class "level", onClick Synchronize, disabled (actionCount == 0) ]
, text " tiers" [ text "Update "
, strong [] [ text <| String.fromInt actionCount ]
, if actionCount == 1 then text " tier" else text " tiers"
]
]
] ]
] ]
......
...@@ -403,6 +403,10 @@ button, a.button { ...@@ -403,6 +403,10 @@ button, a.button {
transition: 0.1s all; transition: 0.1s all;