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.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
@ -60,7 +62,9 @@ update msg model = case msg of
AttemptLogin -> (model, Scylla.Http.login model.apiUrl model.loginUsername model.loginPassword) -- TODO
TryUrl urlRequest -> updateTryUrl model urlRequest
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
ReceiveFirstSyncResponse r -> updateSyncResponse model r False
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)
SendRoomText r -> updateSendRoomText model r
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 m s r = case r of
@ -106,7 +133,7 @@ updateSyncResponse model r notify =
<| Result.map .nextBatch r
syncCmd = sync nextBatch model.apiUrl token
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
<| Maybe.withDefault "" model.token)
<| newUsers sr
@ -114,19 +141,39 @@ updateSyncResponse model r notify =
(\(s, e) -> e.originServerTs)
(\(s, e) -> e.sender /= model.loginUsername)
<| notificationEvents sr
notificationCommand sr = Maybe.withDefault Cmd.none
<| Maybe.map (\(s, e) -> sendNotificationPort
{ name = displayName model e.sender
, text = notificationText e
, room = s
})
<| notification sr
notificationCmd sr = if notify
then Maybe.withDefault Cmd.none
<| Maybe.map (\(s, e) -> sendNotificationPort
{ name = displayName model e.sender
, text = notificationText e
, room = s
}) <| 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
case r of
Ok sr -> ({ model | sync = mergeSyncResponse model.sync sr }, Cmd.batch
[ syncCmd
, newUserCommands sr
, if notify then notificationCommand sr else Cmd.none
, newUserCmd sr
, notificationCmd sr
, setScrollCmd sr
, setReadReceiptCmd sr
])
_ -> (model, syncCmd)

View File

