Compare commits

..

10 Commits

6 changed files with 157 additions and 27 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
@ -60,7 +62,9 @@ update msg model = case msg of
AttemptLogin -> (model, Scylla.Http.login model.apiUrl model.loginUsername model.loginPassword) -- TODO AttemptLogin -> (model, Scylla.Http.login model.apiUrl model.loginUsername model.loginPassword) -- TODO
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 -> updateChangeRoute model r
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
@ -68,6 +72,29 @@ update msg model = case msg of
ChangeRoomText r t -> ({ model | roomText = Dict.insert r t model.roomText}, Cmd.none) ChangeRoomText r t -> ({ model | roomText = Dict.insert r t model.roomText}, Cmd.none)
SendRoomText r -> updateSendRoomText model r SendRoomText r -> updateSendRoomText model r
SendRoomTextResponse r -> (model, Cmd.none) SendRoomTextResponse r -> (model, Cmd.none)
ReceiveCompletedReadMarker r -> (model, Cmd.none)
updateChangeRoute : Model -> Route -> (Model, Cmd Msg)
updateChangeRoute m r =
let
joinedRoom = case r of
Room rid -> Maybe.andThen (Dict.get rid) <| Maybe.andThen .join <| m.sync.rooms
_ -> Nothing
lastMessage = Maybe.andThen (findLastEvent (((==) "m.room.message") << .type_)) <| Maybe.andThen .events <| Maybe.andThen .timeline joinedRoom
readMarkerCmd = case (r, lastMessage) of
(Room rid, Just re) -> setReadMarkers m.apiUrl (Maybe.withDefault "" m.token) rid re.eventId <| Just re.eventId
_ -> Cmd.none
in
({ m | route = r }, readMarkerCmd)
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
@ -106,7 +133,7 @@ updateSyncResponse model r notify =
<| Result.map .nextBatch r <| Result.map .nextBatch r
syncCmd = sync nextBatch model.apiUrl token syncCmd = sync nextBatch model.apiUrl token
newUsers sr = List.filter (\s -> not <| Dict.member s model.userData) <| roomsUsers sr newUsers sr = List.filter (\s -> not <| Dict.member s model.userData) <| roomsUsers sr
newUserCommands sr = Cmd.batch newUserCmd sr = Cmd.batch
<| List.map (userData model.apiUrl <| List.map (userData model.apiUrl
<| Maybe.withDefault "" model.token) <| Maybe.withDefault "" model.token)
<| newUsers sr <| newUsers sr
@ -114,19 +141,39 @@ updateSyncResponse model r notify =
(\(s, e) -> e.originServerTs) (\(s, e) -> e.originServerTs)
(\(s, e) -> e.sender /= model.loginUsername) (\(s, e) -> e.sender /= model.loginUsername)
<| notificationEvents sr <| notificationEvents sr
notificationCommand sr = Maybe.withDefault Cmd.none notificationCmd sr = if notify
<| Maybe.map (\(s, e) -> sendNotificationPort then Maybe.withDefault Cmd.none
{ name = displayName model e.sender <| Maybe.map (\(s, e) -> sendNotificationPort
, text = notificationText e { name = displayName model e.sender
, room = s , text = notificationText e
}) , room = s
<| notification sr }) <| notification sr
else Cmd.none
room = currentRoomId model
roomMessages sr = case room 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 -> []
setScrollCmd sr = if List.isEmpty
<| roomMessages sr
then Cmd.none
else Task.attempt ViewportAfterMessage (Browser.Dom.getViewportOf "events-wrapper")
setReadReceiptCmd sr = case (room, List.head <| List.reverse <| roomMessages sr) of
(Just rid, Just re) -> setReadMarkers model.apiUrl token rid re.eventId <| Just re.eventId
_ -> Cmd.none
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 , newUserCmd sr
, if notify then notificationCommand sr else Cmd.none , notificationCmd sr
, setScrollCmd sr
, setReadReceiptCmd sr
]) ])
_ -> (model, syncCmd) _ -> (model, syncCmd)

