Save parameters in query parameters

Changes

8 changed files (+312/-121)

• build.zig
  • @@ -43,6 +43,7 @@ compile.addElmSourceFile(b.path("src/Template/Layout/Container.elm"));
    compile.addElmSourceFile(b.path("src/Template/Layout/Coordinate.elm")); compile.addElmSourceFile(b.path("src/Template/Layout/Item.elm")); compile.addElmSourceFile(b.path("src/Svg/Path.elm")); + compile.addElmSourceFile(b.path("src/Url/SearchParams.elm")); break :elm_main compile.output_js; };
• elm.json
  • @@ -11,10 +11,10 @@ "elm/core": "1.0.5",
    "elm/html": "1.0.1", "elm/json": "1.1.4", "elm/svg": "1.0.1", + "elm/time": "1.0.0", "elm/url": "1.0.0" }, "indirect": { - "elm/time": "1.0.0", "elm/virtual-dom": "1.0.5" } },
• src/Main.elm
  • @@ -17,10 +17,12 @@ import Html.LivingStandard exposing (..)
    import Json.Decode import Parameters import Parameters.App + import Parameters.Parser import Preferences exposing (FieldHighlight(..)) import Preferences.App import Template exposing (template) import Url exposing (Url) + import Url.SearchParams main : Program Flags Model Msg
  • @@ -60,14 +62,24 @@ init : Flags -> Url -> Key -> ( Model, Cmd Msg )
    init flags url key = let parameters = - Parameters.default + case Maybe.map Url.SearchParams.parse url.query of + Just dict -> + -- TODO: Handle and present errors to a user + Parameters.Parser.parse dict + |> Result.withDefault Parameters.default + + Nothing -> + Parameters.default + + ( parametersModel, parametersCmd ) = + Parameters.App.init url key parameters in ( { url = url , key = key - , parameters = Parameters.App.init parameters + , parameters = parametersModel , preferences = Preferences.App.init flags.preferences } - , Cmd.none + , Cmd.map ParametersMsg parametersCmd )
  • @@ -77,7 +89,7 @@
    type Msg = NoOp - | ParametersFormMsg Parameters.App.Msg + | ParametersMsg Parameters.App.Msg | PreferencesMsg Preferences.App.Msg | UrlRequested Browser.UrlRequest | UrlChanged Url
  • @@ -89,10 +101,10 @@ case msg of
    NoOp -> ( model, Cmd.none ) - ParametersFormMsg subMsg -> + ParametersMsg subMsg -> Parameters.App.update subMsg model.parameters |> Tuple.mapFirst (\p -> { model | parameters = p }) - |> Tuple.mapSecond (Cmd.map ParametersFormMsg) + |> Tuple.mapSecond (Cmd.map ParametersMsg) PreferencesMsg subMsg -> Preferences.App.update subMsg model.preferences
  • @@ -154,7 +166,7 @@ [ node "x-parameters"
    [] ((Parameters.App.view model.parameters - |> List.map (Html.map ParametersFormMsg) + |> List.map (Html.map ParametersMsg) ) ++ hr [] [] :: (Preferences.App.panelItems model.preferences |> List.map (Html.map PreferencesMsg))
• src/Parameters.elm
  • @@ -226,56 +226,85 @@ type alias ParametersDict =
    Dict String String - toDict : Parameters -> Dict String String + toDict : Parameters -> ParametersDict toDict params = - [ Just ( Key.toString LugWidth, String.fromFloat (toMM params.lugWidth) ) - , Just ( Key.toString SurfaceThickness, String.fromFloat (toMM params.thickness) ) - , Just ( Key.toString LiningThickness, String.fromFloat (toMM params.lining) ) - , Just ( Key.toString BuckleHoleOffset, String.fromFloat (toMM params.longPiece.buckleHole.offset) ) - , Just ( Key.toString BuckleHoleCount, String.fromInt params.longPiece.buckleHole.count ) - , Just ( Key.toString BuckleHoleInterval, String.fromFloat (toMM params.longPiece.buckleHole.interval) ) - , Just ( Key.toString BuckleHoleDiameter, String.fromFloat (toMM params.longPiece.buckleHole.diameter) ) - , Just ( Key.toString LongPieceLength, String.fromFloat (toMM params.longPiece.length) ) - , Just ( Key.toString LoopThickness, String.fromFloat (toMM params.shortPiece.loops.thickness) ) - , Just ( Key.toString LoopStyle, loopStyleToString params.shortPiece.loops.style ) - , params.shortPiece.loops.fixed |> Maybe.map (\_ -> ( Key.toString HasFixedLoop, "" )) - , Just - ( Key.toString FixedLoopWidth - , params.shortPiece.loops.fixed |> Maybe.withDefault defaultFixedLoop |> .width |> toMM |> String.fromFloat - ) - , Just - ( Key.toString FixedLoopPlay - , params.shortPiece.loops.fixed |> Maybe.withDefault defaultFixedLoop |> .play |> toMM |> String.fromFloat - ) - , params.shortPiece.loops.free |> Maybe.map (\_ -> ( Key.toString HasFreeLoop, "" )) - , Just - ( Key.toString FreeLoopWidth - , params.shortPiece.loops.free |> Maybe.withDefault defaultFreeLoop |> .width |> toMM |> String.fromFloat - ) - , Just - ( Key.toString FreeLoopPlay - , params.shortPiece.loops.free |> Maybe.withDefault defaultFreeLoop |> .play |> toMM |> String.fromFloat - ) - , Just - ( Key.toString FreeLoopOverlap - , params.shortPiece.loops.free |> Maybe.withDefault defaultFreeLoop |> .overlap |> toMM |> String.fromFloat - ) - , Just ( Key.toString BuckleSpringBarDiameter, String.fromFloat (toMM params.shortPiece.buckle.springBarDiameter) ) - , params.shortPiece.buckle.tongue |> Maybe.map (\_ -> ( Key.toString HasBuckleTongue, "" )) - , Just - ( Key.toString BuckleTongueThickness - , params.shortPiece.buckle.tongue |> Maybe.withDefault defaultBuckleTongue |> .thickness |> toMM |> String.fromFloat - ) - , Just - ( Key.toString BuckleTongueWidth - , params.shortPiece.buckle.tongue |> Maybe.withDefault defaultBuckleTongue |> .width |> toMM |> String.fromFloat - ) - , Just ( Key.toString ShortPieceLength, String.fromFloat (toMM params.shortPiece.length) ) - , Just ( Key.toString CanvasMargin, String.fromFloat (toMM params.rendering.margin) ) - , Just ( Key.toString LineWidth, String.fromFloat (toMM params.rendering.lineWidth) ) - , Just ( Key.toString ColorSchema, colorSchemaToString params.rendering.colorSchema ) + [ ( "version", "1.0" ) + , ( Key.toString LugWidth, String.fromFloat (toMM params.lugWidth) ) + , ( Key.toString SurfaceThickness, String.fromFloat (toMM params.thickness) ) + , ( Key.toString LiningThickness, String.fromFloat (toMM params.lining) ) + , ( Key.toString LongPieceLength, String.fromFloat (toMM params.longPiece.length) ) + , ( Key.toString LoopThickness, String.fromFloat (toMM params.shortPiece.loops.thickness) ) + , ( Key.toString LoopStyle, loopStyleToString params.shortPiece.loops.style ) + , ( Key.toString BuckleSpringBarDiameter, String.fromFloat (toMM params.shortPiece.buckle.springBarDiameter) ) + , ( Key.toString ShortPieceLength, String.fromFloat (toMM params.shortPiece.length) ) + , ( Key.toString CanvasMargin, String.fromFloat (toMM params.rendering.margin) ) + , ( Key.toString LineWidth, String.fromFloat (toMM params.rendering.lineWidth) ) + , ( Key.toString ColorSchema, colorSchemaToString params.rendering.colorSchema ) + , ( Key.toString BuckleHoleCount, String.fromInt params.longPiece.buckleHole.count ) + ] + |> (++) + (if params.longPiece.buckleHole.count > 0 then + [ ( Key.toString BuckleHoleOffset, String.fromFloat (toMM params.longPiece.buckleHole.offset) ) + , ( Key.toString BuckleHoleInterval, String.fromFloat (toMM params.longPiece.buckleHole.interval) ) + , ( Key.toString BuckleHoleDiameter, String.fromFloat (toMM params.longPiece.buckleHole.diameter) ) + ] + + else + [] + ) + |> (++) + (case params.shortPiece.loops.fixed of + Just fixed -> + [ ( Key.toString HasFixedLoop, "" ) + , ( Key.toString FixedLoopWidth, String.fromFloat (toMM fixed.width) ) + , ( Key.toString FixedLoopPlay, String.fromFloat (toMM fixed.play) ) + ] + + Nothing -> + [] + ) + |> (++) + (case params.shortPiece.loops.free of + Just free -> + [ ( Key.toString HasFreeLoop, "" ) + , ( Key.toString FreeLoopWidth, String.fromFloat (toMM free.width) ) + , ( Key.toString FreeLoopPlay, String.fromFloat (toMM free.play) ) + , ( Key.toString FreeLoopOverlap, String.fromFloat (toMM free.overlap) ) + ] + + Nothing -> + [] + ) + |> (++) + (case params.shortPiece.buckle.tongue of + Just tongue -> + [ ( Key.toString HasBuckleTongue, "" ) + , ( Key.toString BuckleTongueThickness, String.fromFloat (toMM tongue.thickness) ) + , ( Key.toString BuckleTongueWidth, String.fromFloat (toMM tongue.width) ) + ] + + Nothing -> + [] + ) + |> Dict.fromList + + + {-| Fields under `Maybe` record may be empty when the parsed parent is + `Nothing`. These values sets default values for those fields. + -} + fallbackValues : ParametersDict + fallbackValues = + [ ( Key.toString FixedLoopWidth, String.fromFloat (toMM defaultFixedLoop.width) ) + , ( Key.toString FixedLoopPlay, String.fromFloat (toMM defaultFixedLoop.play) ) + , ( Key.toString FreeLoopWidth, String.fromFloat (toMM defaultFreeLoop.width) ) + , ( Key.toString FreeLoopPlay, String.fromFloat (toMM defaultFreeLoop.play) ) + , ( Key.toString FreeLoopOverlap, String.fromFloat (toMM defaultFreeLoop.overlap) ) + , ( Key.toString BuckleTongueThickness, String.fromFloat (toMM defaultBuckleTongue.thickness) ) + , ( Key.toString BuckleTongueWidth, String.fromFloat (toMM defaultBuckleTongue.width) ) + , ( Key.toString BuckleHoleOffset, String.fromFloat (toMM default.longPiece.buckleHole.offset) ) + , ( Key.toString BuckleHoleInterval, String.fromFloat (toMM default.longPiece.buckleHole.interval) ) + , ( Key.toString BuckleHoleDiameter, String.fromFloat (toMM default.longPiece.buckleHole.diameter) ) ] - |> List.filterMap identity |> Dict.fromList
• src/Parameters/App.elm
  • @@ -9,6 +9,7 @@
    module Parameters.App exposing (Model, Msg, init, update, view) + import Browser.Navigation import Dict import Html exposing (hr, input, label, node, p, span, text) import Html.Attributes exposing (..)
  • @@ -20,37 +21,60 @@ import Parameters.Constraints exposing (NumberConstraints, constraints)
    import Parameters.Key as Key exposing (Key(..)) import Parameters.Parser exposing (..) import Platform.Cmd as Cmd + import Process + import Task + import Time + import Url exposing (Url) + import Url.SearchParams -- MODEL + type UrlUpdate + = Idle + | Throttled Time.Posix + | Scheduled + + type alias Model = { fields : ParametersDict , errors : Errors , parameters : Parameters , highlighting : Maybe Key + , navigation : Browser.Navigation.Key + , baseUrl : Url + , currentUrl : Url + , urlUpdate : UrlUpdate } - init : Parameters -> Model - init params = + init : Url -> Browser.Navigation.Key -> Parameters -> ( Model, Cmd Msg ) + init baseUrl key params = let fields = - Parameters.toDict params + Dict.union + (Parameters.toDict params) + Parameters.fallbackValues in - { fields = fields - , errors = - case parse fields of - Ok _ -> - Dict.empty + ( { fields = fields + , errors = + case parse fields of + Ok _ -> + Dict.empty - Err errors -> - errors - , parameters = params - , highlighting = Nothing - } + Err errors -> + errors + , parameters = params + , highlighting = Nothing + , navigation = key + , baseUrl = baseUrl + , currentUrl = baseUrl + , urlUpdate = Idle + } + , Task.perform UrlRewriteRequested Time.now + )
  • @@ -60,9 +84,11 @@
    type Msg = FieldChanged Key String | FieldUnset Key - | ColorSchemaChanged ColorSchema | Highlight Key | Unhighlight Key + | UrlRewriteTriggered + | UrlRewriteRequested Time.Posix + | RunThrottledUrlRewrite update : Msg -> Model -> ( Model, Cmd Msg )
  • @@ -80,7 +106,7 @@ | fields = fields
    , errors = Dict.empty , parameters = newParams } - , Cmd.none + , Task.perform UrlRewriteRequested Time.now ) Err errors ->
  • @@ -98,24 +124,12 @@ | fields = fields
    , errors = Dict.empty , parameters = newParams } - , Cmd.none + , Task.perform UrlRewriteRequested Time.now ) Err errors -> ( { model | fields = fields, errors = errors }, Cmd.none ) - ColorSchemaChanged schema -> - let - { parameters } = - model - - { rendering } = - parameters - in - ( { model | parameters = { parameters | rendering = { rendering | colorSchema = schema } } } - , Cmd.none - ) - Highlight key -> ( { model | highlighting = Just key }, Cmd.none )
  • @@ -125,6 +139,56 @@ ( { model | highlighting = Nothing }, Cmd.none )
    else ( model, Cmd.none ) + + UrlRewriteRequested now -> + let + { baseUrl } = + model + + query = + model.parameters + |> Parameters.toDict + |> Url.SearchParams.build + + url = + { baseUrl | query = Just query } + + next = + { model | currentUrl = url } + + throttledUntil = + now + |> Time.posixToMillis + |> (+) 200 + |> Time.millisToPosix + in + case model.urlUpdate of + Idle -> + update UrlRewriteTriggered { next | urlUpdate = Throttled throttledUntil } + + Scheduled -> + ( next, Cmd.none ) + + Throttled until -> + let + timeout = + Time.posixToMillis until - Time.posixToMillis now + in + if timeout <= 0 then + update UrlRewriteTriggered { next | urlUpdate = Throttled throttledUntil } + + else + ( { next | urlUpdate = Scheduled } + , Task.perform (\_ -> RunThrottledUrlRewrite) (Process.sleep (toFloat timeout)) + ) + + RunThrottledUrlRewrite -> + update UrlRewriteTriggered { model | urlUpdate = Idle } + + UrlRewriteTriggered -> + ( model + , Browser.Navigation.replaceUrl model.navigation (Url.toString model.currentUrl) + )
  • @@ -224,6 +288,9 @@ [ text "Invalid bool value. Value must be either \"true\" or \"false\"." ]
    NonexistentVariant str -> [ text ("\"" ++ str ++ "\" is not a valid choice. Did you modify program's source code?") ] + + UnsupportedParametersVersion str -> + [ text ("Parameters version \"" ++ str ++ "\" is not supported.") ] descriptionId : Key -> String
