1
0
Fork 0
tooty/src/Model.elm

795 lines
25 KiB
Elm

module Model exposing (..)
import Dom
import Json.Encode as Encode
import Navigation
import Mastodon.Decoder
import Mastodon.Encoder
import Mastodon.Helper
import Mastodon.Http
import Mastodon.Model
import Mastodon.WebSocket
import Ports
import Task
type alias Flags =
{ client : Maybe Mastodon.Model.Client
, registration : Maybe Mastodon.Model.AppRegistration
}
type DraftMsg
= ClearDraft
| ClearReplyTo
| UpdateSensitive Bool
| UpdateSpoiler String
| UpdateStatus String
| UpdateVisibility String
| UpdateReplyTo Mastodon.Model.Status
| ToggleSpoiler Bool
type ViewerMsg
= CloseViewer
| OpenViewer (List Mastodon.Model.Attachment) Mastodon.Model.Attachment
type MastodonMsg
= AccessToken (Result Mastodon.Model.Error Mastodon.Model.AccessTokenResult)
| AppRegistered (Result Mastodon.Model.Error Mastodon.Model.AppRegistration)
| ContextLoaded Mastodon.Model.Status (Result Mastodon.Model.Error Mastodon.Model.Context)
| FavoriteAdded (Result Mastodon.Model.Error Mastodon.Model.Status)
| FavoriteRemoved (Result Mastodon.Model.Error Mastodon.Model.Status)
| LocalTimeline (Result Mastodon.Model.Error (List Mastodon.Model.Status))
| Notifications (Result Mastodon.Model.Error (List Mastodon.Model.Notification))
| GlobalTimeline (Result Mastodon.Model.Error (List Mastodon.Model.Status))
| Reblogged (Result Mastodon.Model.Error Mastodon.Model.Status)
| StatusPosted (Result Mastodon.Model.Error Mastodon.Model.Status)
| Unreblogged (Result Mastodon.Model.Error Mastodon.Model.Status)
| Account (Result Mastodon.Model.Error Mastodon.Model.Account)
| AccountTimeline (Result Mastodon.Model.Error (List Mastodon.Model.Status))
| UserTimeline (Result Mastodon.Model.Error (List Mastodon.Model.Status))
type WebSocketMsg
= NewWebsocketUserMessage String
| NewWebsocketGlobalMessage String
| NewWebsocketLocalMessage String
type Msg
= AddFavorite Int
| ClearOpenedAccount
| CloseThread
| DraftEvent DraftMsg
| LoadAccount Int
| MastodonEvent MastodonMsg
| NoOp
| OpenThread Mastodon.Model.Status
| Reblog Int
| Register
| RemoveFavorite Int
| ServerChange String
| SubmitDraft
| UrlChange Navigation.Location
| UseGlobalTimeline Bool
| Unreblog Int
| ViewerEvent ViewerMsg
| WebSocketEvent WebSocketMsg
type alias Draft =
{ status : String
, in_reply_to : Maybe Mastodon.Model.Status
, spoiler_text : Maybe String
, sensitive : Bool
, visibility : String
}
type alias Thread =
{ status : Mastodon.Model.Status
, context : Mastodon.Model.Context
}
type alias Viewer =
{ attachments : List Mastodon.Model.Attachment
, attachment : Mastodon.Model.Attachment
}
type CurrentView
= -- Basically, what we should be displaying in the fourth column
AccountView Mastodon.Model.Account
| ThreadView Thread
| LocalTimelineView
| GlobalTimelineView
type alias Model =
{ server : String
, registration : Maybe Mastodon.Model.AppRegistration
, client : Maybe Mastodon.Model.Client
, userTimeline : List Mastodon.Model.Status
, localTimeline : List Mastodon.Model.Status
, globalTimeline : List Mastodon.Model.Status
, accountTimeline : List Mastodon.Model.Status
, notifications : List Mastodon.Model.NotificationAggregate
, draft : Draft
, errors : List String
, location : Navigation.Location
, useGlobalTimeline : Bool
, viewer : Maybe Viewer
, currentView : CurrentView
}
extractAuthCode : Navigation.Location -> Maybe String
extractAuthCode { search } =
case (String.split "?code=" search) of
[ _, authCode ] ->
Just authCode
_ ->
Nothing
defaultDraft : Draft
defaultDraft =
{ status = ""
, in_reply_to = Nothing
, spoiler_text = Nothing
, sensitive = False
, visibility = "public"
}
init : Flags -> Navigation.Location -> ( Model, Cmd Msg )
init flags location =
let
authCode =
extractAuthCode location
in
{ server = ""
, registration = flags.registration
, client = flags.client
, userTimeline = []
, localTimeline = []
, globalTimeline = []
, accountTimeline = []
, notifications = []
, draft = defaultDraft
, errors = []
, location = location
, useGlobalTimeline = False
, viewer = Nothing
, currentView = LocalTimelineView
}
! [ initCommands flags.registration flags.client authCode ]
initCommands : Maybe Mastodon.Model.AppRegistration -> Maybe Mastodon.Model.Client -> Maybe String -> Cmd Msg
initCommands registration client authCode =
Cmd.batch <|
case authCode of
Just authCode ->
case registration of
Just registration ->
[ Mastodon.Http.getAccessToken registration authCode
|> Mastodon.Http.send (MastodonEvent << AccessToken)
]
Nothing ->
[]
Nothing ->
[ loadTimelines client ]
registerApp : Model -> Cmd Msg
registerApp { server, location } =
let
appUrl =
location.origin ++ location.pathname
cleanServer =
if String.endsWith "/" server then
String.dropRight 1 server
else
server
in
Mastodon.Http.register
cleanServer
"tooty"
appUrl
"read write follow"
"https://github.com/n1k0/tooty"
|> Mastodon.Http.send (MastodonEvent << AppRegistered)
saveClient : Mastodon.Model.Client -> Cmd Msg
saveClient client =
Mastodon.Encoder.clientEncoder client
|> Encode.encode 0
|> Ports.saveClient
saveRegistration : Mastodon.Model.AppRegistration -> Cmd Msg
saveRegistration registration =
Mastodon.Encoder.registrationEncoder registration
|> Encode.encode 0
|> Ports.saveRegistration
loadNotifications : Maybe Mastodon.Model.Client -> Cmd Msg
loadNotifications client =
case client of
Just client ->
Mastodon.Http.fetchNotifications client
|> Mastodon.Http.send (MastodonEvent << Notifications)
Nothing ->
Cmd.none
loadTimelines : Maybe Mastodon.Model.Client -> Cmd Msg
loadTimelines client =
case client of
Just client ->
Cmd.batch
[ Mastodon.Http.fetchUserTimeline client
|> Mastodon.Http.send (MastodonEvent << UserTimeline)
, Mastodon.Http.fetchLocalTimeline client
|> Mastodon.Http.send (MastodonEvent << LocalTimeline)
, Mastodon.Http.fetchGlobalTimeline client
|> Mastodon.Http.send (MastodonEvent << GlobalTimeline)
, loadNotifications <| Just client
]
Nothing ->
Cmd.none
preferredTimeline : Model -> CurrentView
preferredTimeline model =
if model.useGlobalTimeline then
GlobalTimelineView
else
LocalTimelineView
postStatus : Mastodon.Model.Client -> Mastodon.Model.StatusRequestBody -> Cmd Msg
postStatus client draft =
Mastodon.Http.postStatus client draft
|> Mastodon.Http.send (MastodonEvent << StatusPosted)
errorText : Mastodon.Model.Error -> String
errorText error =
case error of
Mastodon.Model.MastodonError statusCode statusMsg errorMsg ->
"HTTP " ++ (toString statusCode) ++ " " ++ statusMsg ++ ": " ++ errorMsg
Mastodon.Model.ServerError statusCode statusMsg errorMsg ->
"HTTP " ++ (toString statusCode) ++ " " ++ statusMsg ++ ": " ++ errorMsg
Mastodon.Model.TimeoutError ->
"Request timed out."
Mastodon.Model.NetworkError ->
"Unreachable host."
toStatusRequestBody : Draft -> Mastodon.Model.StatusRequestBody
toStatusRequestBody draft =
{ status = draft.status
, in_reply_to_id =
case draft.in_reply_to of
Just status ->
Just status.id
Nothing ->
Nothing
, spoiler_text = draft.spoiler_text
, sensitive = draft.sensitive
, visibility = draft.visibility
}
updateTimelinesWithBoolFlag : Int -> Bool -> (Mastodon.Model.Status -> Mastodon.Model.Status) -> Model -> Model
updateTimelinesWithBoolFlag statusId flag statusUpdater model =
let
update flag status =
if (Mastodon.Helper.extractReblog status).id == statusId then
statusUpdater status
else
status
in
{ model
| userTimeline = List.map (update flag) model.userTimeline
, localTimeline = List.map (update flag) model.localTimeline
, globalTimeline = List.map (update flag) model.globalTimeline
}
processFavourite : Int -> Bool -> Model -> Model
processFavourite statusId flag model =
updateTimelinesWithBoolFlag statusId flag (\s -> { s | favourited = Just flag }) model
processReblog : Int -> Bool -> Model -> Model
processReblog statusId flag model =
updateTimelinesWithBoolFlag statusId flag (\s -> { s | reblogged = Just flag }) model
deleteStatusFromTimeline : Int -> List Mastodon.Model.Status -> List Mastodon.Model.Status
deleteStatusFromTimeline statusId timeline =
timeline
|> List.filter
(\s ->
s.id
/= statusId
&& (Mastodon.Helper.extractReblog s).id
/= statusId
)
updateDraft : DraftMsg -> Draft -> ( Draft, Cmd Msg )
updateDraft draftMsg draft =
case draftMsg of
ClearDraft ->
defaultDraft ! []
ToggleSpoiler enabled ->
{ draft
| spoiler_text =
if enabled then
Just ""
else
Nothing
}
! []
UpdateSensitive sensitive ->
{ draft | sensitive = sensitive } ! []
UpdateSpoiler spoiler_text ->
{ draft | spoiler_text = Just spoiler_text } ! []
UpdateStatus status ->
{ draft | status = status } ! []
UpdateVisibility visibility ->
{ draft | visibility = visibility } ! []
UpdateReplyTo status ->
let
mention =
"@" ++ status.account.acct
in
{ draft
| in_reply_to = Just status
, status =
if String.startsWith mention draft.status then
draft.status
else
mention ++ " " ++ draft.status
, sensitive = Maybe.withDefault False status.sensitive
, spoiler_text =
if status.spoiler_text == "" then
Nothing
else
Just status.spoiler_text
, visibility = status.visibility
}
! [ Dom.focus "status" |> Task.attempt (always NoOp) ]
ClearReplyTo ->
{ draft | in_reply_to = Nothing } ! []
updateViewer : ViewerMsg -> Maybe Viewer -> ( Maybe Viewer, Cmd Msg )
updateViewer viewerMsg viewer =
case viewerMsg of
CloseViewer ->
Nothing ! []
OpenViewer attachments attachment ->
(Just <| Viewer attachments attachment) ! []
processMastodonEvent : MastodonMsg -> Model -> ( Model, Cmd Msg )
processMastodonEvent msg model =
case msg of
AccessToken result ->
case result of
Ok { server, accessToken } ->
let
client =
Mastodon.Model.Client server accessToken
in
{ model | client = Just client }
! [ loadTimelines <| Just client
, Navigation.modifyUrl model.location.pathname
, saveClient client
]
Err error ->
{ model | errors = (errorText error) :: model.errors } ! []
AppRegistered result ->
case result of
Ok registration ->
{ model | registration = Just registration }
! [ saveRegistration registration
, Navigation.load <| Mastodon.Http.getAuthorizationUrl registration
]
Err error ->
{ model | errors = (errorText error) :: model.errors } ! []
ContextLoaded status result ->
case result of
Ok context ->
let
thread =
Thread status context
in
{ model | currentView = ThreadView thread } ! []
Err error ->
{ model
| currentView = preferredTimeline model
, errors = (errorText error) :: model.errors
}
! []
FavoriteAdded result ->
case result of
Ok status ->
processFavourite status.id True model ! [ loadNotifications model.client ]
Err error ->
{ model | errors = (errorText error) :: model.errors } ! []
FavoriteRemoved result ->
case result of
Ok status ->
processFavourite status.id False model ! [ loadNotifications model.client ]
Err error ->
{ model | errors = (errorText error) :: model.errors } ! []
LocalTimeline result ->
case result of
Ok localTimeline ->
{ model | localTimeline = localTimeline } ! []
Err error ->
{ model | localTimeline = [], errors = (errorText error) :: model.errors } ! []
Notifications result ->
case result of
Ok notifications ->
{ model | notifications = Mastodon.Helper.aggregateNotifications notifications } ! []
Err error ->
{ model | notifications = [], errors = (errorText error) :: model.errors } ! []
GlobalTimeline result ->
case result of
Ok globalTimeline ->
{ model | globalTimeline = globalTimeline } ! []
Err error ->
{ model | globalTimeline = [], errors = (errorText error) :: model.errors } ! []
Reblogged result ->
case result of
Ok status ->
model ! [ loadNotifications model.client ]
Err error ->
{ model | errors = (errorText error) :: model.errors } ! []
StatusPosted _ ->
{ model | draft = defaultDraft } ! []
Unreblogged result ->
case result of
Ok status ->
model ! [ loadNotifications model.client ]
Err error ->
{ model | errors = (errorText error) :: model.errors } ! []
Account result ->
case result of
Ok account ->
{ model | currentView = AccountView account } ! []
Err error ->
{ model
| currentView = preferredTimeline model
, errors = (errorText error) :: model.errors
}
! []
AccountTimeline result ->
case result of
Ok statuses ->
{ model | accountTimeline = statuses } ! []
Err error ->
{ model | errors = (errorText error) :: model.errors } ! []
UserTimeline result ->
case result of
Ok userTimeline ->
{ model | userTimeline = userTimeline } ! []
Err error ->
{ model | userTimeline = [], errors = (errorText error) :: model.errors } ! []
processWebSocketMsg : WebSocketMsg -> Model -> ( Model, Cmd Msg )
processWebSocketMsg msg model =
case msg of
NewWebsocketUserMessage message ->
case (Mastodon.Decoder.decodeWebSocketMessage message) of
Mastodon.WebSocket.ErrorEvent error ->
{ model | errors = error :: model.errors } ! []
Mastodon.WebSocket.StatusUpdateEvent result ->
case result of
Ok status ->
{ model | userTimeline = status :: model.userTimeline } ! []
Err error ->
{ model | errors = error :: model.errors } ! []
Mastodon.WebSocket.StatusDeleteEvent result ->
case result of
Ok id ->
{ model | userTimeline = deleteStatusFromTimeline id model.userTimeline } ! []
Err error ->
{ model | errors = error :: model.errors } ! []
Mastodon.WebSocket.NotificationEvent result ->
case result of
Ok notification ->
let
notifications =
Mastodon.Helper.addNotificationToAggregates
notification
model.notifications
in
{ model | notifications = notifications } ! []
Err error ->
{ model | errors = error :: model.errors } ! []
NewWebsocketLocalMessage message ->
case (Mastodon.Decoder.decodeWebSocketMessage message) of
Mastodon.WebSocket.ErrorEvent error ->
{ model | errors = error :: model.errors } ! []
Mastodon.WebSocket.StatusUpdateEvent result ->
case result of
Ok status ->
{ model | localTimeline = status :: model.localTimeline } ! []
Err error ->
{ model | errors = error :: model.errors } ! []
Mastodon.WebSocket.StatusDeleteEvent result ->
case result of
Ok id ->
{ model | localTimeline = deleteStatusFromTimeline id model.localTimeline } ! []
Err error ->
{ model | errors = error :: model.errors } ! []
_ ->
model ! []
NewWebsocketGlobalMessage message ->
case (Mastodon.Decoder.decodeWebSocketMessage message) of
Mastodon.WebSocket.ErrorEvent error ->
{ model | errors = error :: model.errors } ! []
Mastodon.WebSocket.StatusUpdateEvent result ->
case result of
Ok status ->
{ model | globalTimeline = status :: model.globalTimeline } ! []
Err error ->
{ model | errors = error :: model.errors } ! []
Mastodon.WebSocket.StatusDeleteEvent result ->
case result of
Ok id ->
{ model | globalTimeline = deleteStatusFromTimeline id model.globalTimeline } ! []
Err error ->
{ model | errors = error :: model.errors } ! []
_ ->
model ! []
update : Msg -> Model -> ( Model, Cmd Msg )
update msg model =
case msg of
NoOp ->
model ! []
MastodonEvent msg ->
let
( newModel, commands ) =
processMastodonEvent msg model
in
newModel ! [ commands ]
WebSocketEvent msg ->
let
( newModel, commands ) =
processWebSocketMsg msg model
in
newModel ! [ commands ]
ServerChange server ->
{ model | server = server } ! []
UrlChange location ->
model ! []
Register ->
model ! [ registerApp model ]
OpenThread status ->
case model.client of
Just client ->
model
! [ Mastodon.Http.context client status.id
|> Mastodon.Http.send (MastodonEvent << (ContextLoaded status))
]
Nothing ->
model ! []
CloseThread ->
{ model | currentView = preferredTimeline model } ! []
Reblog id ->
-- Note: The case of reblogging is specific as it seems the server
-- response takes a lot of time to be received by the client, so we
-- perform optimistic updates here.
case model.client of
Just client ->
processReblog id True model
! [ Mastodon.Http.reblog client id
|> Mastodon.Http.send (MastodonEvent << Reblogged)
]
Nothing ->
model ! []
Unreblog id ->
case model.client of
Just client ->
processReblog id False model
! [ Mastodon.Http.unfavourite client id
|> Mastodon.Http.send (MastodonEvent << Unreblogged)
]
Nothing ->
model ! []
AddFavorite id ->
model
! case model.client of
Just client ->
[ Mastodon.Http.favourite client id
|> Mastodon.Http.send (MastodonEvent << FavoriteAdded)
]
Nothing ->
[]
RemoveFavorite id ->
model
! case model.client of
Just client ->
[ Mastodon.Http.unfavourite client id
|> Mastodon.Http.send (MastodonEvent << FavoriteRemoved)
]
Nothing ->
[]
DraftEvent draftMsg ->
let
( draft, commands ) =
updateDraft draftMsg model.draft
in
{ model | draft = draft } ! [ commands ]
ViewerEvent viewerMsg ->
let
( viewer, commands ) =
updateViewer viewerMsg model.viewer
in
{ model | viewer = viewer } ! [ commands ]
SubmitDraft ->
model
! case model.client of
Just client ->
[ postStatus client <| toStatusRequestBody model.draft ]
Nothing ->
[]
LoadAccount accountId ->
{-
@TODO
When requesting a user profile, we should load a new "page"
so that the URL in the browser matches the user displayed
-}
{ model | currentView = preferredTimeline model }
! case model.client of
Just client ->
[ Mastodon.Http.fetchAccount client accountId
|> Mastodon.Http.send (MastodonEvent << Account)
, Mastodon.Http.fetchAccountTimeline client accountId
|> Mastodon.Http.send (MastodonEvent << AccountTimeline)
]
Nothing ->
[]
UseGlobalTimeline flag ->
let
newModel =
{ model | useGlobalTimeline = flag }
in
{ model | currentView = preferredTimeline newModel } ! []
ClearOpenedAccount ->
{ model | currentView = preferredTimeline model } ! []
subscriptions : Model -> Sub Msg
subscriptions model =
case model.client of
Just client ->
let
subs =
[ Mastodon.WebSocket.subscribeToWebSockets
client
Mastodon.WebSocket.UserStream
NewWebsocketUserMessage
]
++ (if model.useGlobalTimeline then
[ Mastodon.WebSocket.subscribeToWebSockets
client
Mastodon.WebSocket.GlobalPublicStream
NewWebsocketGlobalMessage
]
else
[ Mastodon.WebSocket.subscribeToWebSockets
client
Mastodon.WebSocket.LocalPublicStream
NewWebsocketLocalMessage
]
)
in
Sub.batch <| List.map (Sub.map WebSocketEvent) subs
Nothing ->
Sub.batch []