Shorten URL search parameters QR code generation was soooooooooo slow.

Changes

7 changed files (+281/-64)

• src/Main.elm
  • @@ -60,25 +60,25 @@ , preferences : Preferences.App.Model
    } - parseParameters : Url -> Key -> ( Result QueryHealer.Model Parameters.App.Model, Cmd Msg ) - parseParameters url key = + parseParameters : Url -> Key -> Preferences.Preferences -> ( Result QueryHealer.Model Parameters.App.Model, Cmd Msg ) + parseParameters url key preferences = case Maybe.map Url.SearchParams.parse url.query of Just dict -> case Parameters.Parser.parse dict of Ok params -> let ( model, cmd ) = - Parameters.App.init url key params + Parameters.App.init url key preferences params in ( Ok model, Cmd.map ParametersMsg cmd ) Err errors -> - ( Err (QueryHealer.init url errors), Cmd.none ) + ( Err (QueryHealer.init url preferences errors), Cmd.none ) Nothing -> let ( model, cmd ) = - Parameters.App.init url key Parameters.default + Parameters.App.init url key preferences Parameters.default in ( Ok model, Cmd.map ParametersMsg cmd )
  • @@ -86,13 +86,16 @@
    init : Flags -> Url -> Key -> ( Model, Cmd Msg ) init flags url key = let + preferences = + Preferences.App.init flags.preferences + ( parameters, parametersCmd ) = - parseParameters url key + parseParameters url key preferences.preferences in ( { url = url , key = key , parameters = parameters - , preferences = Preferences.App.init flags.preferences + , preferences = preferences } , parametersCmd )
  • @@ -139,7 +142,19 @@ ( model, Cmd.none )
    PreferencesMsg subMsg -> Preferences.App.update subMsg model.preferences - |> Tuple.mapFirst (\p -> { model | preferences = p }) + |> Tuple.mapFirst + (\p -> + { model + | preferences = p + , parameters = + case model.parameters of + Ok parameters -> + Ok { parameters | preferences = p.preferences } + + Err queryHealer -> + Err { queryHealer | preferences = p.preferences } + } + ) |> Tuple.mapSecond (Cmd.map PreferencesMsg) UrlRequested (Browser.Internal url) ->
  • @@ -160,7 +175,7 @@
    Err _ -> let ( parameters, parametersCmd ) = - parseParameters url model.key + parseParameters url model.key model.preferences.preferences in ( { model | url = url, parameters = parameters }, parametersCmd )