View File

@ -1,21 +1,25 @@
module Scylla.Http exposing (..) module Scylla.Http exposing (..)
import Scylla.Model exposing (..) import Scylla.Model exposing (..)
import Scylla.Api exposing (..) import Scylla.Api exposing (..)
import Scylla.Route exposing (RoomId)
import Scylla.Sync exposing (syncResponseDecoder) import Scylla.Sync exposing (syncResponseDecoder)
import Scylla.Login exposing (loginResponseDecoder, Username, Password) import Scylla.Login exposing (loginResponseDecoder, Username, Password)
import Scylla.UserData exposing (userDataDecoder, UserData) import Scylla.UserData exposing (userDataDecoder, UserData)
import Json.Encode exposing (object, string, int) import Json.Encode exposing (object, string, int)
import Http exposing (request, emptyBody, jsonBody, expectJson, expectWhatever) import Http exposing (request, emptyBody, jsonBody, expectJson, expectWhatever)
fullUrl : ApiUrl -> ApiUrl fullClientUrl : ApiUrl -> ApiUrl
fullUrl s = s ++ "/_matrix/client/r0" fullClientUrl s = s ++ "/_matrix/client/r0"
fullMediaUrl : ApiUrl -> ApiUrl
fullMediaUrl s = s ++ "/_matrix/media/r0"
-- Http Requests -- Http Requests
firstSync : ApiUrl -> ApiToken -> Cmd Msg firstSync : ApiUrl -> ApiToken -> Cmd Msg
firstSync apiUrl token = request firstSync apiUrl token = request
{ method = "GET" { method = "GET"
, headers = authenticatedHeaders token , headers = authenticatedHeaders token
, url = (fullUrl apiUrl) ++ "/sync" , url = (fullClientUrl apiUrl) ++ "/sync"
, body = emptyBody , body = emptyBody
, expect = expectJson ReceiveFirstSyncResponse syncResponseDecoder , expect = expectJson ReceiveFirstSyncResponse syncResponseDecoder
, timeout = Nothing , timeout = Nothing
@ -26,7 +30,7 @@ sync : String -> ApiUrl -> ApiToken -> Cmd Msg
sync nextBatch apiUrl token = request sync nextBatch apiUrl token = request
{ method = "GET" { method = "GET"
, headers = authenticatedHeaders token , headers = authenticatedHeaders token
, url = (fullUrl apiUrl) ++ "/sync" ++ "?since=" ++ (nextBatch) ++ "&timeout=10000" , url = (fullClientUrl apiUrl) ++ "/sync" ++ "?since=" ++ (nextBatch) ++ "&timeout=10000"
, body = emptyBody , body = emptyBody
, expect = expectJson ReceiveSyncResponse syncResponseDecoder , expect = expectJson ReceiveSyncResponse syncResponseDecoder
, timeout = Nothing , timeout = Nothing
@ -37,7 +41,7 @@ sendTextMessage : ApiUrl -> ApiToken -> Int -> String -> String -> Cmd Msg
sendTextMessage apiUrl token transactionId room message = request sendTextMessage apiUrl token transactionId room message = request
{ method = "PUT" { method = "PUT"
, headers = authenticatedHeaders token , headers = authenticatedHeaders token
, url = (fullUrl apiUrl) , url = (fullClientUrl apiUrl)
++ "/rooms/" ++ room ++ "/rooms/" ++ room
++ "/send/" ++ "m.room.message" ++ "/send/" ++ "m.room.message"
++ "/" ++ (String.fromInt transactionId) ++ "/" ++ (String.fromInt transactionId)
@ -54,7 +58,7 @@ login : ApiUrl -> Username -> Password -> Cmd Msg
login apiUrl username password = request login apiUrl username password = request
{ method = "POST" { method = "POST"
, headers = basicHeaders , headers = basicHeaders
, url = (fullUrl apiUrl) ++ "/login" , url = (fullClientUrl apiUrl) ++ "/login"
, body = jsonBody <| object , body = jsonBody <| object
[ ("type", string "m.login.password") [ ("type", string "m.login.password")
, ("identifier", object , ("identifier", object
@ -72,9 +76,26 @@ userData : ApiUrl -> ApiToken -> Username -> Cmd Msg
userData apiUrl token username = request userData apiUrl token username = request
{ method = "GET" { method = "GET"
, headers = authenticatedHeaders token , headers = authenticatedHeaders token
, url = (fullUrl apiUrl) ++ "/profile/" ++ username , url = (fullClientUrl apiUrl) ++ "/profile/" ++ username
, body = emptyBody , body = emptyBody
, expect = expectJson (ReceiveUserData username) userDataDecoder , expect = expectJson (ReceiveUserData username) userDataDecoder
, timeout = Nothing , timeout = Nothing
, tracker = Nothing , tracker = Nothing
} }
setReadMarkers : ApiUrl -> ApiToken -> String -> RoomId -> Maybe String -> Cmd Msg
setReadMarkers apiUrl token roomId fullyRead readReceipt =
let
readReciptFields = case readReceipt of
Just s -> [ ("m.read", string s) ]
_ -> []
in
request
{ method = "POST"
, headers = authenticatedHeaders token
, url = (fullClientUrl apiUrl) ++ "/rooms/" ++ roomId ++ "/read_markers"
, body = jsonBody <| object <| [ ("m.fully_read", string fullyRead) ] ++ readReciptFields
, expect = expectWhatever ReceiveCompletedReadMarker
, timeout = Nothing
, tracker = Nothing
}

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,10 +37,13 @@ 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
| ReceiveUserData Username (Result Http.Error UserData) | ReceiveUserData Username (Result Http.Error UserData)
| ReceiveCompletedReadMarker (Result Http.Error ())
displayName : Model -> Username -> String displayName : Model -> Username -> String
displayName m s = Maybe.withDefault (senderName s) <| Maybe.andThen .displayName <| Dict.get s m.userData displayName m s = Maybe.withDefault (senderName s) <| Maybe.andThen .displayName <| Dict.get s m.userData
@ -49,3 +53,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

@ -387,11 +387,16 @@ senderName s =
roomName : JoinedRoom -> Maybe String roomName : JoinedRoom -> Maybe String
roomName jr = roomName jr =
let let
state = jr.state nameEvent = Maybe.andThen (findLastEvent (((==) "m.room.name") << .type_))
nameEvent = findLastEvent (((==) "m.room.name") << .type_) << Maybe.andThen .events
name e = Result.toMaybe <| Decode.decodeValue (field "name" string) e.content name c = Result.toMaybe <| Decode.decodeValue (field "name" string) c
maybeStateEvent = nameEvent jr.state
maybeTimelineEvent = nameEvent jr.timeline
realEventContent = case maybeTimelineEvent of
Just te -> Just te.content
_ -> Maybe.map .content maybeStateEvent
in in
Maybe.andThen name <| Maybe.andThen nameEvent <| Maybe.andThen .events <| state Maybe.andThen name realEventContent
-- Business Logic: Event Extraction -- Business Logic: Event Extraction
notificationText : RoomEvent -> String notificationText : RoomEvent -> String

View File

@ -4,15 +4,27 @@ import Scylla.Sync exposing (..)
import Scylla.Route exposing (..) import Scylla.Route exposing (..)
import Scylla.Fnv as Fnv import Scylla.Fnv as Fnv
import Scylla.Login exposing (Username) import Scylla.Login exposing (Username)
import Scylla.Http exposing (fullMediaUrl)
import Scylla.Api exposing (ApiUrl)
import Svg import Svg
import Svg.Attributes import Svg.Attributes
import Url.Builder import Url.Builder
import Json.Decode as Decode import Json.Decode as Decode
import Html exposing (Html, div, input, text, button, div, span, a, h2, table, td, tr) 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) import Html.Attributes exposing (type_, value, href, class, style, src, id)
import Html.Events exposing (onInput, onClick) import Html.Events exposing (onInput, onClick, on)
import Dict import Dict
contentRepositoryDownloadUrl : ApiUrl -> String -> String
contentRepositoryDownloadUrl apiUrl s =
let
lastIndex = Maybe.withDefault 6 <| List.head <| List.reverse <| String.indexes "/" s
authority = String.slice 6 lastIndex s
content = String.dropLeft (lastIndex + 1) s
in
(fullMediaUrl apiUrl) ++ "/download/" ++ authority ++ "/" ++ content
stringColor : String -> String stringColor : String -> String
stringColor s = stringColor s =
let let
@ -114,6 +126,7 @@ joinedRoomView m roomId jr =
[ input [ input
[ type_ "text" [ type_ "text"
, onInput <| ChangeRoomText roomId , onInput <| ChangeRoomText roomId
, onEnterKey <| SendRoomText roomId
, value <| Maybe.withDefault "" <| Dict.get roomId m.roomText , value <| Maybe.withDefault "" <| Dict.get roomId m.roomText
] [] ] []
, button [ onClick <| SendRoomText roomId ] [ iconView "send" ] , button [ onClick <| SendRoomText roomId ] [ iconView "send" ]
@ -126,6 +139,13 @@ joinedRoomView m roomId jr =
, messageInput , messageInput
] ]
onEnterKey : Msg -> Attribute Msg
onEnterKey msg =
let
isEnter code = if code == 13 then Decode.succeed msg else Decode.fail "Not ENTER"
in
on "keydown" (Decode.andThen isEnter <| Decode.field "keyCode" Decode.int)
iconView : String -> Html Msg iconView : String -> Html Msg
iconView name = iconView name =
let let
@ -136,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 =
@ -163,6 +183,7 @@ messageView m re =
in in
case msgtype of case msgtype of
Ok "m.text" -> messageTextView m re Ok "m.text" -> messageTextView m re
Ok "m.image" -> messageImageView m re
_ -> Nothing _ -> Nothing
messageTextView : Model -> RoomEvent -> Maybe (Html Msg) messageTextView : Model -> RoomEvent -> Maybe (Html Msg)
@ -172,3 +193,12 @@ messageTextView m re =
wrap mtext = span [] [ text mtext ] wrap mtext = span [] [ text mtext ]
in in
Maybe.map wrap <| Result.toMaybe body Maybe.map wrap <| Result.toMaybe body
messageImageView : Model -> RoomEvent -> Maybe (Html Msg)
messageImageView m re =
let
body = Decode.decodeValue (Decode.field "url" Decode.string) re.content
in
Maybe.map (\s -> img [ class "message-image", src s ] [])
<| Maybe.map (contentRepositoryDownloadUrl m.apiUrl)
<| Result.toMaybe body

View File

@ -19,6 +19,7 @@ body {
font-family: 'Open Sans', sans-serif; font-family: 'Open Sans', sans-serif;
margin: 0px; margin: 0px;
background-color: $background-color; background-color: $background-color;
font-size: 12px;
} }
@mixin input-common { @mixin input-common {
@ -122,11 +123,16 @@ div.room-wrapper {
flex-direction: column; flex-direction: column;
} }
div.typing-wrapper {
padding: 5px;
}
/* /*
* The message input and send button. * The message input and send button.
*/ */
div.message-wrapper { div.message-wrapper {
display: flex; display: flex;
flex-shrink: 0;
input { input {
flex-grow: 9; flex-grow: 9;
@ -154,6 +160,11 @@ table.events-table {
vertical-align: top; vertical-align: top;
} }
img {
max-width: 90%;
max-height: 400px;
}
td:nth-child(1) { td:nth-child(1) {
width: 10%; width: 10%;
max-width: 100px; max-width: 100px;