Scylla/src/Main.elm

334 lines
13 KiB
Elm
Raw Normal View History

2018-12-08 20:02:29 -08:00
import Browser exposing (application, UrlRequest(..))
import Browser.Navigation as Nav
import Browser.Dom exposing (Viewport, setViewportOf)
2018-12-08 13:49:30 -08:00
import Scylla.Sync exposing (..)
2018-12-08 15:06:14 -08:00
import Scylla.Login exposing (..)
import Scylla.Api exposing (..)
2018-12-08 13:49:30 -08:00
import Scylla.Model exposing (..)
import Scylla.Http exposing (..)
2018-12-08 15:06:14 -08:00
import Scylla.Views exposing (viewFull)
2018-12-17 19:56:50 -08:00
import Scylla.Route exposing (Route(..), RoomId)
import Scylla.UserData exposing (..)
2018-12-13 13:42:23 -08:00
import Scylla.Notification exposing (..)
import Scylla.Storage exposing (..)
import Url exposing (Url)
2018-12-08 19:09:20 -08:00
import Url.Parser exposing (parse)
import Url.Builder
import Json.Encode
import Json.Decode
2018-12-17 19:56:50 -08:00
import Time exposing (every)
2018-12-08 13:49:30 -08:00
import Html exposing (div, text)
2018-12-20 19:22:51 -08:00
import File exposing (File)
import File.Select as Select
2018-12-08 15:06:14 -08:00
import Http
2018-12-09 23:38:43 -08:00
import Dict
import Task
2018-12-17 19:56:50 -08:00
syncTimeout = 10000
typingTimeout = 2000
2018-12-17 22:07:27 -08:00
init : () -> Url -> Nav.Key -> (Model, Cmd Msg)
init _ url key =
let
model =
{ key = key
2018-12-08 19:09:20 -08:00
, route = Maybe.withDefault Unknown <| parse Scylla.Route.route url
2018-12-17 22:07:27 -08:00
, token = Nothing
2018-12-08 15:06:14 -08:00
, loginUsername = ""
, loginPassword = ""
2018-12-08 13:49:30 -08:00
, apiUrl = "https://matrix.org"
2018-12-08 17:15:35 -08:00
, sync =
{ nextBatch = ""
, rooms = Nothing
, presence = Nothing
, accountData = Nothing
}
, errors = []
2018-12-09 23:38:43 -08:00
, roomText = Dict.empty
, transactionId = 0
, userData = Dict.empty
}
2018-12-17 22:07:27 -08:00
cmd = getStoreValuePort "scylla.loginInfo"
in
(model, cmd)
view : Model -> Browser.Document Msg
view m =
{ title = "Scylla"
2018-12-08 17:15:35 -08:00
, body = viewFull m
}
update : Msg -> Model -> (Model, Cmd Msg)
2018-12-08 15:06:14 -08:00
update msg model = case msg of
ChangeApiUrl u -> ({ model | apiUrl = u }, Cmd.none)
ChangeLoginUsername u -> ({ model | loginUsername = u }, Cmd.none)
ChangeLoginPassword p -> ({ model | loginPassword = p }, Cmd.none)
AttemptLogin -> (model, Scylla.Http.login model.apiUrl model.loginUsername model.loginPassword) -- TODO
2018-12-08 20:02:29 -08:00
TryUrl urlRequest -> updateTryUrl model urlRequest
2018-12-13 14:06:15 -08:00
OpenRoom s -> (model, Nav.pushUrl model.key <| roomUrl s)
2018-12-15 20:56:17 -08:00
ChangeRoute r -> updateChangeRoute model r
ViewportAfterMessage v -> updateViewportAfterMessage model v
ViewportChangeComplete _ -> (model, Cmd.none)
ReceiveLoginResponse a r -> updateLoginResponse model a r
ReceiveFirstSyncResponse r -> updateSyncResponse model r False
ReceiveSyncResponse r -> updateSyncResponse model r True
ReceiveUserData s r -> updateUserData model s r
2018-12-17 19:56:50 -08:00
ChangeRoomText r t -> updateChangeRoomText model r t
2018-12-09 23:38:43 -08:00
SendRoomText r -> updateSendRoomText model r
SendRoomTextResponse r -> (model, Cmd.none)
ReceiveCompletedReadMarker r -> (model, Cmd.none)
ReceiveCompletedTypingIndicator r -> (model, Cmd.none)
ReceiveStoreData d -> updateStoreData model d
2018-12-17 19:56:50 -08:00
TypingTick _ -> updateTypingTick model
2018-12-19 21:52:07 -08:00
History r -> updateHistory model r
ReceiveHistoryResponse r hr -> updateHistoryResponse model r hr
2018-12-20 19:22:51 -08:00
SendImages rid -> (model, Select.files [ "image/png" ] <| ImagesSelected rid)
SendFiles rid -> (model, Select.files [ "application/*" ] <| FilesSelected rid)
ImagesSelected rid f fs -> updateUploadSelected model rid f fs (ImageUploadComplete rid)
FilesSelected rid f fs -> updateUploadSelected model rid f fs (FileUploadComplete rid)
ImageUploadComplete rid ur -> updateImageUploadComplete model rid ur
FileUploadComplete rid ur -> updateFileUploadComplete model rid ur
SendImageResponse _ -> (model, Cmd.none)
SendFileResponse _ -> (model, Cmd.none)
updateFileUploadComplete : Model -> RoomId -> (Result Http.Error String) -> (Model, Cmd Msg)
updateFileUploadComplete m rid ur =
let
command = case ur of
Ok u -> sendFileMessage m.apiUrl (Maybe.withDefault "" m.token) m.transactionId rid u
_ -> Cmd.none
in
({ m | transactionId = m.transactionId + 1}, command)
updateImageUploadComplete : Model -> RoomId -> (Result Http.Error String) -> (Model, Cmd Msg)
updateImageUploadComplete m rid ur =
let
command = case ur of
Ok u -> sendImageMessage m.apiUrl (Maybe.withDefault "" m.token) m.transactionId rid u
_ -> Cmd.none
in
({ m | transactionId = m.transactionId + 1}, command)
updateUploadSelected : Model -> RoomId -> File -> List File -> (Result Http.Error String -> Msg) -> (Model, Cmd Msg)
updateUploadSelected m rid f fs msg =
let
uploadCmds = List.map (uploadMediaFile m.apiUrl (Maybe.withDefault "" m.token) msg) (f::fs)
in
(m, Cmd.batch uploadCmds)
2018-12-17 19:56:50 -08:00
2018-12-19 21:52:07 -08:00
updateHistoryResponse : Model -> RoomId -> Result Http.Error HistoryResponse -> (Model, Cmd Msg)
2018-12-20 16:39:10 -08:00
updateHistoryResponse m r hr =
let
newUsersCmd h = Cmd.batch
<| List.map (userData m.apiUrl (Maybe.withDefault "" m.token))
<| newUsers m
<| uniqueBy (\s -> s)
<| List.map .sender
<| h.chunk
in
case hr of
Ok h -> ({ m | sync = appendHistoryResponse m.sync r h }, newUsersCmd h)
Err _ -> (m, Cmd.none)
2018-12-19 21:52:07 -08:00
updateHistory : Model -> RoomId -> (Model, Cmd Msg)
updateHistory m r =
let
prevBatch = Maybe.andThen .prevBatch
<| Maybe.andThen .timeline
<| Maybe.andThen (Dict.get r)
<| Maybe.andThen .join
<| m.sync.rooms
command = case prevBatch of
Just pv -> getHistory m.apiUrl (Maybe.withDefault "" m.token) r pv
Nothing -> Cmd.none
in
(m, command)
2018-12-17 19:56:50 -08:00
updateChangeRoomText : Model -> RoomId -> String -> (Model, Cmd Msg)
updateChangeRoomText m roomId text =
let
typingIndicator = case (text, Dict.get roomId m.roomText) of
("", _) -> Just False
(_, Just "") -> Just True
2018-12-17 20:30:11 -08:00
(_, Nothing) -> Just True
2018-12-17 19:56:50 -08:00
_ -> Nothing
command = case typingIndicator of
Just b -> sendTypingIndicator m.apiUrl (Maybe.withDefault "" m.token) roomId m.loginUsername b typingTimeout
_ -> Cmd.none
in
({ m | roomText = Dict.insert roomId text m.roomText}, command)
updateTypingTick : Model -> (Model, Cmd Msg)
updateTypingTick m =
let
command = case currentRoomId m of
Just rid -> sendTypingIndicator m.apiUrl (Maybe.withDefault "" m.token) rid m.loginUsername True typingTimeout
Nothing -> Cmd.none
in
(m, command)
updateStoreData : Model -> Json.Encode.Value -> (Model, Cmd Msg)
updateStoreData m d = case (Json.Decode.decodeValue storeDataDecoder d) of
Ok { key, value } -> case key of
"scylla.loginInfo" -> updateLoginInfo m value
_ -> (m, Cmd.none)
Err _ -> (m, Cmd.none)
updateLoginInfo : Model -> Json.Encode.Value -> (Model, Cmd Msg)
updateLoginInfo m s = case Json.Decode.decodeValue (Json.Decode.map decodeLoginInfo Json.Decode.string) s of
2018-12-17 20:30:11 -08:00
Ok (Just { token, apiUrl, username, transactionId }) ->
(
{ m | token = Just token
, apiUrl = apiUrl
, loginUsername = username
, transactionId = transactionId
}
, firstSync apiUrl token
)
_ -> (m, Nav.pushUrl m.key <| Url.Builder.absolute [ "login" ] [])
2018-12-09 23:38:43 -08:00
2018-12-15 20:56:17 -08:00
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
Ok ud -> ({ m | userData = Dict.insert s ud m.userData }, Cmd.none)
Err e -> (m, userData m.apiUrl (Maybe.withDefault "" m.token) s)
2018-12-17 20:30:11 -08:00
updateSendRoomText : Model -> RoomId -> (Model, Cmd Msg)
2018-12-09 23:38:43 -08:00
updateSendRoomText m r =
let
token = Maybe.withDefault "" m.token
message = Maybe.andThen (\s -> if s == "" then Nothing else Just s)
<| Dict.get r m.roomText
2018-12-17 20:30:11 -08:00
combinedCmd = case message of
Nothing -> Cmd.none
Just s -> Cmd.batch
[ sendTextMessage m.apiUrl token m.transactionId r s
, sendTypingIndicator m.apiUrl token r m.loginUsername False typingTimeout
, setStoreValuePort ("scylla.loginInfo", Json.Encode.string
<| encodeLoginInfo
<| LoginInfo (Maybe.withDefault "" m.token) m.apiUrl m.loginUsername (m.transactionId + 1))
]
2018-12-09 23:38:43 -08:00
in
2018-12-17 20:30:11 -08:00
({ m | roomText = Dict.insert r "" m.roomText, transactionId = m.transactionId + 1 }, combinedCmd)
2018-12-08 20:02:29 -08:00
updateTryUrl : Model -> Browser.UrlRequest -> (Model, Cmd Msg)
updateTryUrl m ur = case ur of
Internal u -> (m, Nav.pushUrl m.key (Url.toString u))
_ -> (m, Cmd.none)
2018-12-08 15:06:14 -08:00
updateLoginResponse : Model -> ApiUrl -> Result Http.Error LoginResponse -> (Model, Cmd Msg)
updateLoginResponse model a r = case r of
Ok lr -> ( { model | token = Just lr.accessToken, loginUsername = lr.userId, apiUrl = a }, Cmd.batch
2018-12-08 19:09:20 -08:00
[ firstSync model.apiUrl lr.accessToken
, Nav.pushUrl model.key <| Url.Builder.absolute [] []
2018-12-17 20:30:11 -08:00
, setStoreValuePort ("scylla.loginInfo", Json.Encode.string
<| encodeLoginInfo
<| LoginInfo lr.accessToken model.apiUrl lr.userId model.transactionId)
2018-12-08 19:09:20 -08:00
] )
2018-12-08 15:06:14 -08:00
Err e -> (model, Cmd.none)
updateSyncResponse : Model -> Result Http.Error SyncResponse -> Bool -> (Model, Cmd Msg)
updateSyncResponse model r notify =
2018-12-09 00:35:07 -08:00
let
token = Maybe.withDefault "" model.token
nextBatch = Result.withDefault model.sync.nextBatch
<| Result.map .nextBatch r
2018-12-19 21:52:07 -08:00
syncCmd = sync model.apiUrl token nextBatch
2018-12-14 00:04:41 -08:00
newUserCmd sr = Cmd.batch
2018-12-13 13:42:23 -08:00
<| List.map (userData model.apiUrl
<| Maybe.withDefault "" model.token)
2018-12-20 16:39:10 -08:00
<| newUsers model
<| allUsers sr
2018-12-13 16:01:54 -08:00
notification sr = findFirstBy
(\(s, e) -> e.originServerTs)
(\(s, e) -> e.sender /= model.loginUsername)
2018-12-13 13:42:23 -08:00
<| notificationEvents sr
2018-12-14 00:04:41 -08:00
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 -> []
2018-12-14 00:04:41 -08:00
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
2018-12-09 00:35:07 -08:00
in
case r of
2018-12-13 13:42:23 -08:00
Ok sr -> ({ model | sync = mergeSyncResponse model.sync sr }, Cmd.batch
[ syncCmd
2018-12-14 00:04:41 -08:00
, newUserCmd sr
, notificationCmd sr
, setScrollCmd sr
, setReadReceiptCmd sr
2018-12-13 13:42:23 -08:00
])
_ -> (model, syncCmd)
subscriptions : Model -> Sub Msg
2018-12-17 19:56:50 -08:00
subscriptions m =
let
2018-12-17 20:30:11 -08:00
currentText = Maybe.withDefault ""
<| Maybe.andThen (\rid -> Dict.get rid m.roomText)
<| currentRoomId m
typingTimer = case currentText of
2018-12-17 19:56:50 -08:00
"" -> Sub.none
_ -> every typingTimeout TypingTick
in
Sub.batch
[ onNotificationClickPort OpenRoom
, receiveStoreValuePort ReceiveStoreData
, typingTimer
]
onUrlRequest : Browser.UrlRequest -> Msg
onUrlRequest = TryUrl
onUrlChange : Url -> Msg
2018-12-08 19:09:20 -08:00
onUrlChange = ChangeRoute << Maybe.withDefault Unknown << parse Scylla.Route.route
main = application
{ init = init
, view = view
, update = update
, subscriptions = subscriptions
, onUrlRequest = onUrlRequest
, onUrlChange = onUrlChange
}