Scroll when new messages arrive and user is close to the bottom.

This commit is contained in:
Danila Fedorin 2018-12-14 00:02:15 -08:00
parent fdb3213ec5
commit 78620c3b4f
3 changed files with 42 additions and 3 deletions

View File

@ -1,5 +1,6 @@
import Browser exposing (application, UrlRequest(..)) import Browser exposing (application, UrlRequest(..))
import Browser.Navigation as Nav import Browser.Navigation as Nav
import Browser.Dom exposing (Viewport, setViewportOf)
import Scylla.Sync exposing (..) import Scylla.Sync exposing (..)
import Scylla.Login exposing (..) import Scylla.Login exposing (..)
import Scylla.Model exposing (..) import Scylla.Model exposing (..)
@ -14,6 +15,7 @@ import Url.Builder
import Html exposing (div, text) import Html exposing (div, text)
import Http import Http
import Dict import Dict
import Task
type alias Flags = type alias Flags =
{ token : Maybe String { token : Maybe String
@ -61,6 +63,8 @@ update msg model = case msg of
TryUrl urlRequest -> updateTryUrl model urlRequest TryUrl urlRequest -> updateTryUrl model urlRequest
OpenRoom s -> (model, Nav.pushUrl model.key <| roomUrl s) OpenRoom s -> (model, Nav.pushUrl model.key <| roomUrl s)
ChangeRoute r -> ({ model | route = r }, Cmd.none) ChangeRoute r -> ({ model | route = r }, Cmd.none)
ViewportAfterMessage v -> updateViewportAfterMessage model v
ViewportChangeComplete _ -> (model, Cmd.none)
ReceiveLoginResponse r -> updateLoginResponse model r ReceiveLoginResponse r -> updateLoginResponse model r
ReceiveFirstSyncResponse r -> updateSyncResponse model r False ReceiveFirstSyncResponse r -> updateSyncResponse model r False
ReceiveSyncResponse r -> updateSyncResponse model r True ReceiveSyncResponse r -> updateSyncResponse model r True
@ -69,6 +73,15 @@ update msg model = case msg of
SendRoomText r -> updateSendRoomText model r SendRoomText r -> updateSendRoomText model r
SendRoomTextResponse r -> (model, Cmd.none) 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 : Model -> String -> Result Http.Error UserData -> (Model, Cmd Msg)
updateUserData m s r = case r of updateUserData m s r = case r of
Ok ud -> ({ m | userData = Dict.insert s ud m.userData }, Cmd.none) Ok ud -> ({ m | userData = Dict.insert s ud m.userData }, Cmd.none)
@ -121,12 +134,23 @@ updateSyncResponse model r notify =
, room = s , room = s
}) })
<| notification sr <| 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 in
case r of case r of
Ok sr -> ({ model | sync = mergeSyncResponse model.sync sr }, Cmd.batch Ok sr -> ({ model | sync = mergeSyncResponse model.sync sr }, Cmd.batch
[ syncCmd [ syncCmd
, newUserCommands sr , newUserCommands sr
, if notify then notificationCommand sr else Cmd.none , if notify then notificationCommand sr else Cmd.none
, setScrollCommand sr
]) ])
_ -> (model, syncCmd) _ -> (model, syncCmd)

View File

@ -3,8 +3,9 @@ import Scylla.Api exposing (..)
import Scylla.Sync exposing (SyncResponse, JoinedRoom, senderName) import Scylla.Sync exposing (SyncResponse, JoinedRoom, senderName)
import Scylla.Login exposing (LoginResponse, Username, Password) import Scylla.Login exposing (LoginResponse, Username, Password)
import Scylla.UserData exposing (UserData) import Scylla.UserData exposing (UserData)
import Scylla.Route exposing (Route) import Scylla.Route exposing (Route(..), RoomId)
import Browser.Navigation as Nav import Browser.Navigation as Nav
import Browser.Dom exposing (Viewport)
import Url.Builder import Url.Builder
import Dict exposing (Dict) import Dict exposing (Dict)
import Browser import Browser
@ -36,6 +37,8 @@ type Msg =
| ChangeRoomText String String -- Change to a room's input text | ChangeRoomText String String -- Change to a room's input text
| SendRoomText String -- Sends a message typed into a given room's input | SendRoomText String -- Sends a message typed into a given room's input
| SendRoomTextResponse (Result Http.Error ()) -- A send message response finished | 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 | ReceiveFirstSyncResponse (Result Http.Error SyncResponse) -- HTTP, Sync has finished
| ReceiveSyncResponse (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 | ReceiveLoginResponse (Result Http.Error LoginResponse) -- HTTP, Login has finished
@ -49,3 +52,15 @@ roomUrl s = Url.Builder.absolute [ "room", s ] []
loginUrl : String loginUrl : String
loginUrl = Url.Builder.absolute [ "login" ] [] 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

View File

@ -11,7 +11,7 @@ import Svg.Attributes
import Url.Builder import Url.Builder
import Json.Decode as Decode import Json.Decode as Decode
import Html exposing (Html, Attribute, div, input, text, button, div, span, a, h2, table, td, tr, img) 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 Html.Events exposing (onInput, onClick, on)
import Dict import Dict
@ -156,7 +156,7 @@ iconView name =
] [ Svg.use [ Svg.Attributes.xlinkHref (url ++ "#" ++ name) ] [] ] ] [ Svg.use [ Svg.Attributes.xlinkHref (url ++ "#" ++ name) ] [] ]
eventWrapperView : Model -> List (Html Msg) -> Html Msg 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 : Model -> RoomEvent -> Maybe (Html Msg)
eventView m re = eventView m re =