From 217fef73842afe337ca18d64296ae910de0ce44e Mon Sep 17 00:00:00 2001
From: Eike Kettner <eike.kettner@posteo.de>
Date: Sat, 13 Jun 2020 20:58:15 +0200
Subject: [PATCH] Throttle search requests
Throttle search requests when typing. Also fix handling subscriptions
in main.
---
elm.json | 3 +-
modules/webapp/src/main/elm/App/Update.elm | 92 +++++++--------
.../webapp/src/main/elm/Comp/SearchMenu.elm | 9 +-
modules/webapp/src/main/elm/Main.elm | 6 +-
.../webapp/src/main/elm/Page/Home/Data.elm | 4 +
.../webapp/src/main/elm/Page/Home/Update.elm | 108 ++++++++++++------
.../webapp/src/main/elm/Page/Home/View.elm | 48 ++------
modules/webapp/src/main/elm/Util/Update.elm | 22 +++-
8 files changed, 160 insertions(+), 132 deletions(-)
diff --git a/elm.json b/elm.json
index bbc41890..50606567 100644
--- a/elm.json
+++ b/elm.json
@@ -22,7 +22,8 @@
"justinmimbs/date": "3.1.2",
"norpan/elm-html5-drag-drop": "3.1.4",
"ryannhg/date-format": "2.3.0",
- "truqu/elm-base64": "2.0.4"
+ "truqu/elm-base64": "2.0.4",
+ "ursi/elm-throttle": "1.0.1"
},
"indirect": {
"elm/bytes": "1.0.8",
diff --git a/modules/webapp/src/main/elm/App/Update.elm b/modules/webapp/src/main/elm/App/Update.elm
index 0eff0cc0..10439077 100644
--- a/modules/webapp/src/main/elm/App/Update.elm
+++ b/modules/webapp/src/main/elm/App/Update.elm
@@ -40,44 +40,44 @@ update msg model =
( m, c, s ) =
updateWithSub msg model
in
- ( { m | subs = Sub.batch [ m.subs, s ] }, c )
+ ( { m | subs = s }, c )
updateWithSub : Msg -> Model -> ( Model, Cmd Msg, Sub Msg )
updateWithSub msg model =
case msg of
HomeMsg lm ->
- updateHome lm model |> noSub
+ updateHome lm model
LoginMsg lm ->
- updateLogin lm model |> noSub
+ updateLogin lm model
ManageDataMsg lm ->
- updateManageData lm model |> noSub
+ updateManageData lm model
CollSettingsMsg m ->
- updateCollSettings m model |> noSub
+ updateCollSettings m model
UserSettingsMsg m ->
- updateUserSettings m model |> noSub
+ updateUserSettings m model
QueueMsg m ->
- updateQueue m model |> noSub
+ updateQueue m model
RegisterMsg m ->
- updateRegister m model |> noSub
+ updateRegister m model
UploadMsg m ->
updateUpload m model
NewInviteMsg m ->
- updateNewInvite m model |> noSub
+ updateNewInvite m model
ItemDetailMsg m ->
updateItemDetail m model
VersionResp (Ok info) ->
- ( { model | version = info }, Cmd.none ) |> noSub
+ ( { model | version = info }, Cmd.none, Sub.none )
VersionResp (Err _) ->
( model, Cmd.none, Sub.none )
@@ -162,25 +162,27 @@ updateWithSub msg model =
check =
checkPage model.flags page
- ( m, c ) =
+ ( m, c, s ) =
initPage model page
in
if check == page then
- ( { m | page = page }, c, Sub.none )
+ ( { m | page = page }, c, s )
else
( model, Page.goto check, Sub.none )
ToggleNavMenu ->
- ( { model | navMenuOpen = not model.navMenuOpen }, Cmd.none, Sub.none )
+ ( { model | navMenuOpen = not model.navMenuOpen }
+ , Cmd.none
+ , Sub.none
+ )
GetUiSettings settings ->
- Util.Update.andThen1
+ Util.Update.andThen2
[ updateUserSettings Page.UserSettings.Data.UpdateSettings
, updateHome Page.Home.Data.DoSearch
]
{ model | uiSettings = settings }
- |> noSub
updateItemDetail : Page.ItemDetail.Data.Msg -> Model -> ( Model, Cmd Msg, Sub Msg )
@@ -200,7 +202,7 @@ updateItemDetail lmsg model =
)
-updateNewInvite : Page.NewInvite.Data.Msg -> Model -> ( Model, Cmd Msg )
+updateNewInvite : Page.NewInvite.Data.Msg -> Model -> ( Model, Cmd Msg, Sub Msg )
updateNewInvite lmsg model =
let
( lm, lc ) =
@@ -208,6 +210,7 @@ updateNewInvite lmsg model =
in
( { model | newInviteModel = lm }
, Cmd.map NewInviteMsg lc
+ , Sub.none
)
@@ -227,7 +230,7 @@ updateUpload lmsg model =
)
-updateRegister : Page.Register.Data.Msg -> Model -> ( Model, Cmd Msg )
+updateRegister : Page.Register.Data.Msg -> Model -> ( Model, Cmd Msg, Sub Msg )
updateRegister lmsg model =
let
( lm, lc ) =
@@ -235,10 +238,11 @@ updateRegister lmsg model =
in
( { model | registerModel = lm }
, Cmd.map RegisterMsg lc
+ , Sub.none
)
-updateQueue : Page.Queue.Data.Msg -> Model -> ( Model, Cmd Msg )
+updateQueue : Page.Queue.Data.Msg -> Model -> ( Model, Cmd Msg, Sub Msg )
updateQueue lmsg model =
let
( lm, lc ) =
@@ -246,10 +250,11 @@ updateQueue lmsg model =
in
( { model | queueModel = lm }
, Cmd.map QueueMsg lc
+ , Sub.none
)
-updateUserSettings : Page.UserSettings.Data.Msg -> Model -> ( Model, Cmd Msg )
+updateUserSettings : Page.UserSettings.Data.Msg -> Model -> ( Model, Cmd Msg, Sub Msg )
updateUserSettings lmsg model =
let
( lm, lc, ls ) =
@@ -257,17 +262,13 @@ updateUserSettings lmsg model =
in
( { model
| userSettingsModel = lm
- , subs =
- Sub.batch
- [ model.subs
- , Sub.map UserSettingsMsg ls
- ]
}
, Cmd.map UserSettingsMsg lc
+ , Sub.map UserSettingsMsg ls
)
-updateCollSettings : Page.CollectiveSettings.Data.Msg -> Model -> ( Model, Cmd Msg )
+updateCollSettings : Page.CollectiveSettings.Data.Msg -> Model -> ( Model, Cmd Msg, Sub Msg )
updateCollSettings lmsg model =
let
( lm, lc ) =
@@ -277,10 +278,11 @@ updateCollSettings lmsg model =
in
( { model | collSettingsModel = lm }
, Cmd.map CollSettingsMsg lc
+ , Sub.none
)
-updateLogin : Page.Login.Data.Msg -> Model -> ( Model, Cmd Msg )
+updateLogin : Page.Login.Data.Msg -> Model -> ( Model, Cmd Msg, Sub Msg )
updateLogin lmsg model =
let
( lm, lc, ar ) =
@@ -295,21 +297,25 @@ updateLogin lmsg model =
in
( { model | loginModel = lm, flags = newFlags }
, Cmd.map LoginMsg lc
+ , Sub.none
)
-updateHome : Page.Home.Data.Msg -> Model -> ( Model, Cmd Msg )
+updateHome : Page.Home.Data.Msg -> Model -> ( Model, Cmd Msg, Sub Msg )
updateHome lmsg model =
let
- ( lm, lc ) =
+ ( lm, lc, ls ) =
Page.Home.Update.update model.key model.flags model.uiSettings lmsg model.homeModel
in
- ( { model | homeModel = lm }
+ ( { model
+ | homeModel = lm
+ }
, Cmd.map HomeMsg lc
+ , Sub.map HomeMsg ls
)
-updateManageData : Page.ManageData.Data.Msg -> Model -> ( Model, Cmd Msg )
+updateManageData : Page.ManageData.Data.Msg -> Model -> ( Model, Cmd Msg, Sub Msg )
updateManageData lmsg model =
let
( lm, lc ) =
@@ -317,14 +323,15 @@ updateManageData lmsg model =
in
( { model | manageDataModel = lm }
, Cmd.map ManageDataMsg lc
+ , Sub.none
)
-initPage : Model -> Page -> ( Model, Cmd Msg )
+initPage : Model -> Page -> ( Model, Cmd Msg, Sub Msg )
initPage model page =
case page of
HomePage ->
- Util.Update.andThen1
+ Util.Update.andThen2
[ updateHome Page.Home.Data.Init
, updateQueue Page.Queue.Data.StopRefresh
]
@@ -337,14 +344,14 @@ initPage model page =
updateQueue Page.Queue.Data.StopRefresh model
CollectiveSettingPage ->
- Util.Update.andThen1
+ Util.Update.andThen2
[ updateQueue Page.Queue.Data.StopRefresh
, updateCollSettings Page.CollectiveSettings.Data.Init
]
model
UserSettingPage ->
- Util.Update.andThen1
+ Util.Update.andThen2
[ updateQueue Page.Queue.Data.StopRefresh
]
model
@@ -362,21 +369,8 @@ initPage model page =
updateQueue Page.Queue.Data.StopRefresh model
ItemDetailPage id ->
- let
- updateDetail m__ =
- let
- ( m, c, s ) =
- updateItemDetail (Page.ItemDetail.Data.Init id) m__
- in
- ( { m | subs = Sub.batch [ m.subs, s ] }, c )
- in
- Util.Update.andThen1
- [ updateDetail
+ Util.Update.andThen2
+ [ updateItemDetail (Page.ItemDetail.Data.Init id)
, updateQueue Page.Queue.Data.StopRefresh
]
model
-
-
-noSub : ( Model, Cmd Msg ) -> ( Model, Cmd Msg, Sub Msg )
-noSub ( m, c ) =
- ( m, c, Sub.none )
diff --git a/modules/webapp/src/main/elm/Comp/SearchMenu.elm b/modules/webapp/src/main/elm/Comp/SearchMenu.elm
index eb1135cc..d06de0e0 100644
--- a/modules/webapp/src/main/elm/Comp/SearchMenu.elm
+++ b/modules/webapp/src/main/elm/Comp/SearchMenu.elm
@@ -499,6 +499,9 @@ view settings model =
[ text headline
]
]
+
+ nameIcon =
+ i [ class "left align icon" ] []
in
div [ class "ui form" ]
[ div [ class "inline field" ]
@@ -514,7 +517,7 @@ view settings model =
]
]
]
- , formHeader (i [ class "left align icon" ] []) "By Name"
+ , formHeader nameIcon "Names"
, div [ class "field" ]
[ label [] [ text "All Names" ]
, input
@@ -528,7 +531,7 @@ view settings model =
]
]
, div [ class "field" ]
- [ label [] [ text "Name or Notes" ]
+ [ label [] [ text "Name" ]
, input
[ type_ "text"
, onInput SetName
@@ -536,7 +539,7 @@ view settings model =
]
[]
, span [ class "small-info" ]
- [ text "Looks in item name and notes only."
+ [ text "Looks in item name."
]
]
, span [ class "small-info" ]
diff --git a/modules/webapp/src/main/elm/Main.elm b/modules/webapp/src/main/elm/Main.elm
index cab34bac..fbc29b5e 100644
--- a/modules/webapp/src/main/elm/Main.elm
+++ b/modules/webapp/src/main/elm/Main.elm
@@ -45,12 +45,12 @@ init flags url key =
page =
checkPage flags im.page
- ( m, cmd ) =
+ ( m, cmd, s ) =
if im.page == page then
App.Update.initPage im page
else
- ( im, Page.goto page )
+ ( im, Page.goto page, Sub.none )
sessionCheck =
case m.flags.account of
@@ -60,7 +60,7 @@ init flags url key =
Nothing ->
Cmd.none
in
- ( m
+ ( { m | subs = s }
, Cmd.batch
[ cmd
, ic
diff --git a/modules/webapp/src/main/elm/Page/Home/Data.elm b/modules/webapp/src/main/elm/Page/Home/Data.elm
index 5e8bd36f..7bb62901 100644
--- a/modules/webapp/src/main/elm/Page/Home/Data.elm
+++ b/modules/webapp/src/main/elm/Page/Home/Data.elm
@@ -16,6 +16,7 @@ import Data.Flags exposing (Flags)
import Data.Items
import Data.UiSettings exposing (UiSettings)
import Http
+import Throttle exposing (Throttle)
type alias Model =
@@ -27,6 +28,7 @@ type alias Model =
, searchOffset : Int
, moreAvailable : Bool
, moreInProgress : Bool
+ , throttle : Throttle Msg
}
@@ -40,6 +42,7 @@ init _ =
, searchOffset = 0
, moreAvailable = True
, moreInProgress = False
+ , throttle = Throttle.create 1
}
@@ -53,6 +56,7 @@ type Msg
| DoSearch
| ToggleSearchMenu
| LoadMore
+ | UpdateThrottle
type ViewMode
diff --git a/modules/webapp/src/main/elm/Page/Home/Update.elm b/modules/webapp/src/main/elm/Page/Home/Update.elm
index 9dd5636a..592efc6e 100644
--- a/modules/webapp/src/main/elm/Page/Home/Update.elm
+++ b/modules/webapp/src/main/elm/Page/Home/Update.elm
@@ -7,17 +7,15 @@ import Data.Flags exposing (Flags)
import Data.UiSettings exposing (UiSettings)
import Page exposing (Page(..))
import Page.Home.Data exposing (..)
-import Util.Update
+import Throttle
+import Time
-update : Nav.Key -> Flags -> UiSettings -> Msg -> Model -> ( Model, Cmd Msg )
+update : Nav.Key -> Flags -> UiSettings -> Msg -> Model -> ( Model, Cmd Msg, Sub Msg )
update key flags settings msg model =
case msg of
Init ->
- Util.Update.andThen1
- [ update key flags settings (SearchMenuMsg Comp.SearchMenu.Init)
- ]
- model
+ update key flags settings (SearchMenuMsg Comp.SearchMenu.Init) model
ResetSearch ->
let
@@ -34,14 +32,20 @@ update key flags settings msg model =
newModel =
{ model | searchMenuModel = Tuple.first nextState.modelCmd }
- ( m2, c2 ) =
+ ( m2, c2, s2 ) =
if nextState.stateChange && not model.searchInProgress then
doSearch flags settings newModel
else
- ( newModel, Cmd.none )
+ withSub ( newModel, Cmd.none )
in
- ( m2, Cmd.batch [ c2, Cmd.map SearchMenuMsg (Tuple.second nextState.modelCmd) ] )
+ ( m2
+ , Cmd.batch
+ [ c2
+ , Cmd.map SearchMenuMsg (Tuple.second nextState.modelCmd)
+ ]
+ , s2
+ )
ItemCardListMsg m ->
let
@@ -56,9 +60,10 @@ update key flags settings msg model =
Nothing ->
Cmd.none
in
- ( { model | itemListModel = m2 }
- , Cmd.batch [ Cmd.map ItemCardListMsg c2, cmd ]
- )
+ withSub
+ ( { model | itemListModel = m2 }
+ , Cmd.batch [ Cmd.map ItemCardListMsg c2, cmd ]
+ )
ItemSearchResp (Ok list) ->
let
@@ -92,52 +97,71 @@ update key flags settings msg model =
update key flags settings (ItemCardListMsg (Comp.ItemCardList.AddResults list)) m
ItemSearchAddResp (Err _) ->
- ( { model
- | moreInProgress = False
- }
- , Cmd.none
- )
+ withSub
+ ( { model
+ | moreInProgress = False
+ }
+ , Cmd.none
+ )
ItemSearchResp (Err _) ->
- ( { model
- | searchInProgress = False
- }
- , Cmd.none
- )
+ withSub
+ ( { model
+ | searchInProgress = False
+ }
+ , Cmd.none
+ )
DoSearch ->
let
nm =
{ model | searchOffset = 0 }
in
- doSearch flags settings nm
+ if model.searchInProgress then
+ withSub ( model, Cmd.none )
+
+ else
+ doSearch flags settings nm
ToggleSearchMenu ->
- ( { model | menuCollapsed = not model.menuCollapsed }
- , Cmd.none
- )
+ withSub
+ ( { model | menuCollapsed = not model.menuCollapsed }
+ , Cmd.none
+ )
LoadMore ->
if model.moreAvailable then
- doSearchMore flags settings model
+ doSearchMore flags settings model |> withSub
else
- ( model, Cmd.none )
+ withSub ( model, Cmd.none )
+
+ UpdateThrottle ->
+ let
+ ( newThrottle, cmd ) =
+ Throttle.update model.throttle
+ in
+ withSub ( { model | throttle = newThrottle }, cmd )
-doSearch : Flags -> UiSettings -> Model -> ( Model, Cmd Msg )
+doSearch : Flags -> UiSettings -> Model -> ( Model, Cmd Msg, Sub Msg )
doSearch flags settings model =
let
- cmd =
+ searchCmd =
doSearchCmd flags settings 0 model
+
+ ( newThrottle, cmd ) =
+ Throttle.try searchCmd model.throttle
in
- ( { model
- | searchInProgress = True
- , viewMode = Listing
- , searchOffset = 0
- }
- , cmd
- )
+ withSub
+ ( { model
+ | searchInProgress = cmd /= Cmd.none
+ , viewMode = Listing
+ , searchOffset = 0
+ , throttle = newThrottle
+ }
+ , cmd
+ )
doSearchMore : Flags -> UiSettings -> Model -> ( Model, Cmd Msg )
@@ -149,3 +173,13 @@ doSearchMore flags settings model =
( { model | moreInProgress = True, viewMode = Listing }
, cmd
)
+
+
+withSub : ( Model, Cmd Msg ) -> ( Model, Cmd Msg, Sub Msg )
+withSub ( m, c ) =
+ ( m
+ , c
+ , Throttle.ifNeeded
+ (Time.every 150 (\_ -> UpdateThrottle))
+ m.throttle
+ )
diff --git a/modules/webapp/src/main/elm/Page/Home/View.elm b/modules/webapp/src/main/elm/Page/Home/View.elm
index 73b6249a..4accf452 100644
--- a/modules/webapp/src/main/elm/Page/Home/View.elm
+++ b/modules/webapp/src/main/elm/Page/Home/View.elm
@@ -47,8 +47,15 @@ view settings model =
, onClick DoSearch
, title "Run search query"
, href ""
+ , disabled model.searchInProgress
]
- [ i [ class "ui search icon" ] []
+ [ i
+ [ classList
+ [ ( "search icon", not model.searchInProgress )
+ , ( "loading spinner icon", model.searchInProgress )
+ ]
+ ]
+ []
]
]
]
@@ -82,12 +89,8 @@ view settings model =
]
, case model.viewMode of
Listing ->
- if model.searchInProgress then
- resultPlaceholder
-
- else
- Html.map ItemCardListMsg
- (Comp.ItemCardList.view settings model.itemListModel)
+ Html.map ItemCardListMsg
+ (Comp.ItemCardList.view settings model.itemListModel)
Detail ->
div [] []
@@ -123,34 +126,3 @@ view settings model =
]
]
]
-
-
-resultPlaceholder : Html Msg
-resultPlaceholder =
- div [ class "ui basic segment" ]
- [ div [ class "ui active inverted dimmer" ]
- [ div [ class "ui medium text loader" ]
- [ text "Searching …"
- ]
- ]
- , div [ class "ui middle aligned very relaxed divided basic list segment" ]
- [ div [ class "item" ]
- [ div [ class "ui fluid placeholder" ]
- [ div [ class "full line" ] []
- , div [ class "full line" ] []
- ]
- ]
- , div [ class "item" ]
- [ div [ class "ui fluid placeholder" ]
- [ div [ class "full line" ] []
- , div [ class "full line" ] []
- ]
- ]
- , div [ class "item" ]
- [ div [ class "ui fluid placeholder" ]
- [ div [ class "full line" ] []
- , div [ class "full line" ] []
- ]
- ]
- ]
- ]
diff --git a/modules/webapp/src/main/elm/Util/Update.elm b/modules/webapp/src/main/elm/Util/Update.elm
index dee7dfe4..1d14f4ba 100644
--- a/modules/webapp/src/main/elm/Util/Update.elm
+++ b/modules/webapp/src/main/elm/Util/Update.elm
@@ -1,4 +1,4 @@
-module Util.Update exposing (andThen1)
+module Util.Update exposing (andThen1, andThen2)
andThen1 : List (a -> ( a, Cmd b )) -> a -> ( a, Cmd b )
@@ -16,3 +16,23 @@ andThen1 fs a =
in
List.foldl update init fs
|> Tuple.mapSecond Cmd.batch
+
+
+andThen2 : List (model -> ( model, Cmd msg, Sub msg )) -> model -> ( model, Cmd msg, Sub msg )
+andThen2 fs m =
+ let
+ init =
+ ( m, [], [] )
+
+ update el ( m1, c1, s1 ) =
+ let
+ ( m2, c2, s2 ) =
+ el m1
+ in
+ ( m2, c2 :: c1, s2 :: s1 )
+
+ combine ( m1, cl, sl ) =
+ ( m1, Cmd.batch cl, Sub.batch sl )
+ in
+ List.foldl update init fs
+ |> combine