• src/Parameters/Key.elm
  • @@ -36,11 +36,15 @@ | ShortPieceLength
    | CanvasMargin | LineWidth | ColorSchema + | Version toString : Key -> String toString key = case key of + Version -> + "version" + LugWidth -> "lug-width"
• src/Parameters/Parser.elm
  • @@ -24,6 +24,7 @@ | NotALength
    | NotAnInt | NonexistentVariant String | NotABool + | UnsupportedParametersVersion String type alias Errors =
  • @@ -326,6 +327,13 @@ , parseField BuckleHoleInterval (parseLength constraints.longPiece.buckleHole.interval) fields
    ) ) of + ( ( Ok 0, _ ), _ ) -> + let + default = + Parameters.default.longPiece.buckleHole + in + Ok { default | count = 0 } + ( ( Ok count, Ok diameter ), ( Ok offset, Ok interval ) ) -> Ok { count = count, diameter = diameter, offset = offset, interval = interval }
  • @@ -385,41 +393,49 @@
    parse : ParametersDict -> Result Errors Parameters parse fields = - case - ( ( parseField LugWidth (parseLength constraints.lugWidth) fields - , parseField LiningThickness (parseLength constraints.lining) fields - , parseField SurfaceThickness (parseLength constraints.thickness) fields - ) - , ( parseLongPiece fields - , parseShortPiece fields - ) - , parseCanvas fields - ) - of - ( ( Ok lugWidth, Ok lining, Ok thickness ), ( Ok longPiece, Ok shortPiece ), Ok rendering ) -> - let - base = - Parameters.default - in - Ok - { base - | lugWidth = lugWidth - , lining = lining - , thickness = thickness - , longPiece = longPiece - , shortPiece = shortPiece - , rendering = rendering - } + case getKey Version fields of + Just "1.0" -> + case + ( ( parseField LugWidth (parseLength constraints.lugWidth) fields + , parseField LiningThickness (parseLength constraints.lining) fields + , parseField SurfaceThickness (parseLength constraints.thickness) fields + ) + , ( parseLongPiece fields + , parseShortPiece fields + ) + , parseCanvas fields + ) + of + ( ( Ok lugWidth, Ok lining, Ok thickness ), ( Ok longPiece, Ok shortPiece ), Ok rendering ) -> + let + base = + Parameters.default + in + Ok + { base + | lugWidth = lugWidth + , lining = lining + , thickness = thickness + , longPiece = longPiece + , shortPiece = shortPiece + , rendering = rendering + } - ( ( lugWidth, lining, thickness ), ( longPiece, shortPiece ), rendering ) -> - [ mkErrors [ ( LugWidth, getError lugWidth ) ] - , mkErrors [ ( LiningThickness, getError lining ) ] - , mkErrors [ ( SurfaceThickness, getError thickness ) ] - , getError longPiece |> Maybe.withDefault Dict.empty - , getError shortPiece |> Maybe.withDefault Dict.empty - , getError rendering |> Maybe.withDefault Dict.empty - ] - |> List.map Dict.toList - |> List.concat - |> Dict.fromList - |> Err + ( ( lugWidth, lining, thickness ), ( longPiece, shortPiece ), rendering ) -> + [ mkErrors [ ( LugWidth, getError lugWidth ) ] + , mkErrors [ ( LiningThickness, getError lining ) ] + , mkErrors [ ( SurfaceThickness, getError thickness ) ] + , getError longPiece |> Maybe.withDefault Dict.empty + , getError shortPiece |> Maybe.withDefault Dict.empty + , getError rendering |> Maybe.withDefault Dict.empty + ] + |> List.map Dict.toList + |> List.concat + |> Dict.fromList + |> Err + + Just str -> + Err (mkErrors [ ( Version, Just (UnsupportedParametersVersion str) ) ]) + + Nothing -> + Err (mkErrors [ ( Version, Just MissingValue ) ])
