Compare commits

...

3 Commits

4 changed files with 82 additions and 42 deletions

View File

@ -52,6 +52,7 @@ init _ url key =
, sending = Dict.empty , sending = Dict.empty
, transactionId = 0 , transactionId = 0
, userData = Dict.empty , userData = Dict.empty
, roomNames = Dict.empty
, connected = True , connected = True
, searchText = "" , searchText = ""
} }
@ -319,7 +320,7 @@ updateSyncResponse model r notify =
notificationCmd sr = if notify notificationCmd sr = if notify
then Maybe.withDefault Cmd.none then Maybe.withDefault Cmd.none
<| Maybe.map (\(s, e) -> sendNotificationPort <| Maybe.map (\(s, e) -> sendNotificationPort
{ name = displayName model e.sender { name = displayName model.userData e.sender
, text = notificationText e , text = notificationText e
, room = s , room = s
}) <| notification sr }) <| notification sr
@ -343,9 +344,16 @@ updateSyncResponse model r notify =
_ -> Cmd.none _ -> Cmd.none
receivedEvents sr = List.map Just <| allTimelineEventIds sr receivedEvents sr = List.map Just <| allTimelineEventIds sr
sending sr = Dict.filter (\_ (rid, { body, id }) -> not <| List.member id <| receivedEvents sr) model.sending sending sr = Dict.filter (\_ (rid, { body, id }) -> not <| List.member id <| receivedEvents sr) model.sending
newSync sr = mergeSyncResponse model.sync sr
newModel sr =
{ model | sync = newSync sr
, sending = sending (mergeSyncResponse model.sync sr)
, roomNames = computeRoomsDisplayNames model.userData (newSync sr)
}
in in
case r of case r of
Ok sr -> ({ model | sync = mergeSyncResponse model.sync sr, sending = sending (mergeSyncResponse model.sync sr) }, Cmd.batch Ok sr -> (newModel sr
, Cmd.batch
[ syncCmd [ syncCmd
, newUserCmd sr , newUserCmd sr
, notificationCmd sr , notificationCmd sr

View File

@ -1,6 +1,6 @@
module Scylla.Model exposing (..) module Scylla.Model exposing (..)
import Scylla.Api exposing (..) import Scylla.Api exposing (..)
import Scylla.Sync exposing (SyncResponse, HistoryResponse, JoinedRoom, senderName, roomName, roomJoinedUsers) import Scylla.Sync exposing (SyncResponse, HistoryResponse, JoinedRoom, senderName, roomName, roomJoinedUsers, findFirst, directMessagesDecoder, AccountData)
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(..), RoomId) import Scylla.Route exposing (Route(..), RoomId)
@ -13,7 +13,7 @@ import Url.Builder
import Dict exposing (Dict) import Dict exposing (Dict)
import Time exposing (Posix) import Time exposing (Posix)
import File exposing (File) import File exposing (File)
import Json.Decode import Json.Decode as Decode
import Browser import Browser
import Http import Http
import Url exposing (Url) import Url exposing (Url)
@ -31,6 +31,7 @@ type alias Model =
, sending : Dict Int (RoomId, SendingMessage) , sending : Dict Int (RoomId, SendingMessage)
, transactionId : Int , transactionId : Int
, userData : Dict Username UserData , userData : Dict Username UserData
, roomNames : Dict RoomId String
, connected : Bool , connected : Bool
, searchText : String , searchText : String
} }
@ -54,7 +55,7 @@ type Msg =
| ReceiveUserData Username (Result Http.Error UserData) -- HTTP, receive user data | ReceiveUserData Username (Result Http.Error UserData) -- HTTP, receive user data
| ReceiveCompletedReadMarker (Result Http.Error ()) -- HTTP, read marker request completed | ReceiveCompletedReadMarker (Result Http.Error ()) -- HTTP, read marker request completed
| ReceiveCompletedTypingIndicator (Result Http.Error ()) -- HTTP, typing indicator request completed | ReceiveCompletedTypingIndicator (Result Http.Error ()) -- HTTP, typing indicator request completed
| ReceiveStoreData Json.Decode.Value -- We are send back a value on request from localStorage. | ReceiveStoreData Decode.Value -- We are send back a value on request from localStorage.
| TypingTick Posix -- Tick for updating the typing status | TypingTick Posix -- Tick for updating the typing status
| History RoomId -- Load history for a room | History RoomId -- Load history for a room
| ReceiveHistoryResponse RoomId (Result Http.Error HistoryResponse) -- HTTP, receive history | ReceiveHistoryResponse RoomId (Result Http.Error HistoryResponse) -- HTTP, receive history
@ -71,27 +72,40 @@ type Msg =
| AttemptReconnect | AttemptReconnect
| UpdateSearchText String | UpdateSearchText String
displayName : Model -> Username -> String displayName : Dict String UserData -> Username -> String
displayName m s = Maybe.withDefault (senderName s) <| Maybe.andThen .displayName <| Dict.get s m.userData displayName ud s = Maybe.withDefault (senderName s) <| Maybe.andThen .displayName <| Dict.get s ud
roomDisplayName : Model -> JoinedRoom -> String roomDisplayName : Model -> RoomId -> String
roomDisplayName m jr = roomDisplayName m rid =
Maybe.withDefault "<No Name>" <| Dict.get rid m.roomNames
computeRoomDisplayName : Dict String UserData -> Maybe AccountData -> RoomId -> JoinedRoom -> Maybe String
computeRoomDisplayName ud ad rid jr =
let let
customName = roomName jr customName = roomName jr
roomUsers = List.filter ((/=) m.loginUsername) <| roomJoinedUsers jr direct = ad
singleUserName = if List.length roomUsers == 1 then List.head roomUsers else Nothing |> Maybe.andThen .events
singleUserDisplayName = Maybe.andThen |> Maybe.andThen (findFirst ((==) "m.direct" << .type_))
(\u -> Maybe.andThen .displayName <| Dict.get u m.userData) singleUserName |> Maybe.map (Decode.decodeValue directMessagesDecoder << .content)
firstOption d os = case os of |> Maybe.andThen Result.toMaybe
[] -> d |> Maybe.andThen (Dict.get rid)
((Just v)::_) -> v
(Nothing::xs) -> firstOption d xs
in in
firstOption "<No Name>" case (customName, direct) of
[ customName (Just s, _) -> customName
, singleUserDisplayName (_, Just u) -> direct
, singleUserName _ -> Nothing
]
computeRoomsDisplayNames : Dict String UserData -> SyncResponse -> Dict String String
computeRoomsDisplayNames ud sr =
sr.rooms
|> Maybe.andThen .join
|> Maybe.map Dict.toList
|> Maybe.map (List.foldl
(\(rid, jr) d ->
computeRoomDisplayName ud sr.accountData rid jr
|> Maybe.map (\n -> Dict.insert rid n d)
|> Maybe.withDefault d) Dict.empty)
|> Maybe.withDefault Dict.empty
roomUrl : String -> String roomUrl : String -> String
roomUrl s = Url.Builder.absolute [ "room", s ] [] roomUrl s = Url.Builder.absolute [ "room", s ] []

View File

@ -258,6 +258,22 @@ historyResponseDecoder =
|> required "end" string |> required "end" string
|> required "chunk" (list roomEventDecoder) |> required "chunk" (list roomEventDecoder)
-- Direct Messages
type alias DirectMessages = Dict String String
type alias DirectMessagesRaw = Dict String (List String)
directMessagesDecoder : Decoder DirectMessages
directMessagesDecoder =
Decode.dict (Decode.list Decode.string)
|> Decode.map (invertDirectMessages)
invertDirectMessages : DirectMessagesRaw -> DirectMessages
invertDirectMessages dmr =
Dict.foldl
(\k lv acc -> List.foldl (\v -> Dict.insert v k) acc lv)
Dict.empty
dmr
-- Business Logic: Helper Functions -- Business Logic: Helper Functions
groupBy : (a -> comparable) -> List a -> Dict comparable (List a) groupBy : (a -> comparable) -> List a -> Dict comparable (List a)
groupBy f xs = groupBy f xs =
@ -268,15 +284,17 @@ groupBy f xs =
in in
List.foldl (\v acc -> Dict.update (f v) (update v) acc) Dict.empty xs List.foldl (\v acc -> Dict.update (f v) (update v) acc) Dict.empty xs
uniqueByRecursive : (a -> comparable) -> List a -> Set comparable -> List a uniqueByTailRecursive : (a -> comparable) -> List a -> Set comparable -> List a -> List a
uniqueByRecursive f l s = case l of uniqueByTailRecursive f l s acc =
x::tail -> if Set.member (f x) s case l of
then uniqueByRecursive f tail s x::tail ->
else x::uniqueByRecursive f tail (Set.insert (f x) s) if Set.member (f x) s
[] -> [] then uniqueByTailRecursive f tail s acc
else uniqueByTailRecursive f tail s (x::acc)
[] -> List.reverse acc
uniqueBy : (a -> comparable) -> List a -> List a uniqueBy : (a -> comparable) -> List a -> List a
uniqueBy f l = uniqueByRecursive f l Set.empty uniqueBy f l = uniqueByTailRecursive f l Set.empty []
findFirst : (a -> Bool) -> List a -> Maybe a findFirst : (a -> Bool) -> List a -> Maybe a
findFirst cond l = case l of findFirst cond l = case l of
@ -302,18 +320,18 @@ findLastEvent = findLastBy .originServerTs
mergeMaybe : (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a mergeMaybe : (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
mergeMaybe f l r = case (l, r) of mergeMaybe f l r = case (l, r) of
(Just v1, Just v2) -> Just <| f v1 v2 (Just v1, Just v2) -> Just <| f v1 v2
(Just v, Nothing) -> Just v (Just v, Nothing) -> l
(Nothing, Just v) -> Just v (Nothing, Just v) -> r
_ -> Nothing _ -> Nothing
mergeEvents : List Event -> List Event -> List Event mergeEvents : List Event -> List Event -> List Event
mergeEvents l1 l2 = l1 ++ l2 mergeEvents l1 l2 = l1 ++ l2
mergeStateEvents : List StateEvent -> List StateEvent -> List StateEvent mergeStateEvents : List StateEvent -> List StateEvent -> List StateEvent
mergeStateEvents l1 l2 = uniqueBy .eventId <| l1 ++ l2 mergeStateEvents l1 l2 = l1 ++ l2
mergeRoomEvents : List RoomEvent -> List RoomEvent -> List RoomEvent mergeRoomEvents : List RoomEvent -> List RoomEvent -> List RoomEvent
mergeRoomEvents l1 l2 = uniqueBy .eventId <| l1 ++ l2 mergeRoomEvents l1 l2 = l1 ++ l2
mergeStrippedStates : List StrippedState -> List StrippedState -> List StrippedState mergeStrippedStates : List StrippedState -> List StrippedState -> List StrippedState
mergeStrippedStates l1 l2 = l1 ++ l2 mergeStrippedStates l1 l2 = l1 ++ l2

View File

@ -109,18 +109,18 @@ homeserverView m hs rs =
let let
roomList = div [ class "rooms-list" ] roomList = div [ class "rooms-list" ]
<| List.map (\(rid, r) -> roomListElementView m rid r) <| List.map (\(rid, r) -> roomListElementView m rid r)
<| List.sortBy (\(rid, r) -> roomDisplayName m r) rs <| List.sortBy (\(rid, r) -> roomDisplayName m rid) rs
in in
div [ class "homeserver-wrapper" ] [ h3 [] [ text hs ], roomList ] div [ class "homeserver-wrapper" ] [ h3 [] [ text hs ], roomList ]
roomListElementView : Model -> String -> JoinedRoom -> Html Msg roomListElementView : Model -> RoomId -> JoinedRoom -> Html Msg
roomListElementView m s jr = roomListElementView m rid jr =
let let
name = roomDisplayName m jr name = roomDisplayName m rid
isVisible = m.searchText == "" || (String.contains (String.toLower m.searchText) <| String.toLower name) isVisible = m.searchText == "" || (String.contains (String.toLower m.searchText) <| String.toLower name)
isCurrentRoom = case currentRoomId m of isCurrentRoom = case currentRoomId m of
Nothing -> False Nothing -> False
Just cr -> cr == s Just cr -> cr == rid
in in
div [ classList div [ classList
[ ("room-link-wrapper", True) [ ("room-link-wrapper", True)
@ -129,7 +129,7 @@ roomListElementView m s jr =
] ]
] ]
<| roomNotificationCountView jr.unreadNotifications ++ <| roomNotificationCountView jr.unreadNotifications ++
[ a [ href <| roomUrl s ] [ text name ] ] [ a [ href <| roomUrl rid ] [ text name ] ]
roomNotificationCountView : Maybe UnreadNotificationCounts -> List (Html Msg) roomNotificationCountView : Maybe UnreadNotificationCounts -> List (Html Msg)
roomNotificationCountView ns = roomNotificationCountView ns =
@ -161,7 +161,7 @@ joinedRoomView m roomId rd =
let let
renderedMessages = List.map (userMessagesView m) <| mergeMessages m.loginUsername <| extractMessages rd renderedMessages = List.map (userMessagesView m) <| mergeMessages m.loginUsername <| extractMessages rd
messagesWrapper = messagesWrapperView m roomId renderedMessages messagesWrapper = messagesWrapperView m roomId renderedMessages
typing = List.map (displayName m) <| roomTypingUsers rd.joinedRoom typing = List.map (displayName m.userData) <| roomTypingUsers rd.joinedRoom
typingText = String.join ", " typing typingText = String.join ", " typing
typingSuffix = case List.length typing of typingSuffix = case List.length typing of
0 -> "" 0 -> ""
@ -182,7 +182,7 @@ joinedRoomView m roomId rd =
] ]
in in
div [ class "room-wrapper" ] div [ class "room-wrapper" ]
[ h2 [] [ text <| roomDisplayName m rd.joinedRoom ] [ h2 [] [ text <| roomDisplayName m roomId ]
, messagesWrapper , messagesWrapper
, messageInput , messageInput
, typingWrapper , typingWrapper
@ -215,7 +215,7 @@ messagesWrapperView m rid es = div [ class "messages-wrapper", id "messages-wrap
senderView : Model -> Username -> Html Msg senderView : Model -> Username -> Html Msg
senderView m s = senderView m s =
span [ style "color" <| stringColor s, class "sender-wrapper" ] [ text <| displayName m s ] span [ style "color" <| stringColor s, class "sender-wrapper" ] [ text <| displayName m.userData s ]
userMessagesView : Model -> (Username, List Message) -> Html Msg userMessagesView : Model -> (Username, List Message) -> Html Msg
userMessagesView m (u, ms) = userMessagesView m (u, ms) =