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 (..) module Api exposing (..)
import Dict exposing (Dict) import Dict exposing (Dict)
import Set exposing (Set)
import File exposing (File) import File exposing (File)
import Http exposing import Http exposing
( Expect, Response(..) ( Expect, Response(..)
...@@ -9,10 +11,12 @@ import Http exposing ...@@ -9,10 +11,12 @@ import Http exposing
, fileBody, jsonBody , fileBody, jsonBody
) )
import Json.Decode exposing (Decoder, decodeString, dict, list, string) import Json.Decode exposing (Decoder, decodeString, dict, list, string)
import Json.Encode as JE
import Url.Builder exposing (QueryParameter) import Url.Builder exposing (QueryParameter)
import Data.CheckoutRequest as CheckoutRequest exposing (CheckoutRequest) import Data.CheckoutRequest as CheckoutRequest exposing (CheckoutRequest)
import Data.Key as Key exposing (Key)
import Data.StoreResponse as StoreResponse exposing (StoreResponse) import Data.StoreResponse as StoreResponse exposing (StoreResponse)
import Data.StoreRequest as StoreRequest exposing (StoreRequest) import Data.StoreRequest as StoreRequest exposing (StoreRequest)
import Data.TextgridInfo as TextgridInfo exposing (TextgridInfo) import Data.TextgridInfo as TextgridInfo exposing (TextgridInfo)
...@@ -91,11 +95,11 @@ listBranches flags uuid toMsg = ...@@ -91,11 +95,11 @@ listBranches flags uuid toMsg =
, expect = expectJson toMsg (dict Version.decoder) , 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 = listVersions flags uuid toMsg =
get get
{ url = url flags [ "tier", Uuid.toString uuid, "versions" ] [] { url = url flags [ "tier", Uuid.toString uuid, "versions" ] []
, expect = expectJson toMsg (dict Version.decoder) , expect = expectJson toMsg (list Version.decoder)
} }
putTextgrid putTextgrid
...@@ -135,3 +139,27 @@ checkout flags checkoutRequest toMsg = ...@@ -135,3 +139,27 @@ checkout flags checkoutRequest toMsg =
, timeout = Nothing , timeout = Nothing
, tracker = 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 module Data.Key exposing
( Key ( Key
, fromBaseAndName , fromBaseAndName, fromParts
, toString, parts, split , toString, parts, split
, decoder, stringFormatDecoder, encode , decoder, stringFormatDecoder, encode
) )
...@@ -19,6 +19,10 @@ fromBaseAndName : List String -> String -> Key ...@@ -19,6 +19,10 @@ fromBaseAndName : List String -> String -> Key
fromBaseAndName base name = fromBaseAndName base name =
Key <| List.append base [ name ] Key <| List.append base [ name ]
fromParts : List String -> Key
fromParts parts_ =
Key parts_
parts : Key -> List String parts : Key -> List String
parts (Key key) = parts (Key key) =
key key
...@@ -26,8 +30,8 @@ parts (Key key) = ...@@ -26,8 +30,8 @@ parts (Key key) =
split : Key -> ( List String, Maybe String ) split : Key -> ( List String, Maybe String )
split (Key key) = split (Key key) =
case List.reverse key of case List.reverse key of
name :: base -> ( base, Just name ) name :: base -> ( List.reverse base, Just name )
[] -> ( [], Nothing ) [] -> ( [], Nothing )
toString : Key -> String toString : Key -> String
toString (Key path) = toString (Key path) =
......
...@@ -4,26 +4,30 @@ module Data.Tier exposing ...@@ -4,26 +4,30 @@ module Data.Tier exposing
) )
import Dict exposing (Dict) import Dict exposing (Dict)
import Set exposing (Set)
import Json.Decode as D exposing (Decoder) 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.Version as Version exposing (Version) import Data.Version as Version exposing (Version)
type alias Tier = type alias Tier =
{ uuid : String { uuid : Uuid
, key : Key , key : Key
, branches : Dict String Version , tags : Set String
, versions : List Version
} }
decoder : Decoder Tier decoder : Decoder Tier
decoder = decoder =
D.map3 Tier D.map4 Tier
(D.field "uuid" D.string) (D.field "uuid" Uuid.decoder)
(D.field "key" Key.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 Dict
import Set exposing (Set)
import Browser exposing (Document) import Browser exposing (Document)
import Html exposing (Html, div, h1, header, main_, span, text) import Browser.Navigation as Navigation
import Html.Attributes exposing (class) 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.Tier exposing (Tier)
import Data.Uuid exposing (Uuid) import Data.Uuid as Uuid exposing (Uuid)
import Data.Version as Version exposing (Version) import Data.Version as Version exposing (Version)
import Api import Api
...@@ -22,10 +25,23 @@ import Component.Properties exposing (viewProperties) ...@@ -22,10 +25,23 @@ import Component.Properties exposing (viewProperties)
-- MODEL ---------------------------------------------------------------------- -- MODEL ----------------------------------------------------------------------
type Model type alias TierState =
{ origKey : Key
, key : String
, origTags : Set String
, tags : String
, tier : Tier
}
type State
= Loading = Loading
| Error Error | Error Error
| Tier Tier | Tier TierState
type alias Model =
{ state : State
, flags : Flags
}
...@@ -33,6 +49,12 @@ type Model ...@@ -33,6 +49,12 @@ type Model
type Msg type Msg
= GotTier (Result Error Tier) = GotTier (Result Error Tier)
| SetKey String
| SetTags String
| SyncKey
| SyncedKey (Result Error String)
| SyncTags
| SyncedTags (Result Error String)
...@@ -40,15 +62,49 @@ type Msg ...@@ -40,15 +62,49 @@ type Msg
init : Flags -> Uuid -> String -> ( Model, Cmd Msg ) init : Flags -> Uuid -> String -> ( Model, Cmd Msg )
init flags uuid tag = init flags uuid tag =
( Loading, Api.getTier flags uuid tag GotTier ) ( { state = Loading, flags = flags }
, Api.getTier flags uuid tag GotTier
)
-- VIEW ----------------------------------------------------------------------- -- VIEW -----------------------------------------------------------------------
viewTier : Tier -> List (Html Msg) viewTierState : TierState -> List (Html Msg)
viewTier tier = viewTierState { origKey, key, origTags, tags, tier } =
let 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 : Version.Metadata -> Html Msg
versionMetadata { author, comment, date, parents } = versionMetadata { author, comment, date, parents } =
viewProperties viewProperties
...@@ -61,10 +117,10 @@ viewTier tier = ...@@ -61,10 +117,10 @@ viewTier tier =
] ]
branch : ( String, Version ) -> Html Msg branch : ( String, Version ) -> Html Msg
branch ( id, version ) = branch ( id, version_ ) =
div [ class "branch" ] div [ class "branch" ]
[ div [ class "name" ] [ text <| String.dropLeft 8 id ] [ div [ class "name" ] [ text <| String.dropLeft 8 id ]
, versionMetadata version.info , versionMetadata version_.info
] ]
tierName : Html Msg tierName : Html Msg
...@@ -73,13 +129,13 @@ viewTier tier = ...@@ -73,13 +129,13 @@ viewTier tier =
( _, Just name ) -> ( _, Just name ) ->
h1 [ class "title" ] h1 [ class "title" ]
[ text name [ text name
, span [ class "uuid" ] [ text tier.uuid ] , span [ class "uuid" ] [ text <| Uuid.toString tier.uuid ]
] ]
( _, Nothing ) -> ( _, Nothing ) ->
h1 [ class "title" ] h1 [ class "title" ]
[ text "missing name???" [ text "missing name???"
, span [ class "uuid" ] [ text tier.uuid ] , span [ class "uuid" ] [ text <| Uuid.toString tier.uuid ]
] ]
header_ = header_ =
...@@ -90,13 +146,32 @@ viewTier tier = ...@@ -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 in
[ header_ [ header_
, main_ [] , main_ [ class "no-border" ]
[ viewProperties [ div [ class "container" ] metadata
[ ( "uuid", text tier.uuid ) , div [ class "container" ]
, ( "key", text <| Key.toString tier.key ) [ table [ class "versions" ] <|
, ( "versions", div [] <| (Dict.toList tier.branches |> List.map branch) ) thead_ :: (List.map version tier.versions)
] ]
] ]
] ]
...@@ -105,15 +180,15 @@ view : Model -> Document Msg ...@@ -105,15 +180,15 @@ view : Model -> Document Msg
view model = view model =
let let
body = body =
case model of case model.state of
Loading -> Loading ->
[ div [ class "loading" ] [ text "loading" ] ] [ div [ class "loading" ] [ text "loading" ] ]
Error e -> Error e ->
[ div [ class "error" ] [ text <| Error.errorToString e ] ] [ div [ class "error" ] [ text <| Error.errorToString e ] ]
Tier t -> Tier tierState ->
viewTier t viewTierState tierState
in in
{ title = "tier view" { title = "tier view"
, body = body , body = body
...@@ -123,11 +198,97 @@ view model = ...@@ -123,11 +198,97 @@ view model =
-- UPDATE --------------------------------------------------------------------- -- 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 -> Model -> ( Model, Cmd Msg )
update msg _ = update msg model =
case msg of case ( msg, model.state ) of
GotTier result -> ( 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 case result of
Ok tier -> ( Tier tier, Cmd.none ) Ok _ ->
Err err -> ( Error err, Cmd.none ) ( model
, Navigation.reload
)
Err e ->
( { model | state = Error e }
, Cmd.none
)
( _, _ ) ->
( model, Cmd.none )
...@@ -34,7 +34,7 @@ import Component.Spinner exposing (viewSpinner) ...@@ -34,7 +34,7 @@ import Component.Spinner exposing (viewSpinner)
type alias ShowingTiersState = type alias ShowingTiersState =
{ tierListing : TierListing { tierListing : TierListing
, expanded : Dict String (Dict String Version) , expanded : Dict String (List Version)
, search : Maybe String , search : Maybe String
, selected : Dict ( String, String ) Key -- ( uuid, version -> key ) , selected : Dict ( String, String ) Key -- ( uuid, version -> key )
, allTags : Dict String Int , allTags : Dict String Int