From 78620c3b4f950e8ab6fd6d4b2b35e818b52e1ab7 Mon Sep 17 00:00:00 2001 From: Danila Fedorin Date: Fri, 14 Dec 2018 00:02:15 -0800 Subject: [PATCH] Scroll when new messages arrive and user is close to the bottom. --- src/Main.elm | 24 ++++++++++++++++++++++++ src/Scylla/Model.elm | 17 ++++++++++++++++- src/Scylla/Views.elm | 4 ++-- 3 files changed, 42 insertions(+), 3 deletions(-) diff --git a/src/Main.elm b/src/Main.elm index 7ff2f4b..f089df7 100644 --- a/src/Main.elm +++ b/src/Main.elm @@ -1,5 +1,6 @@ import Browser exposing (application, UrlRequest(..)) import Browser.Navigation as Nav +import Browser.Dom exposing (Viewport, setViewportOf) import Scylla.Sync exposing (..) import Scylla.Login exposing (..) import Scylla.Model exposing (..) @@ -14,6 +15,7 @@ import Url.Builder import Html exposing (div, text) import Http import Dict +import Task type alias Flags = { token : Maybe String @@ -61,6 +63,8 @@ update msg model = case msg of TryUrl urlRequest -> updateTryUrl model urlRequest OpenRoom s -> (model, Nav.pushUrl model.key <| roomUrl s) ChangeRoute r -> ({ model | route = r }, Cmd.none) + ViewportAfterMessage v -> updateViewportAfterMessage model v + ViewportChangeComplete _ -> (model, Cmd.none) ReceiveLoginResponse r -> updateLoginResponse model r ReceiveFirstSyncResponse r -> updateSyncResponse model r False ReceiveSyncResponse r -> updateSyncResponse model r True @@ -69,6 +73,15 @@ update msg model = case msg of SendRoomText r -> updateSendRoomText model r SendRoomTextResponse r -> (model, Cmd.none) +updateViewportAfterMessage : Model -> Result Browser.Dom.Error Viewport -> (Model, Cmd Msg) +updateViewportAfterMessage m vr = + let + cmd vp = if vp.scene.height - (vp.viewport.y + vp.viewport.height ) < 100 + then Task.attempt ViewportChangeComplete <| setViewportOf "events-wrapper" vp.viewport.x vp.scene.height + else Cmd.none + in + (m, Result.withDefault Cmd.none <| Result.map cmd vr) + updateUserData : Model -> String -> Result Http.Error UserData -> (Model, Cmd Msg) updateUserData m s r = case r of Ok ud -> ({ m | userData = Dict.insert s ud m.userData }, Cmd.none) @@ -121,12 +134,23 @@ updateSyncResponse model r notify = , room = s }) <| notification sr + roomMessages sr = case currentRoomId model of + Just rid -> List.filter (((==) "m.room.message") << .type_) + <| Maybe.withDefault [] + <| Maybe.andThen .events + <| Maybe.andThen .timeline + <| Maybe.andThen (Dict.get rid) + <| Maybe.andThen .join + <| sr.rooms + Nothing -> [] + setScrollCommand sr = if List.isEmpty <| roomMessages sr then Cmd.none else Task.attempt ViewportAfterMessage (Browser.Dom.getViewportOf "events-wrapper") in case r of Ok sr -> ({ model | sync = mergeSyncResponse model.sync sr }, Cmd.batch [ syncCmd , newUserCommands sr , if notify then notificationCommand sr else Cmd.none + , setScrollCommand sr ]) _ -> (model, syncCmd) diff --git a/src/Scylla/Model.elm b/src/Scylla/Model.elm index 574a2a6..07c7e2f 100644 --- a/src/Scylla/Model.elm +++ b/src/Scylla/Model.elm @@ -3,8 +3,9 @@ import Scylla.Api exposing (..) import Scylla.Sync exposing (SyncResponse, JoinedRoom, senderName) import Scylla.Login exposing (LoginResponse, Username, Password) import Scylla.UserData exposing (UserData) -import Scylla.Route exposing (Route) +import Scylla.Route exposing (Route(..), RoomId) import Browser.Navigation as Nav +import Browser.Dom exposing (Viewport) import Url.Builder import Dict exposing (Dict) import Browser @@ -36,6 +37,8 @@ type Msg = | ChangeRoomText String String -- Change to a room's input text | SendRoomText String -- Sends a message typed into a given room's input | SendRoomTextResponse (Result Http.Error ()) -- A send message response finished + | ViewportAfterMessage (Result Browser.Dom.Error Viewport) -- A message has been received, try scroll (maybe) + | ViewportChangeComplete (Result Browser.Dom.Error ()) -- We're done changing the viewport. | ReceiveFirstSyncResponse (Result Http.Error SyncResponse) -- HTTP, Sync has finished | ReceiveSyncResponse (Result Http.Error SyncResponse) -- HTTP, Sync has finished | ReceiveLoginResponse (Result Http.Error LoginResponse) -- HTTP, Login has finished @@ -49,3 +52,15 @@ roomUrl s = Url.Builder.absolute [ "room", s ] [] loginUrl : String loginUrl = Url.Builder.absolute [ "login" ] [] + +currentRoom : Model -> Maybe JoinedRoom +currentRoom m = + let + roomDict = Maybe.withDefault Dict.empty <| Maybe.andThen .join <| m.sync.rooms + in + Maybe.andThen (\s -> Dict.get s roomDict) <| currentRoomId m + +currentRoomId : Model -> Maybe RoomId +currentRoomId m = case m.route of + Room r -> Just r + _ -> Nothing diff --git a/src/Scylla/Views.elm b/src/Scylla/Views.elm index e8da10c..543c012 100644 --- a/src/Scylla/Views.elm +++ b/src/Scylla/Views.elm @@ -11,7 +11,7 @@ import Svg.Attributes import Url.Builder import Json.Decode as Decode import Html exposing (Html, Attribute, div, input, text, button, div, span, a, h2, table, td, tr, img) -import Html.Attributes exposing (type_, value, href, class, style, src) +import Html.Attributes exposing (type_, value, href, class, style, src, id) import Html.Events exposing (onInput, onClick, on) import Dict @@ -156,7 +156,7 @@ iconView name = ] [ Svg.use [ Svg.Attributes.xlinkHref (url ++ "#" ++ name) ] [] ] eventWrapperView : Model -> List (Html Msg) -> Html Msg -eventWrapperView m es = div [ class "events-wrapper" ] [ table [ class "events-table" ] es ] +eventWrapperView m es = div [ class "events-wrapper", id "events-wrapper" ] [ table [ class "events-table" ] es ] eventView : Model -> RoomEvent -> Maybe (Html Msg) eventView m re =