@ -1,21 +1,25 @@
module Scylla.Http exposing (..)
import Scylla.Model exposing (..)
import Scylla.Api exposing (..)
import Scylla.Route exposing (RoomId)
import Scylla.Sync exposing (syncResponseDecoder)
import Scylla.Login exposing (loginResponseDecoder, Username, Password)
import Scylla.UserData exposing (userDataDecoder, UserData)
import Json.Encode exposing (object, string, int)
import Http exposing (request, emptyBody, jsonBody, expectJson, expectWhatever)
fullUrl : ApiUrl -> ApiUrl
fullUrl s = s ++ "/_matrix/client/r0"
fullClientUrl : ApiUrl -> ApiUrl
fullClientUrl s = s ++ "/_matrix/client/r0"
fullMediaUrl : ApiUrl -> ApiUrl
fullMediaUrl s = s ++ "/_matrix/media/r0"
-- Http Requests
firstSync : ApiUrl -> ApiToken -> Cmd Msg
firstSync apiUrl token = request
{ method = "GET"
, headers = authenticatedHeaders token
, url = (fullUrl apiUrl) ++ "/sync"
, url = (fullClientUrl apiUrl) ++ "/sync"
, body = emptyBody
, expect = expectJson ReceiveFirstSyncResponse syncResponseDecoder
, timeout = Nothing
@ -26,7 +30,7 @@ sync : String -> ApiUrl -> ApiToken -> Cmd Msg
sync nextBatch apiUrl token = request
{ method = "GET"
, headers = authenticatedHeaders token
, url = (fullUrl apiUrl) ++ "/sync" ++ "?since=" ++ (nextBatch) ++ "&timeout=10000"
, url = (fullClientUrl apiUrl) ++ "/sync" ++ "?since=" ++ (nextBatch) ++ "&timeout=10000"
, body = emptyBody
, expect = expectJson ReceiveSyncResponse syncResponseDecoder
, timeout = Nothing
@ -37,7 +41,7 @@ sendTextMessage : ApiUrl -> ApiToken -> Int -> String -> String -> Cmd Msg
sendTextMessage apiUrl token transactionId room message = request
{ method = "PUT"
, headers = authenticatedHeaders token
, url = (fullUrl apiUrl)
, url = (fullClientUrl apiUrl)
++ "/rooms/" ++ room
++ "/send/" ++ "m.room.message"
++ "/" ++ (String.fromInt transactionId)
@ -54,7 +58,7 @@ login : ApiUrl -> Username -> Password -> Cmd Msg
login apiUrl username password = request
{ method = "POST"
, headers = basicHeaders
, url = (fullUrl apiUrl) ++ "/login"
, url = (fullClientUrl apiUrl) ++ "/login"
, body = jsonBody <| object
[ ("type", string "m.login.password")
, ("identifier", object
@ -72,9 +76,26 @@ userData : ApiUrl -> ApiToken -> Username -> Cmd Msg
userData apiUrl token username = request
{ method = "GET"
, headers = authenticatedHeaders token
, url = (fullUrl apiUrl) ++ "/profile/" ++ username
, url = (fullClientUrl apiUrl) ++ "/profile/" ++ username
, body = emptyBody
, expect = expectJson (ReceiveUserData username) userDataDecoder
, timeout = 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.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,10 +37,13 @@ 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
| ReceiveUserData Username (Result Http.Error UserData)
| ReceiveCompletedReadMarker (Result Http.Error ())
displayName : Model -> Username -> String
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 = 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 jr =
let
state = jr.state
nameEvent = findLastEvent (((==) "m.room.name") << .type_)
name e = Result.toMaybe <| Decode.decodeValue (field "name" string) e.content
nameEvent = Maybe.andThen (findLastEvent (((==) "m.room.name") << .type_))
<< Maybe.andThen .events
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
Maybe.andThen name <| Maybe.andThen nameEvent <| Maybe.andThen .events <| state
Maybe.andThen name realEventContent
-- Business Logic: Event Extraction
notificationText : RoomEvent -> String

View File

@ -4,15 +4,27 @@ import Scylla.Sync exposing (..)
import Scylla.Route exposing (..)
import Scylla.Fnv as Fnv
import Scylla.Login exposing (Username)
import Scylla.Http exposing (fullMediaUrl)
import Scylla.Api exposing (ApiUrl)
import Svg
import Svg.Attributes
import Url.Builder
import Json.Decode as Decode
import Html exposing (Html, div, input, text, button, div, span, a, h2, table, td, tr)
import Html.Attributes exposing (type_, value, href, class, style)
import Html.Events exposing (onInput, onClick)
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, id)
import Html.Events exposing (onInput, onClick, on)
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 s =
let
@ -114,6 +126,7 @@ joinedRoomView m roomId jr =
[ input
[ type_ "text"
, onInput <| ChangeRoomText roomId
, onEnterKey <| SendRoomText roomId
, value <| Maybe.withDefault "" <| Dict.get roomId m.roomText
] []
, button [ onClick <| SendRoomText roomId ] [ iconView "send" ]
@ -126,6 +139,13 @@ joinedRoomView m roomId jr =
, 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 name =
let
@ -136,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 =
@ -163,6 +183,7 @@ messageView m re =
in
case msgtype of
Ok "m.text" -> messageTextView m re
Ok "m.image" -> messageImageView m re
_ -> Nothing
messageTextView : Model -> RoomEvent -> Maybe (Html Msg)
@ -172,3 +193,12 @@ messageTextView m re =
wrap mtext = span [] [ text mtext ]
in
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;
margin: 0px;
background-color: $background-color;
font-size: 12px;
}
@mixin input-common {
@ -122,11 +123,16 @@ div.room-wrapper {
flex-direction: column;
}
div.typing-wrapper {
padding: 5px;
}
/*
* The message input and send button.
*/
div.message-wrapper {
display: flex;
flex-shrink: 0;
input {
flex-grow: 9;
@ -154,6 +160,11 @@ table.events-table {
vertical-align: top;
}
img {
max-width: 90%;
max-height: 400px;
}
td:nth-child(1) {
width: 10%;
max-width: 100px;