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

lotsa more work

parent 86659134
module Api exposing (..)
import Dict exposing (Dict)
import File exposing (File)
import Http exposing
( Expect, Response(..)
......@@ -7,17 +8,18 @@ import Http exposing
, get, request
, fileBody, jsonBody
)
import Json.Decode exposing (Decoder, decodeString, list, string)
import Json.Decode exposing (Decoder, decodeString, dict, list, string)
import Url.Builder exposing (QueryParameter)
import Data.CheckoutRequest as CheckoutRequest exposing (CheckoutRequest)
import Data.StoreResponse as StoreResponse exposing (StoreResponse)
import Data.StoreRequest as StoreRequest exposing (StoreRequest)
import Data.TextgridMatchInfo as TextgridMatchInfo exposing (TextgridMatchInfo)
import Data.TextgridInfo as TextgridInfo exposing (TextgridInfo)
import Data.Tier as Tier
import Data.TierListing as TierListing exposing (TierListing)
import Data.Uuid as Uuid exposing (Uuid(..))
import Data.Version as Version exposing (Version)
import Error exposing (Error)
import Flags exposing (Flags)
......@@ -75,23 +77,30 @@ getTiers flags prefix toMsg =
, expect = expectJson toMsg (TierListing.decoder prefix)
}
getTier : Flags -> Uuid -> (Result Error Tier.Tier -> msg) -> Cmd msg
getTier flags uuid toMsg =
getTier : Flags -> Uuid -> String -> (Result Error Tier.Tier -> msg) -> Cmd msg
getTier flags uuid tag toMsg =
get
{ url = url flags [ "tier", Uuid.toString uuid ] []
{ url = url flags [ "tier", Uuid.toString uuid, "at", tag ] []
, expect = expectJson toMsg Tier.decoder
}
listBranches : Flags -> Uuid -> (Result Error (Dict String Version) -> msg) -> Cmd msg
listBranches flags uuid toMsg =
get
{ url = url flags [ "tier", Uuid.toString uuid ] []
, expect = expectJson toMsg (dict Version.decoder)
}
putTextgrid
: Flags -> File -> (Result Error TextgridMatchInfo -> msg)
: Flags -> File -> (Result Error TextgridInfo -> msg)
-> Cmd msg
putTextgrid flags file toMsg =
request
{ method = "PUT"
{ method = "POST"
, headers = []
, url = url flags [ "textgrid" ] []
, url = url flags [ "checkin" ] []
, body = fileBody file
, expect = expectJson toMsg TextgridMatchInfo.decoder
, expect = expectJson toMsg TextgridInfo.decoder
, timeout = Nothing
, tracker = Just "putTextgrid"
}
......@@ -99,7 +108,7 @@ putTextgrid flags file toMsg =
store : Flags -> StoreRequest -> (Result Error StoreResponse -> msg) -> Cmd msg
store flags storeRequest toMsg =
request
{ method = "PUT"
{ method = "POST"
, headers = []
, url = url flags [ "store" ] []
, body = jsonBody (StoreRequest.encode storeRequest)
......@@ -111,7 +120,7 @@ store flags storeRequest toMsg =
checkout : Flags -> CheckoutRequest -> (Result Error String -> msg) -> Cmd msg
checkout flags checkoutRequest toMsg =
request
{ method = "PUT"
{ method = "POST"
, headers = []
, url = url flags [ "checkout" ] []
, body = jsonBody (CheckoutRequest.encode checkoutRequest)
......
module Data.TextgridMatchInfo exposing
( Match, TierMatchInfo, TextgridMatchInfo
module Data.TextgridInfo exposing
( Match, TierInfo(..), TextgridInfo
, decoder
)
import Dict exposing (Dict)
import Json.Decode as D exposing (Decoder)
import Data.Key as Key exposing (Key)
......@@ -16,23 +18,33 @@ type alias Match =
, percent : Int
}
type alias TierMatchInfo =
{ name : String
, matches : List Match
}
type TierInfo
= Known Uuid Key String
| Fresh (List Match)
| Error String
type alias TextgridMatchInfo =
{ matches : List TierMatchInfo
type alias TextgridInfo =
{ tiers : Dict String TierInfo
, digest : String
}
tierMatchInfoDecoder : Decoder TierMatchInfo
tierMatchInfoDecoder =
D.map2 TierMatchInfo
(D.field "name" D.string)
(D.field "matches" (D.list matchDecoder))
freshDecoder : Decoder TierInfo
freshDecoder =
D.map Fresh <|
D.field "matches" (D.list matchDecoder)
knownDecoder : Decoder TierInfo
knownDecoder =
D.map3 Known
(D.field "uuid" Uuid.decoder)
(D.field "key" Key.decoder)
(D.field "version" D.string)
errorDecoder : Decoder TierInfo
errorDecoder =
D.map Error (D.field "reason" D.string)
matchDecoder : Decoder Match
matchDecoder =
......@@ -41,9 +53,19 @@ matchDecoder =
(D.field "key" Key.decoder)
(D.field "percent" D.int)
decoder : Decoder TextgridMatchInfo
decoder : Decoder TextgridInfo
decoder =
D.map2 TextgridMatchInfo
(D.field "matches" (D.list tierMatchInfoDecoder))
D.map2 TextgridInfo
(D.field "tiers" (D.map Dict.fromList tierInfoDecoder))
(D.field "digest" D.string)
tierInfoDecoder : Decoder TierInfo
tierInfoDecoder =
D.field "type" D.string
|> D.andThen (\typ ->
case typ of
"fresh" -> freshDecoder
"known" -> knownDecoder
"error" -> errorDecoder
other -> D.fail <| "unknown tag " ++ other)
......@@ -3,7 +3,7 @@ module Data.Tier exposing
, decoder
)
import Dict
import Dict exposing (Dict)
import Json.Decode as D exposing (Decoder)
......@@ -15,7 +15,7 @@ import Data.Version as Version exposing (Version)
type alias Tier =
{ uuid : String
, key : Key
, versions : List ( String, Version )
, branches : Dict String Version
}
......@@ -25,5 +25,5 @@ decoder =
D.map3 Tier
(D.field "uuid" D.string)
(D.field "key" Key.decoder)
(D.field "versions" (D.dict Version.decoder |> D.map Dict.toList))
(D.field "versions" (D.dict Version.decoder))
module Data.Version exposing
( Info, Version
( Metadata, Version
, decoder
)
......@@ -7,29 +7,33 @@ import Json.Decode as D exposing (Decoder)
type alias Info =
type alias Metadata =
{ author : String
, comment : String
, date : String
, parents : List String
}
type alias Version =
{ root : String
, info : Info
{ id : String
, root : String
, info : Metadata
}
infoDecoder : Decoder Info
infoDecoder =
D.map3 Info
metadataDecoder : Decoder Metadata
metadataDecoder =
D.map4 Metadata
(D.field "author" D.string)
(D.field "comment" D.string)
(D.field "date" D.string)
(D.field "parents" (D.list D.string))
decoder : Decoder Version
decoder =
D.map2 Version
D.map3 Version
(D.field "id" D.string)
(D.field "root" D.string)
(D.field "info" infoDecoder)
(D.field "info" metadataDecoder)
......@@ -144,8 +144,8 @@ changeRouteTo maybeRoute flags =
Tiers.init flags path
|> updateWith Tiers GotTiersMsg
Just (Route.Tier uuid) ->
Tier.init flags uuid
Just (Route.Tier uuid tag) ->
Tier.init flags uuid tag
|> updateWith Tier GotTierMsg
Just (Route.Upload maybePath) ->
......
module Page.Tier exposing (Model(..), Msg(..), init, view, update)
import Dict
import Browser exposing (Document)
import Html exposing (Html, div, h1, header, main_, span, text)
import Html.Attributes exposing (class)
......@@ -7,7 +9,7 @@ import Html.Attributes exposing (class)
import Data.Key as Key
import Data.Tier exposing (Tier)
import Data.Uuid exposing (Uuid)
import Data.Version exposing (Version, Info)
import Data.Version as Version exposing (Version)
import Api
import Error exposing (Error)
......@@ -36,9 +38,9 @@ type Msg
-- INIT -----------------------------------------------------------------------
init : Flags -> Uuid -> ( Model, Cmd Msg )
init flags uuid =
( Loading, Api.getTier flags uuid GotTier )
init : Flags -> Uuid -> String -> ( Model, Cmd Msg )
init flags uuid tag =
( Loading, Api.getTier flags uuid tag GotTier )
......@@ -47,20 +49,22 @@ init flags uuid =
viewTier : Tier -> List (Html Msg)
viewTier tier =
let
versionInfo : Info -> Html Msg
versionInfo { author, comment, date } =
versionMetadata : Version.Metadata -> Html Msg
versionMetadata { author, comment, date, parents } =
viewProperties
[ ( "author", text author )
, ( "comment", text comment )
, ( "date", text date )
, ( "parents", span [ class "parents" ] <|
List.map (\p ->
span [ class "version" ] [ text p ]) parents)
]
version : ( String, Version ) -> Html Msg
version ( id, { root, info } ) =
div [ class "version" ]
[ div [ class "id" ] [ text <| String.dropLeft 8 id ]
, div [ class "root" ] [ text root ]
, versionInfo info
branch : ( String, Version ) -> Html Msg
branch ( id, version ) =
div [ class "branch" ]
[ div [ class "name" ] [ text <| String.dropLeft 8 id ]
, versionMetadata version.info
]
tierName : Html Msg
......@@ -92,7 +96,7 @@ viewTier tier =
[ viewProperties
[ ( "uuid", text tier.uuid )
, ( "key", text <| Key.toString tier.key )
, ( "versions", div [] <| List.map version tier.versions )
, ( "branches", div [] <| (Dict.toList tier.branches |> List.map branch) )
]
]
]
......
......@@ -17,6 +17,7 @@ import Data.Key as Key exposing (Key)
import Data.Tier exposing (Tier)
import Data.TierListing exposing (TierListing)
import Data.Uuid as Uuid exposing (Uuid)
import Data.Version as Version exposing (Version)
import Api
import Error exposing (Error)
......@@ -33,7 +34,7 @@ import Component.Spinner exposing (viewSpinner)
type alias ShowingTiersState =
{ tierListing : TierListing
, expanded : Dict String (Maybe Tier)
, expanded : Dict String (Dict String Version)
, search : Maybe String
, selected : Dict ( String, String ) Key -- ( uuid, version -> key )
}
......@@ -58,7 +59,7 @@ type Msg
| Expand Uuid
| Contract Uuid
| Select ( Uuid, String, Key ) Bool
| GotTier (Result Error Tier)
| GotBranches Uuid (Result Error (Dict String Version))
| PrepareCheckout
| GotStoredSelection (Result JD.Error CheckoutRequest.CheckoutStorage)
......@@ -115,26 +116,28 @@ viewHeader path selectedTiers =
]
viewTierListing
: Dict ( String, String ) Key -> Dict String (Maybe Tier) -> TierListing
: Dict ( String, String ) Key -> Dict String (Dict String Version) -> TierListing
-> Maybe String -> Document Msg
viewTierListing selected expanded tierListing search =
let
version uuid key ( id, { root, info } ) =
let
isSelected = Dict.member ( Uuid.toString uuid, id ) selected
in
div [ class "version" ]
[ span [ class "version-id" ] [ text <| String.dropLeft 8 id ]
, span [ class "datetime" ] [ text <| "datetime" ++ info.date ]
, span [ class "author" ] [ text <| "author" ++ info.author ]
, span [ class "comment" ] [ text <| "comment" ++ info.comment ]
version uuid key versionId info =
span [ class "version" ]
[ span [ class "datetime" ] [ text <| "datetime" ++ info.date ]
, span [ class "author" ] [ text <| "author" ++ info.author ]
, span [ class "comment" ] [ text <| "comment" ++ info.comment ]
, input
[ type_ "checkbox"
, onCheck <| Select ( uuid, id, key )
, onCheck <| Select ( uuid, versionId, key )
]
[]
]
branch uuid key ( name, version_ ) =
div [ class "branch" ]
[ span [ class "name" ] [ text name ]
, version uuid key version_.id version_.info
]
viewKey parts =
List.map
(\part -> span [ class "part" ] [ text part ])
......@@ -149,28 +152,28 @@ viewTierListing selected expanded tierListing search =
identifiers =
div [ class "identifiers" ]
[ div [ class "uuid" ] [ text <| Uuid.toString uuid ]
, a [ class "key", href <| Route.routeToString (Route.Tier uuid) ]
, a [ class "key", href <| Route.routeToString (Route.Tier uuid "latest") ]
(viewKey <| Key.parts key_)
]
in
case data of
Just (Just data_) ->
div [ class "container" ]
[ div [ class "row" ]
[ identifiers
, button [ class "level", onClick <| Contract uuid ] [ text "↑" ]
]
, div [ class "row" ] <|
List.map (version uuid key_) data_.versions
]
Just Nothing ->
div [ class "container" ]
[ div [ class "row" ]
[ identifiers
, button [ class "level", disabled True ] [ text "⋯" ]
]
]
Just versionDict ->
if Dict.isEmpty versionDict then
div [ class "container" ]
[ div [ class "row" ]
[ identifiers
, button [ class "level", disabled True ] [ text "⋯" ]
]
]
else
div [ class "container" ]
[ div [ class "row" ]
[ identifiers
, button [ class "level", onClick <| Contract uuid ] [ text "" ]
]
, div [ class "row" ] <|
List.map (branch uuid key_) (Dict.toList versionDict)
]
Nothing ->
div [ class "container" ]
......@@ -271,16 +274,9 @@ update msg model =
, Cmd.none
)
( Expand uuid, ShowingTiers showingTiersState ) ->
( { model
| state = ShowingTiers
{ showingTiersState
| expanded =
Dict.insert (Uuid.toString uuid) Nothing
showingTiersState.expanded
}
}
, Api.getTier model.flags uuid GotTier
( Expand uuid, ShowingTiers _ ) ->
( model
, Api.listBranches model.flags uuid (GotBranches uuid)
)
( Contract uuid, ShowingTiers showingTiersState ) ->
......@@ -324,14 +320,14 @@ update msg model =
, Cmd.none
)
( GotTier result, ShowingTiers showingTiersState ) ->
( GotBranches uuid result, ShowingTiers showingTiersState ) ->
case result of
Ok tier ->
Ok branches ->
( { model
| state = ShowingTiers
{ showingTiersState
| expanded =
Dict.insert tier.uuid (Just tier) showingTiersState.expanded
Dict.insert (Uuid.toString uuid) branches showingTiersState.expanded
}
}
, Cmd.none
......
module Page.Upload exposing (Model, Msg(..), init, update, subscriptions, view)
import Dict
import Dict exposing (Dict)
import Set exposing (Set)
import Browser exposing (Document)
......@@ -15,7 +15,7 @@ import Json.Decode exposing (Decoder, at, map, oneOrMore, succeed)
import Data.Key as Key exposing (Key(..))
import Data.StoreResponse exposing (StoreResponse)
import Data.StoreRequest exposing (StoreAction(..), StoreRequest)
import Data.TextgridMatchInfo exposing (Match, TextgridMatchInfo, TierMatchInfo)
import Data.TextgridInfo as TextgridInfo exposing (Match, TextgridInfo, TierInfo)
import Data.Uuid as Uuid exposing (Uuid(..))
import Api
......@@ -34,7 +34,7 @@ type alias ShowingInfoState =
{ digest : String
, bases : Set (List String)
, root : Maybe String
, matches : List ( TierMatchInfo, Maybe StoreAction )
, tiers : Dict String ( TierInfo, Maybe StoreAction )
}
type State
......@@ -55,7 +55,7 @@ type alias Model =
type Msg
= GotFiles File (List File)
| GotTextgridMatchInfo (Result Error TextgridMatchInfo)
| GotTextgridInfo (Result Error TextgridInfo)
| GotProgress Progress
| DragEnter
| DragLeave
......@@ -83,33 +83,42 @@ init flags maybePath =
setAction : ShowingInfoState -> String -> Maybe StoreAction -> State
setAction state tierName maybeStoreAction =
List.map
(\( tmi, dest ) ->
if tmi.name == tierName then
( tmi, maybeStoreAction )
Dict.map
(\name ( ti, dest ) ->
if name == tierName then
( ti, maybeStoreAction )
else
( tmi, dest ))
state.matches
( ti, dest ))
state.tiers
|> ShowingInfoState state.digest state.bases state.root
|> ShowingInfo
basesOfTierMatchInfo : TierMatchInfo -> Set (List String)
basesOfTierMatchInfo { matches } =
basesOfTierInfo : TierInfo -> Set (List String)
basesOfTierInfo tierInfo =
let
baseOfMatch { key } =
Key.split key |> Tuple.first
in
List.map baseOfMatch matches
|> Set.fromList
case tierInfo of
TextgridInfo.Fresh matches ->
List.map baseOfMatch matches
|> Set.fromList
gotTextgridMatchInfo : TextgridMatchInfo -> State
gotTextgridMatchInfo { matches, digest } =
TextgridInfo.Known _ key _ ->
Key.split key |> Tuple.first
|> Set.singleton
TextgridInfo.Error _ ->
Set.empty
gotTextgridInfo : TextgridInfo -> State
gotTextgridInfo { tiers, digest } =
let
allBases =
List.map basesOfTierMatchInfo matches
List.map basesOfTierInfo (Dict.values tiers)
|> List.foldl Set.union Set.empty
in
List.map (\tmi -> ( tmi, Nothing )) matches
Dict.map (\_ tmi -> ( tmi, Nothing )) tiers
|> ShowingInfoState digest allBases Nothing
|> ShowingInfo
......@@ -119,13 +128,13 @@ update msg model =
case msg of
GotFiles file files ->
( model
, Api.putTextgrid model.flags file GotTextgridMatchInfo
, Api.putTextgrid model.flags file GotTextgridInfo
)
GotTextgridMatchInfo result ->
GotTextgridInfo result ->
case result of
Ok textgridMatchInfo ->
( { model | state = gotTextgridMatchInfo textgridMatchInfo }
( { model | state = gotTextgridInfo textgridMatchInfo }
, Cmd.none
)
......@@ -164,7 +173,7 @@ update msg model =
ShowingInfo showingInfoState ->
let
cmd =
List.map Tuple.second showingInfoState.matches
List.map Tuple.second (Dict.values showingInfoState.tiers)
|> List.filterMap identity
|> StoreRequest showingInfoState.digest
|> \sr -> Api.store model.flags sr GotResult
......@@ -209,12 +218,13 @@ update msg model =
|> Key.fromBaseAndName
cmd =
List.map (\( tierMatchInfo, _ ) ->
Dict.map (\name _ ->
NewBucket
{ key = key tierMatchInfo.name
, name = tierMatchInfo.name
{ key = key name
, name = name
}
) showingInfoState.matches
) showingInfoState.tiers
|> Dict.values
|> StoreRequest showingInfoState.digest
|> \sr -> Api.store model.flags sr GotResult