• src/Parameters.elm
  • @@ -215,23 +215,37 @@ type alias ParametersDict =
    Dict String String - toDict : Parameters -> ParametersDict - toDict params = + type DictKeyMode + = Regular + | Compact + + + toDict : DictKeyMode -> Parameters -> ParametersDict + toDict mode params = + let + toString = + case mode of + Regular -> + Key.toString + + Compact -> + Key.toCompactID + in [ ( "version", "1.0" ) - , ( Key.toString TipStyle, tipStyleToString params.longPiece.tip ) - , ( Key.toString ShoulderWidth, String.fromFloat (toMM params.shoulderWidth) ) - , ( Key.toString PaddingOffset, String.fromFloat (toMM params.paddingOffset) ) - , ( Key.toString LongPieceLength, String.fromFloat (toMM params.longPiece.length) ) - , ( Key.toString LoopStyle, loopStyleToString params.shortPiece.loops.style ) - , ( 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 BuckleHoleAdjustments, String.fromInt params.longPiece.buckleHole.adjustments ) - , ( Key.toString BuckleHoleDistance, String.fromFloat (toMM params.longPiece.buckleHole.distance) ) - , ( Key.toString BuckleHoleInterval, String.fromFloat (toMM params.longPiece.buckleHole.interval) ) - , ( Key.toString BuckleHoleDiameter, String.fromFloat (toMM params.longPiece.buckleHole.diameter) ) - , ( Key.toString Profile, profileKind params.profile ) + , ( toString TipStyle, tipStyleToString params.longPiece.tip ) + , ( toString ShoulderWidth, String.fromFloat (toMM params.shoulderWidth) ) + , ( toString PaddingOffset, String.fromFloat (toMM params.paddingOffset) ) + , ( toString LongPieceLength, String.fromFloat (toMM params.longPiece.length) ) + , ( toString LoopStyle, loopStyleToString params.shortPiece.loops.style ) + , ( toString ShortPieceLength, String.fromFloat (toMM params.shortPiece.length) ) + , ( toString CanvasMargin, String.fromFloat (toMM params.rendering.margin) ) + , ( toString LineWidth, String.fromFloat (toMM params.rendering.lineWidth) ) + , ( toString ColorSchema, colorSchemaToString params.rendering.colorSchema ) + , ( toString BuckleHoleAdjustments, String.fromInt params.longPiece.buckleHole.adjustments ) + , ( toString BuckleHoleDistance, String.fromFloat (toMM params.longPiece.buckleHole.distance) ) + , ( toString BuckleHoleInterval, String.fromFloat (toMM params.longPiece.buckleHole.interval) ) + , ( toString BuckleHoleDiameter, String.fromFloat (toMM params.longPiece.buckleHole.diameter) ) + , ( toString Profile, profileKind params.profile ) ] |> (++) (case params.longPiece.tip of
  • @@ -239,7 +253,7 @@ Round ->
    [] Pointed sharpness -> - [ ( Key.toString TipSharpness, String.fromInt sharpness ) ] + [ ( toString TipSharpness, String.fromInt sharpness ) ] ) |> (++) (case params.profile of
  • @@ -247,14 +261,14 @@ Straight ->
    [] Tapered to -> - [ ( Key.toString TaperTo, String.fromFloat (toMM to) ) ] + [ ( toString TaperTo, String.fromFloat (toMM to) ) ] ) |> (++) (case params.shortPiece.loops.fixed of Just fixed -> - [ ( Key.toString HasFixedLoop, "" ) - , ( Key.toString FixedLoopWidth, String.fromFloat (toMM fixed.width) ) - , ( Key.toString FixedLoopLength, String.fromFloat (toMM fixed.length) ) + [ ( toString HasFixedLoop, "" ) + , ( toString FixedLoopWidth, String.fromFloat (toMM fixed.width) ) + , ( toString FixedLoopLength, String.fromFloat (toMM fixed.length) ) ] Nothing ->
  • @@ -263,10 +277,10 @@ )
    |> (++) (case params.shortPiece.loops.free of Just free -> - [ ( Key.toString HasFreeLoop, "" ) - , ( Key.toString FreeLoopWidth, String.fromFloat (toMM free.width) ) - , ( Key.toString FreeLoopLength, String.fromFloat (toMM free.length) ) - , ( Key.toString FreeLoopOverlap, String.fromFloat (toMM free.overlap) ) + [ ( toString HasFreeLoop, "" ) + , ( toString FreeLoopWidth, String.fromFloat (toMM free.width) ) + , ( toString FreeLoopLength, String.fromFloat (toMM free.length) ) + , ( toString FreeLoopOverlap, String.fromFloat (toMM free.overlap) ) ] Nothing ->
  • @@ -274,7 +288,7 @@ []
    ) |> (++) (if params.rendering.qrCode then - [ ( Key.toString QRCode, "" ) ] + [ ( toString QRCode, "" ) ] else []
  • @@ -285,22 +299,36 @@
    {-| 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 TaperTo, "18" ) - , ( Key.toString TipSharpness, String.fromInt defaultTipSharpness ) - , ( Key.toString FixedLoopWidth, String.fromFloat (toMM defaultFixedLoop.width) ) - , ( Key.toString FixedLoopLength, String.fromFloat (toMM defaultFixedLoop.length) ) - , ( Key.toString FreeLoopWidth, String.fromFloat (toMM defaultFreeLoop.width) ) - , ( Key.toString FreeLoopLength, String.fromFloat (toMM defaultFreeLoop.length) ) - , ( Key.toString FreeLoopOverlap, String.fromFloat (toMM defaultFreeLoop.overlap) ) + fallbackValues : DictKeyMode -> ParametersDict + fallbackValues mode = + let + toString = + case mode of + Regular -> + Key.toString + + Compact -> + Key.toCompactID + in + [ ( toString TaperTo, "18" ) + , ( toString TipSharpness, String.fromInt defaultTipSharpness ) + , ( toString FixedLoopWidth, String.fromFloat (toMM defaultFixedLoop.width) ) + , ( toString FixedLoopLength, String.fromFloat (toMM defaultFixedLoop.length) ) + , ( toString FreeLoopWidth, String.fromFloat (toMM defaultFreeLoop.width) ) + , ( toString FreeLoopLength, String.fromFloat (toMM defaultFreeLoop.length) ) + , ( toString FreeLoopOverlap, String.fromFloat (toMM defaultFreeLoop.overlap) ) ] |> Dict.fromList getKey : Key -> ParametersDict -> Maybe String getKey key fields = - Dict.get (Key.toString key) fields + case Dict.get (Key.toCompactID key) fields of + Just value -> + Just value + + Nothing -> + Dict.get (Key.toString key) fields hasKey : Key -> ParametersDict -> Bool
• src/Parameters/App.elm
  • @@ -22,6 +22,7 @@ import Parameters.Constraints exposing (NumberConstraints, constraints)
    import Parameters.Key as Key exposing (Key(..)) import Parameters.Parser exposing (..) import Platform.Cmd as Cmd + import Preferences exposing (Preferences) import Process import Task import Time
  • @@ -48,16 +49,17 @@ , navigation : Browser.Navigation.Key
    , baseUrl : Url , currentUrl : Url , urlUpdate : UrlUpdate + , preferences : Preferences } - init : Url -> Browser.Navigation.Key -> Parameters -> ( Model, Cmd Msg ) - init baseUrl key params = + init : Url -> Browser.Navigation.Key -> Preferences -> Parameters -> ( Model, Cmd Msg ) + init baseUrl key preferences params = let fields = Dict.union - (Parameters.toDict params) - Parameters.fallbackValues + (Parameters.toDict Parameters.Regular params) + (Parameters.fallbackValues Parameters.Regular) in ( { fields = fields , errors =
  • @@ -73,6 +75,7 @@ , navigation = key
    , baseUrl = baseUrl , currentUrl = baseUrl , urlUpdate = Idle + , preferences = preferences } , Task.perform UrlRewriteRequested Time.now )
  • @@ -148,7 +151,7 @@ model
    query = model.parameters - |> Parameters.toDict + |> Parameters.toDict model.preferences.urlKeyMode |> Url.SearchParams.build url =
• src/Parameters/Key.elm
  • @@ -7,7 +7,7 @@ --
    -- SPDX-License-Identifier: MPL-2.0 - module Parameters.Key exposing (Key(..), toLabel, toString) + module Parameters.Key exposing (Key(..), toCompactID, toLabel, toString) type Key
  • @@ -194,3 +194,82 @@ "Color schema"
    QRCode -> "QR code" + + + toCompactID : Key -> String + toCompactID key = + case key of + Version -> + "v" + + TipStyle -> + "0" + + TipSharpness -> + "1" + + Profile -> + "2" + + TaperTo -> + "3" + + ShoulderWidth -> + "4" + + PaddingOffset -> + "5" + + BuckleHoleDistance -> + "6" + + BuckleHoleAdjustments -> + "7" + + BuckleHoleDiameter -> + "8" + + BuckleHoleInterval -> + "9" + + LongPieceLength -> + "a" + + LoopStyle -> + "b" + + HasFixedLoop -> + "c" + + FixedLoopWidth -> + "d" + + FixedLoopLength -> + "e" + + HasFreeLoop -> + "f" + + FreeLoopWidth -> + "g" + + FreeLoopLength -> + "h" + + FreeLoopOverlap -> + "i" + + ShortPieceLength -> + "j" + + CanvasMargin -> + "k" + + LineWidth -> + "l" + + ColorSchema -> + "m" + + QRCode -> + "n"
• src/Preferences.elm
  • @@ -11,6 +11,7 @@ module Preferences exposing (FieldHighlight(..), Preferences, PreviewTheme(..), decoder, defaultPreferences, encode)
    import Json.Decode as Decode import Json.Encode as Encode + import Parameters exposing (DictKeyMode(..)) type PreviewTheme
  • @@ -81,11 +82,41 @@ "do_not_highlight"
    ) + dictKeyModeDecoder : Decode.Decoder DictKeyMode + dictKeyModeDecoder = + Decode.string + |> Decode.andThen + (\str -> + case str of + "regular" -> + Decode.succeed Regular + + "compact" -> + Decode.succeed Compact + + _ -> + Decode.fail ("\"" ++ str ++ "\" is not a valid DictKeyMode value") + ) + + + encodeDictKeyMode : DictKeyMode -> Encode.Value + encodeDictKeyMode mode = + Encode.string + (case mode of + Regular -> + "regular" + + Compact -> + "compact" + ) + + {-| User preferences. This is not supposed to be shared. -} type alias Preferences = { previewTheme : PreviewTheme , fieldHighlight : FieldHighlight + , urlKeyMode : DictKeyMode }
  • @@ -93,6 +124,7 @@ defaultPreferences : Preferences
    defaultPreferences = { previewTheme = SystemTheme , fieldHighlight = DoNotHighlight + , urlKeyMode = Compact }
  • @@ -101,7 +133,7 @@ Always fallback to safe defaults.
    -} decoder : Decode.Decoder Preferences decoder = - Decode.map2 + Decode.map3 Preferences (Decode.oneOf [ Decode.field "preview_theme" previewThemeDecoder
  • @@ -113,6 +145,11 @@ [ Decode.field "field_highlight" fieldHighlightDecoder
    , Decode.succeed defaultPreferences.fieldHighlight ] ) + (Decode.oneOf + [ Decode.field "url_key_mode" dictKeyModeDecoder + , Decode.succeed defaultPreferences.urlKeyMode + ] + ) encode : Preferences -> Encode.Value
  • @@ -120,4 +157,5 @@ encode p =
    Encode.object [ ( "preview_theme", encodePreviewTheme p.previewTheme ) , ( "field_highlight", encodeFieldHighlight p.fieldHighlight ) + , ( "url_key_mode", encodeDictKeyMode p.urlKeyMode ) ]
• src/Preferences/App.elm
  • @@ -15,6 +15,7 @@ import Html.Events
    import Html.LivingStandard exposing (..) import Json.Decode as Decode import Json.Encode as Encode + import Parameters exposing (DictKeyMode(..)) import Preferences exposing (FieldHighlight(..), Preferences, PreviewTheme(..))
  • @@ -53,6 +54,7 @@ type Msg
    = NoOp | SetPreviewTheme PreviewTheme | SetFieldHighlight FieldHighlight + | SetUrlKeyMode DictKeyMode | WritePreferences
  • @@ -71,6 +73,9 @@ update WritePreferences { model | preferences = { preferences | previewTheme = theme } }
    SetFieldHighlight highlight -> update WritePreferences { model | preferences = { preferences | fieldHighlight = highlight } } + + SetUrlKeyMode mode -> + update WritePreferences { model | preferences = { preferences | urlKeyMode = mode } } WritePreferences -> ( model, writePreferences (Preferences.encode model.preferences) )
  • @@ -88,6 +93,11 @@
    fieldHighlightId : String fieldHighlightId = "field-highlight" + + + urlKeyModeId : String + urlKeyModeId = + "url-key-mode" descriptionId : String -> String
  • @@ -192,6 +202,36 @@ , name = fieldHighlightId
    , value = "do-not-highlight" , checked = model.preferences.fieldHighlight == DoNotHighlight , onCheck = SetFieldHighlight DoNotHighlight + } + [] + ] + , node "x-field" + [] + [ span [ slot "title" ] [ text "URL Parameter Mode" ] + , p + [ slot "description" + , id (descriptionId urlKeyModeId) + ] + [ text "This affects QR code generation and its performance." ] + , radioBox + { label = [ text "Compact" ] + , description = [ text "Use shortened parameter names. Cryptic but compact. Recommended." ] + , name = urlKeyModeId + , value = "compact" + , checked = model.preferences.urlKeyMode == Compact + , onCheck = SetUrlKeyMode Compact + } + [] + , radioBox + { label = [ text "Long" ] + , description = + [ text "Use descriptive but verbose parameter names. " + , text "Generates big QR code and significantly slows down QR code generation." + ] + , name = urlKeyModeId + , value = "regular" + , checked = model.preferences.urlKeyMode == Regular + , onCheck = SetUrlKeyMode Regular } [] ]