• src/Url/SearchParams.elm (new)
  • @@ -0,0 +1,62 @@
    + -- Copyright 2026 Shota FUJI + -- + -- This Source Code Form is subject to the terms of the Mozilla Public + -- License, v. 2.0. If a copy of the MPL was not distributed with this + -- file, You can obtain one at https://mozilla.org/MPL/2.0/. + -- + -- SPDX-License-Identifier: MPL-2.0 + + + module Url.SearchParams exposing (build, parse) + + import Dict exposing (Dict) + import List + import String + import Url + + + parseParameter : String -> Maybe ( String, String ) + parseParameter p = + case String.split "=" p of + [] -> + Nothing + + [ key ] -> + Maybe.map + (\k -> ( k, "" )) + (Url.percentDecode key) + + [ key, value ] -> + Maybe.map2 + Tuple.pair + (Url.percentDecode key) + (Url.percentDecode value) + + _ -> + Nothing + + + parse : String -> Dict String String + parse qs = + qs + |> String.split "&" + |> List.filterMap parseParameter + |> Dict.fromList + + + buildParameter : ( String, String ) -> String + buildParameter ( key, value ) = + case value of + "" -> + Url.percentEncode key + + _ -> + Url.percentEncode key ++ "=" ++ Url.percentEncode value + + + build : Dict String String -> String + build dict = + dict + |> Dict.toList + |> List.map buildParameter + |> String.join "&"