Commit 475d901c authored by Vlad Dumitru's avatar Vlad Dumitru
Browse files

can modify tags and key through the web ui

parent c95e148e
module Api exposing (..)
import Dict exposing (Dict)
import Set exposing (Set)
import File exposing (File)
import Http exposing
( Expect, Response(..)
......@@ -9,10 +11,12 @@ import Http exposing
, fileBody, jsonBody
)
import Json.Decode exposing (Decoder, decodeString, dict, list, string)
import Json.Encode as JE
import Url.Builder exposing (QueryParameter)
import Data.CheckoutRequest as CheckoutRequest exposing (CheckoutRequest)
import Data.Key as Key exposing (Key)
import Data.StoreResponse as StoreResponse exposing (StoreResponse)
import Data.StoreRequest as StoreRequest exposing (StoreRequest)
import Data.TextgridInfo as TextgridInfo exposing (TextgridInfo)
......@@ -91,11 +95,11 @@ listBranches flags uuid toMsg =
, expect = expectJson toMsg (dict Version.decoder)
}
listVersions : Flags -> Uuid -> (Result Error (Dict String Version) -> msg) -> Cmd msg
listVersions : Flags -> Uuid -> (Result Error (List Version) -> msg) -> Cmd msg
listVersions flags uuid toMsg =
get
{ url = url flags [ "tier", Uuid.toString uuid, "versions" ] []
, expect = expectJson toMsg (dict Version.decoder)
, expect = expectJson toMsg (list Version.decoder)
}
putTextgrid
......@@ -135,3 +139,27 @@ checkout flags checkoutRequest toMsg =
, timeout = Nothing
, tracker = Nothing
}
putKey : Flags -> Uuid -> String -> Key -> (Result Error String -> msg) -> Cmd msg
putKey flags uuid branch key toMsg =
request
{ method = "PUT"
, headers = []
, url = url flags [ "tier", Uuid.toString uuid, "head", branch, "key" ] []
, body = Http.stringBody "text/plain" (Key.toString key)
, expect = expectString toMsg
, timeout = Nothing
, tracker = Nothing
}
putTags : Flags -> Uuid -> String -> Set String -> (Result Error String -> msg) -> Cmd msg
putTags flags uuid branch tags toMsg =
request
{ method = "PUT"
, headers = []
, url = url flags [ "tier", Uuid.toString uuid, "head", branch, "tags" ] []
, body = jsonBody ((JE.list JE.string) (Set.toList tags))
, expect = expectString toMsg
, timeout = Nothing
, tracker = Nothing
}
module Component.Tabs exposing (Tabs, viewTabs, updateTabs)
import Dict exposing (Dict)
import Html exposing (Html, a, div, text)
import Html.Attributes exposing (class)
import Html.Events exposing (onClick)
type alias Tabs msg =
Dict String (Html msg)
type alias TabsModel msg =
{ tabs : Tabs msg
, shown : String
}
type Msg
= Select String
viewTabSelector : (Msg -> msg) -> ( String, Html msg ) -> Html msg
viewTabSelector toMsg ( name, _ ) =
a [ class "selector", onClick <| toMsg <| Select name ]
[ text name ]
viewTabs : (Msg -> msg) -> TabsModel msg -> Html msg
viewTabs toMsg model =
let
header =
div [ class "header" ] <|
List.map (viewTabSelector toMsg) (Dict.toList model.tabs)
body =
case Dict.get model.shown model.tabs of
Just content ->
content
Nothing ->
div [] []
in
div [ class "tabs" ]
[ header
, body
]
updateTabs : Msg -> TabsModel msg -> ( TabsModel msg, Cmd msg )
updateTabs msg model =
case msg of
Select name ->
( { model | shown = name }
, Cmd.none
)
module Data.Key exposing
( Key
, fromBaseAndName
, fromBaseAndName, fromParts
, toString, parts, split
, decoder, stringFormatDecoder, encode
)
......@@ -19,6 +19,10 @@ fromBaseAndName : List String -> String -> Key
fromBaseAndName base name =
Key <| List.append base [ name ]
fromParts : List String -> Key
fromParts parts_ =
Key parts_
parts : Key -> List String
parts (Key key) =
key
......@@ -26,7 +30,7 @@ parts (Key key) =
split : Key -> ( List String, Maybe String )
split (Key key) =
case List.reverse key of
name :: base -> ( base, Just name )
name :: base -> ( List.reverse base, Just name )
[] -> ( [], Nothing )
toString : Key -> String
......
......@@ -4,26 +4,30 @@ module Data.Tier exposing
)
import Dict exposing (Dict)
import Set exposing (Set)
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 exposing (Version)
type alias Tier =
{ uuid : String
{ uuid : Uuid
, key : Key
, branches : Dict String Version
, tags : Set String
, versions : List Version
}
decoder : Decoder Tier
decoder =
D.map3 Tier
(D.field "uuid" D.string)
D.map4 Tier
(D.field "uuid" Uuid.decoder)
(D.field "key" Key.decoder)
(D.field "versions" (D.dict Version.decoder))
(D.field "tags" (D.map Set.fromList <| D.list D.string))
(D.field "versions" (D.list Version.decoder))
module Page.Tier exposing (Model(..), Msg(..), init, view, update)
module Page.Tier exposing (Model, Msg(..), init, view, update)
import Dict
import Set exposing (Set)
import Browser exposing (Document)
import Html exposing (Html, div, h1, header, main_, span, text)
import Html.Attributes exposing (class)
import Browser.Navigation as Navigation
import Html exposing (Html, button, div, h1, header, input, main_, span, table, td, th, thead, tr, text)
import Html.Attributes exposing (class, classList, disabled, type_, value)
import Html.Events exposing (onClick, onInput)
import Data.Key as Key
import Data.Key as Key exposing (Key)
import Data.Tier exposing (Tier)
import Data.Uuid exposing (Uuid)
import Data.Uuid as Uuid exposing (Uuid)
import Data.Version as Version exposing (Version)
import Api
......@@ -22,10 +25,23 @@ import Component.Properties exposing (viewProperties)
-- MODEL ----------------------------------------------------------------------
type Model
type alias TierState =
{ origKey : Key
, key : String
, origTags : Set String
, tags : String
, tier : Tier
}
type State
= Loading
| Error Error
| Tier Tier
| Tier TierState
type alias Model =
{ state : State
, flags : Flags
}
......@@ -33,6 +49,12 @@ type Model
type Msg
= GotTier (Result Error Tier)
| SetKey String
| SetTags String
| SyncKey
| SyncedKey (Result Error String)
| SyncTags
| SyncedTags (Result Error String)
......@@ -40,15 +62,49 @@ type Msg
init : Flags -> Uuid -> String -> ( Model, Cmd Msg )
init flags uuid tag =
( Loading, Api.getTier flags uuid tag GotTier )
( { state = Loading, flags = flags }
, Api.getTier flags uuid tag GotTier
)
-- VIEW -----------------------------------------------------------------------
viewTier : Tier -> List (Html Msg)
viewTier tier =
viewTierState : TierState -> List (Html Msg)
viewTierState { origKey, key, origTags, tags, tier } =
let
keyChanged =
not (origKey == Key.fromParts (String.split "/" key |> List.filter (\p -> not (String.isEmpty p))))
tagsChanged =
not (origTags == Set.fromList (String.split "," tags |> List.filter (\t -> not (String.isEmpty t))))
metadata : List (Html Msg)
metadata =
[ viewProperties
[ ( "key"
, input
[ type_ "text", onInput SetKey, value key
, classList [ ( "green", keyChanged ) ]
] []
)
, ( "tags"
, input
[ type_ "text", onInput SetTags, value tags
, classList [ ( "green", tagsChanged ) ]
] []
)
]
, div [ class "row", class "flex-pull-right", class "top-sep" ]
[ button
[ onClick SyncKey
, disabled <| not (keyChanged || tagsChanged)
, class "level"
]
[ text "Sync" ]
]
]
versionMetadata : Version.Metadata -> Html Msg
versionMetadata { author, comment, date, parents } =
viewProperties
......@@ -61,10 +117,10 @@ viewTier tier =
]
branch : ( String, Version ) -> Html Msg
branch ( id, version ) =
branch ( id, version_ ) =
div [ class "branch" ]
[ div [ class "name" ] [ text <| String.dropLeft 8 id ]
, versionMetadata version.info
, versionMetadata version_.info
]
tierName : Html Msg
......@@ -73,13 +129,13 @@ viewTier tier =
( _, Just name ) ->
h1 [ class "title" ]
[ text name
, span [ class "uuid" ] [ text tier.uuid ]
, span [ class "uuid" ] [ text <| Uuid.toString tier.uuid ]
]
( _, Nothing ) ->
h1 [ class "title" ]
[ text "missing name???"
, span [ class "uuid" ] [ text tier.uuid ]
, span [ class "uuid" ] [ text <| Uuid.toString tier.uuid ]
]
header_ =
......@@ -90,13 +146,32 @@ viewTier tier =
]
]
version : Version -> Html Msg
version data =
tr []
[ td [ class "head" ] [ text <| Maybe.withDefault "" data.head ]
, td [ class "datetime" ] [ text data.info.date ]
, td [ class "author" ] [ text data.info.author ]
, td [ class "comment" ] [ text data.info.comment ]
, td [ class "action" ] [] -- TODO: download this version
]
thead_ =
thead [] [ tr []
[ th [] []
, th [] [ text "date/time" ]
, th [] [ text "author" ]
, th [] [ text "comment" ]
, th [] []
]]
in
[ header_
, main_ []
[ viewProperties
[ ( "uuid", text tier.uuid )
, ( "key", text <| Key.toString tier.key )
, ( "versions", div [] <| (Dict.toList tier.branches |> List.map branch) )
, main_ [ class "no-border" ]
[ div [ class "container" ] metadata
, div [ class "container" ]
[ table [ class "versions" ] <|
thead_ :: (List.map version tier.versions)
]
]
]
......@@ -105,15 +180,15 @@ view : Model -> Document Msg
view model =
let
body =
case model of
case model.state of
Loading ->
[ div [ class "loading" ] [ text "loading" ] ]
Error e ->
[ div [ class "error" ] [ text <| Error.errorToString e ] ]
Tier t ->
viewTier t
Tier tierState ->
viewTierState tierState
in
{ title = "tier view"
, body = body
......@@ -123,11 +198,97 @@ view model =
-- UPDATE ---------------------------------------------------------------------
syncKey : Flags -> TierState -> Cmd Msg
syncKey flags tierState =
let
newKey =
String.split "/" tierState.key
|> List.filter (\p -> not (String.isEmpty p))
|> Key.fromParts
in
if newKey == tierState.origKey then
syncTags flags tierState
else
Api.putKey flags tierState.tier.uuid "latest" newKey SyncedKey
syncTags : Flags -> TierState -> Cmd Msg
syncTags flags tierState =
let
newTags =
String.split "," tierState.tags
|> List.filter (\t -> not (String.isEmpty t))
|> Set.fromList
in
if newTags == tierState.origTags then
Navigation.reload
else
Api.putTags flags tierState.tier.uuid "latest" newTags SyncedTags
update : Msg -> Model -> ( Model, Cmd Msg )
update msg _ =
case msg of
GotTier result ->
update msg model =
case ( msg, model.state ) of
( GotTier result, _ ) ->
case result of
Ok tier ->
( { model
| state = Tier
{ key = (Key.toString tier.key)
, origKey = tier.key
, tags = Set.toList tier.tags |> String.join ","
, origTags = tier.tags
, tier = tier
}
}
, Cmd.none
)
Err err ->
( { model | state = Error err }, Cmd.none )
( SetKey key, Tier tierState ) ->
( { model | state = Tier { tierState | key = key } }
, Cmd.none
)
( SetTags tags, Tier tierState ) ->
( { model | state = Tier { tierState | tags = tags } }
, Cmd.none
)
( SyncKey, Tier tierState ) ->
( model
, syncKey model.flags tierState
)
( SyncedKey result, Tier tierState ) ->
case result of
Ok _ ->
( model
, syncTags model.flags tierState
)
Err e ->
( { model | state = Error e }
, Cmd.none
)
( SyncTags, Tier tierState ) ->
( model
, syncTags model.flags tierState
)
( SyncedTags result, Tier tierState ) ->
case result of
Ok tier -> ( Tier tier, Cmd.none )
Err err -> ( Error err, Cmd.none )
Ok _ ->
( model
, Navigation.reload
)
Err e ->
( { model | state = Error e }
, Cmd.none
)
( _, _ ) ->
( model, Cmd.none )
......@@ -34,7 +34,7 @@ import Component.Spinner exposing (viewSpinner)
type alias ShowingTiersState =
{ tierListing : TierListing
, expanded : Dict String (Dict String Version)
, expanded : Dict String (List Version)
, search : Maybe String
, selected : Dict ( String, String ) Key -- ( uuid, version -> key )
, allTags : Dict String Int
......@@ -62,7 +62,7 @@ type Msg
| Expand Uuid
| Contract Uuid
| Select ( Uuid, String, Key ) Bool
| GotVersions Uuid (Result Error (Dict String Version))
| GotVersions Uuid (Result Error (List Version))
| PrepareCheckout
| GotStoredSelection (Result JD.Error CheckoutRequest.CheckoutStorage)
| ToggleTagFilter String Bool
......@@ -102,9 +102,9 @@ viewHeader tagFilterShown path selectedTiers allTags selectedTags =
]
[]
, if tagFilterShown then
button [ onClick HideTagFilter, class "active" ] [ text "" ]
button [ onClick HideTagFilter, class "active" ] [ text "tags" ]
else
button [ onClick ShowTagFilter ] [ text "" ]
button [ onClick ShowTagFilter ] [ text "tags" ]
]
tagCheckbox ( tag, count ) =
......@@ -131,7 +131,6 @@ viewHeader tagFilterShown path selectedTiers allTags selectedTags =
]
else
[]
in
header [] <|
[ div [ class "box" ]
......@@ -154,12 +153,12 @@ viewHeader tagFilterShown path selectedTiers allTags selectedTags =
] ++ tagFilter
viewTierListing
: Bool -> Dict ( String, String ) Key -> Dict String (Dict String Version) -> TierListing
: Bool -> Dict ( String, String ) Key -> Dict String (List Version) -> TierListing
-> Maybe String -> Dict String Int -> Set String -> Document Msg
viewTierListing tagFilterShown selected expanded tierListing search allTags selectedTags =
let
version : Uuid -> Key -> ( String, Version ) -> Html Msg
version uuid key ( versionId, data ) =
version : Uuid -> Key -> Version -> Html Msg
version uuid key data =
tr []
[ td [ class "head" ] [ text <| Maybe.withDefault "" data.head ]
, td [ class "datetime" ] [ text data.info.date ]
......@@ -168,7 +167,7 @@ viewTierListing tagFilterShown selected expanded tierListing search allTags sele
, td [ class "action" ]
[ input
[ type_ "checkbox"
, onCheck <| Select ( uuid, versionId, key )
, onCheck <| Select ( uuid, data.id, key )
]
[]
]
......@@ -204,26 +203,26 @@ viewTierListing tagFilterShown selected expanded tierListing search allTags sele
]]
in
case data of
Just versionDict ->
if Dict.isEmpty versionDict then
div [ class "container" ]
Just versionList ->
if List.isEmpty versionList then
div [ class "container", class "tier-item" ]
[ div [ class "row" ]
[ identifiers
, button [ class "level", disabled True ] [ text "⋯" ]
]
]
else
div [ class "container" ]
div [ class "container", class "tier-item" ]
[ div [ class "row" ]
[ identifiers
, button [ class "level", onClick <| Contract uuid ] [ text "↑" ]
]
, table [ class "versions" ] <|
thead_ :: List.map (version uuid key_) (Dict.toList versionDict)
thead_ :: List.map (version uuid key_) versionList
]
Nothing ->
div [ class "container" ]
div [ class "container", class "tier-item" ]
[ div [ class "row" ]
[ identifiers
, button [ class "level", onClick <| Expand uuid ] [ text "↓" ]
......
......@@ -4,7 +4,7 @@ import Dict exposing (Dict)
import Set exposing (Set)
import Browser exposing (Document)
import Html exposing (Attribute, Html, a, button, div, input, h1, header, 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.Events exposing (onClick, onInput, preventDefaultOn)
......@@ -17,6 +17,7 @@ import Data.Key as Key exposing (Key(..))
import Data.StoreResponse as StoreResponse exposing (StoreTierResult, StoreResponse)
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 Api
......@@ -36,6 +37,7 @@ type alias ShowingInfoState =
, bases : Set (List String)
, root : Maybe String
, tiers : Dict String ( TierInfo, Maybe StoreAction )
, listing : Maybe TierListing
}
type State
......@@ -66,6 +68,8 @@ type Msg
| SetBase String
| Upload
| DownloadTextgrid String