• src/QueryHealer.elm
  • @@ -17,6 +17,7 @@ import Html.LivingStandard exposing (..)
    import Parameters import Parameters.Key as Key exposing (Key) import Parameters.Parser exposing (Error(..)) + import Preferences exposing (Preferences) import Url exposing (Url) import Url.SearchParams as SearchParams
  • @@ -29,17 +30,19 @@ type alias Model =
    { errors : Parameters.Parser.Errors , searchParams : Dict String String , url : Url + , preferences : Preferences } - init : Url -> Parameters.Parser.Errors -> Model - init url errors = + init : Url -> Preferences -> Parameters.Parser.Errors -> Model + init url preferences errors = { errors = errors , searchParams = url.query |> Maybe.map SearchParams.parse |> Maybe.withDefault Dict.empty , url = url + , preferences = preferences }
  • @@ -62,22 +65,22 @@
    -- VIEW - defaults : Dict String String - defaults = + defaults : Parameters.DictKeyMode -> Dict String String + defaults mode = Dict.union - (Parameters.toDict Parameters.default) - Parameters.fallbackValues + (Parameters.toDict mode Parameters.default) + (Parameters.fallbackValues mode) row : Model -> Key -> Error -> Html Msg - row { searchParams, url } key error = + row { searchParams, url, preferences } key error = let setLinkText : String -> Html msg setLinkText value = text ("Set to \"" ++ value ++ "\". ") withDefault = - case Parameters.getKey key defaults of + case Parameters.getKey key (defaults preferences.urlKeyMode) of Just value -> Dict.insert (Key.toString key) value searchParams
  • @@ -89,7 +92,7 @@ a
    [ slot "action" , href (Url.toString { url | query = Just (SearchParams.build withDefault) }) ] - [ setLinkText (Parameters.getKey key defaults |> Maybe.withDefault "") + [ setLinkText (Parameters.getKey key (defaults preferences.urlKeyMode) |> Maybe.withDefault "") , text "(default value)" ] in
  • @@ -154,7 +157,12 @@ [ span [ slot "description" ] [ text "Unsupported version." ]
    , defaultLink , a [ slot "action" - , href (Url.toString { url | query = Just (SearchParams.build (Parameters.default |> Parameters.toDict)) }) + , href + (Url.toString + { url + | query = Just (SearchParams.build (Parameters.default |> Parameters.toDict preferences.urlKeyMode)) + } + ) ] [ text "Use default parameters" ] ]
  • @@ -165,7 +173,7 @@
    view : Model -> Html Msg view model = let - { url } = + { url, preferences } = model in node "x-error-page"
  • @@ -176,7 +184,13 @@ [ slot "description" ]
    [ text "This URL is not a valid URL for WWSTB." , text " Fix erroneous parameters or start with " , a - [ href (Url.toString { url | query = Just (SearchParams.build (Parameters.default |> Parameters.toDict)) }) ] + [ href + (Url.toString + { url + | query = Just (SearchParams.build (Parameters.default |> Parameters.toDict preferences.urlKeyMode)) + } + ) + ] [ text "default parameters" ] , text "." ]