module Model exposing (..) import Autocomplete import Command import List.Extra exposing (removeAt) import Navigation import Mastodon.Decoder import Mastodon.Helper import Mastodon.Http exposing (Links) import Mastodon.Model exposing (..) import Mastodon.WebSocket import String.Extra import Task import Types exposing (..) maxBuffer : Int maxBuffer = -- Max number of entries to keep in columns 100 extractAuthCode : Navigation.Location -> Maybe String extractAuthCode { search } = case (String.split "?code=" search) of [ _, authCode ] -> Just authCode _ -> Nothing defaultDraft : Draft defaultDraft = { status = "" , inReplyTo = Nothing , spoilerText = Nothing , sensitive = False , visibility = "public" , statusLength = 0 , autoState = Autocomplete.empty , autoAtPosition = Nothing , autoQuery = "" , autoCursorPosition = 0 , autoMaxResults = 4 , autoAccounts = [] , showAutoMenu = False } init : Flags -> Navigation.Location -> ( Model, Cmd Msg ) init flags location = let authCode = extractAuthCode location in { server = "" , registration = flags.registration , client = flags.client , homeTimeline = emptyTimeline "home-timeline" , localTimeline = emptyTimeline "local-timeline" , globalTimeline = emptyTimeline "global-timeline" , accountTimeline = emptyTimeline "account-timeline" , accountFollowers = [] , accountFollowing = [] , accountRelationships = [] , accountRelationship = Nothing , notifications = emptyTimeline "notifications" , draft = defaultDraft , errors = [] , location = location , useGlobalTimeline = False , viewer = Nothing , currentView = LocalTimelineView , currentUser = Nothing , notificationFilter = NotificationAll } ! [ Command.initCommands flags.registration flags.client authCode ] emptyTimeline : String -> Timeline a emptyTimeline id = { id = id , entries = [] , links = Links Nothing Nothing } preferredTimeline : Model -> CurrentView preferredTimeline model = if model.useGlobalTimeline then GlobalTimelineView else LocalTimelineView errorText : Error -> String errorText error = case error of MastodonError statusCode statusMsg errorMsg -> "HTTP " ++ (toString statusCode) ++ " " ++ statusMsg ++ ": " ++ errorMsg ServerError statusCode statusMsg errorMsg -> "HTTP " ++ (toString statusCode) ++ " " ++ statusMsg ++ ": " ++ errorMsg TimeoutError -> "Request timed out." NetworkError -> "Unreachable host." toStatusRequestBody : Draft -> StatusRequestBody toStatusRequestBody draft = { status = draft.status , in_reply_to_id = case draft.inReplyTo of Just status -> Just status.id Nothing -> Nothing , spoiler_text = draft.spoilerText , sensitive = draft.sensitive , visibility = draft.visibility } updateTimelinesWithBoolFlag : Int -> Bool -> (Status -> Status) -> Model -> Model updateTimelinesWithBoolFlag statusId flag statusUpdater model = let update status = if (Mastodon.Helper.extractReblog status).id == statusId then statusUpdater status else status updateTimeline timeline = { timeline | entries = List.map update timeline.entries } in { model | homeTimeline = updateTimeline model.homeTimeline , accountTimeline = updateTimeline model.accountTimeline , localTimeline = updateTimeline model.localTimeline , globalTimeline = updateTimeline model.globalTimeline , currentView = case model.currentView of ThreadView thread -> ThreadView { status = update thread.status , context = { ancestors = List.map update thread.context.ancestors , descendants = List.map update thread.context.descendants } } currentView -> currentView } processFavourite : Int -> Bool -> Model -> Model processFavourite statusId flag model = -- TODO: update notifications too updateTimelinesWithBoolFlag statusId flag (\s -> { s | favourited = Just flag , favourites_count = if flag then s.favourites_count + 1 else if s.favourites_count > 0 then s.favourites_count - 1 else 0 } ) model processReblog : Int -> Bool -> Model -> Model processReblog statusId flag model = -- TODO: update notifications too updateTimelinesWithBoolFlag statusId flag (\s -> { s | reblogged = Just flag , reblogs_count = if flag then s.reblogs_count + 1 else if s.reblogs_count > 0 then s.reblogs_count - 1 else 0 } ) model deleteStatusFromTimeline : Int -> Timeline Status -> Timeline Status deleteStatusFromTimeline statusId timeline = let update status = status.id /= statusId && (Mastodon.Helper.extractReblog status).id /= statusId in { timeline | entries = List.filter update timeline.entries } deleteStatusFromAllTimelines : Int -> Model -> Model deleteStatusFromAllTimelines id model = -- TODO: delete from thread timeline & notifications { model | homeTimeline = deleteStatusFromTimeline id model.homeTimeline , localTimeline = deleteStatusFromTimeline id model.localTimeline , globalTimeline = deleteStatusFromTimeline id model.globalTimeline , accountTimeline = deleteStatusFromTimeline id model.accountTimeline , currentView = deleteStatusFromCurrentView id model } deleteStatusFromCurrentView : Int -> Model -> CurrentView deleteStatusFromCurrentView id model = -- TODO: delete from current account view case model.currentView of ThreadView thread -> if thread.status.id == id then -- the current thread status as been deleted, close it preferredTimeline model else let update statuses = List.filter (\s -> s.id /= id) statuses in ThreadView { thread | context = { ancestors = update thread.context.ancestors , descendants = update thread.context.descendants } } currentView -> currentView {-| Update viewed account relationships as well as the relationship with the current connected user, both according to the "following" status provided. -} processFollowEvent : Relationship -> Bool -> Model -> Model processFollowEvent relationship flag model = let updateRelationship r = if r.id == relationship.id then { r | following = flag } else r accountRelationships = model.accountRelationships |> List.map updateRelationship accountRelationship = case model.accountRelationship of Just accountRelationship -> if accountRelationship.id == relationship.id then Just { relationship | following = flag } else model.accountRelationship Nothing -> Nothing in { model | accountRelationships = accountRelationships , accountRelationship = accountRelationship } updateDraft : DraftMsg -> Account -> Model -> ( Model, Cmd Msg ) updateDraft draftMsg currentUser model = let draft = model.draft in case draftMsg of ClearDraft -> { model | draft = defaultDraft } ! [ Command.updateDomStatus defaultDraft.status ] ToggleSpoiler enabled -> let newDraft = { draft | spoilerText = if enabled then Just "" else Nothing } in { model | draft = newDraft } ! [] UpdateSensitive sensitive -> { model | draft = { draft | sensitive = sensitive } } ! [] UpdateSpoiler spoilerText -> { model | draft = { draft | spoilerText = Just spoilerText } } ! [] UpdateVisibility visibility -> { model | draft = { draft | visibility = visibility } } ! [] UpdateReplyTo status -> let newStatus = Mastodon.Helper.getReplyPrefix currentUser status in { model | draft = { draft | inReplyTo = Just status , status = newStatus , sensitive = Maybe.withDefault False status.sensitive , spoilerText = if status.spoiler_text == "" then Nothing else Just status.spoiler_text , visibility = status.visibility } } ! [ Command.focusId "status" , Command.updateDomStatus newStatus ] UpdateInputInformation { status, selectionStart } -> let stringToPos = String.slice 0 selectionStart status atPosition = case (String.right 1 stringToPos) of "@" -> Just selectionStart " " -> Nothing _ -> model.draft.autoAtPosition query = case atPosition of Just position -> String.slice position (String.length stringToPos) stringToPos Nothing -> "" newDraft = { draft | status = status , statusLength = String.length status , autoCursorPosition = selectionStart , autoAtPosition = atPosition , autoQuery = query , showAutoMenu = showAutoMenu draft.autoAccounts draft.autoAtPosition draft.autoQuery } in { model | draft = newDraft } ! if query /= "" && atPosition /= Nothing then [ Command.searchAccounts model.client query model.draft.autoMaxResults False ] else [] SelectAccount id -> let account = List.filter (\account -> toString account.id == id) draft.autoAccounts |> List.head stringToAtPos = case draft.autoAtPosition of Just atPosition -> String.slice 0 atPosition draft.status _ -> "" stringToPos = String.slice 0 draft.autoCursorPosition draft.status newStatus = case draft.autoAtPosition of Just atPosition -> String.Extra.replaceSlice (case account of Just a -> a.acct ++ " " Nothing -> "" ) atPosition ((String.length draft.autoQuery) + atPosition) draft.status _ -> "" newDraft = { draft | status = newStatus , autoAtPosition = Nothing , autoQuery = "" , autoState = Autocomplete.empty , autoAccounts = [] , showAutoMenu = False } in { model | draft = newDraft } -- As we are using defaultValue, we need to update the textarea -- using a port. ! [ Command.updateDomStatus newStatus ] SetAutoState autoMsg -> let ( newState, maybeMsg ) = Autocomplete.update updateAutocompleteConfig autoMsg draft.autoMaxResults draft.autoState (acceptableAccounts draft.autoQuery draft.autoAccounts) newModel = { model | draft = { draft | autoState = newState } } in case maybeMsg of Nothing -> newModel ! [] Just updateMsg -> update updateMsg newModel ResetAutocomplete toTop -> let newDraft = { draft | autoState = if toTop then Autocomplete.resetToFirstItem updateAutocompleteConfig (acceptableAccounts draft.autoQuery draft.autoAccounts) draft.autoMaxResults draft.autoState else Autocomplete.resetToLastItem updateAutocompleteConfig (acceptableAccounts draft.autoQuery draft.autoAccounts) draft.autoMaxResults draft.autoState } in { model | draft = newDraft } ! [] updateViewer : ViewerMsg -> Maybe Viewer -> ( Maybe Viewer, Cmd Msg ) updateViewer viewerMsg viewer = case viewerMsg of CloseViewer -> Nothing ! [] OpenViewer attachments attachment -> (Just <| Viewer attachments attachment) ! [] updateTimeline : Bool -> List a -> Links -> Timeline a -> Timeline a updateTimeline append entries links timeline = let newEntries = if append then List.concat [ timeline.entries, entries ] else entries in { timeline | entries = newEntries, links = links } prependToTimeline : a -> Timeline a -> Timeline a prependToTimeline entry timeline = { timeline | entries = entry :: timeline.entries } processMastodonEvent : MastodonMsg -> Model -> ( Model, Cmd Msg ) processMastodonEvent msg model = case msg of AccessToken result -> case result of Ok { decoded } -> let client = Client decoded.server decoded.accessToken in { model | client = Just client } ! [ Command.loadTimelines <| Just client , Command.saveClient client , Navigation.modifyUrl model.location.pathname , Navigation.reload ] Err error -> { model | errors = (errorText error) :: model.errors } ! [] AccountFollowed result -> case result of Ok { decoded } -> processFollowEvent decoded True model ! [] Err error -> { model | errors = (errorText error) :: model.errors } ! [] AccountUnfollowed result -> case result of Ok { decoded } -> processFollowEvent decoded False model ! [] Err error -> { model | errors = (errorText error) :: model.errors } ! [] AppRegistered result -> case result of Ok { decoded } -> { model | registration = Just decoded } ! [ Command.saveRegistration decoded , Command.navigateToAuthUrl decoded ] Err error -> { model | errors = (errorText error) :: model.errors } ! [] ContextLoaded status result -> case result of Ok { decoded } -> { model | currentView = ThreadView (Thread status decoded) } ! [ Command.scrollToThreadStatus <| toString status.id ] Err error -> { model | currentView = preferredTimeline model , errors = (errorText error) :: model.errors } ! [] CurrentUser result -> case result of Ok { decoded } -> { model | currentUser = Just decoded } ! [] Err error -> { model | errors = (errorText error) :: model.errors } ! [] FavoriteAdded result -> case result of Ok _ -> model ! [] Err error -> { model | errors = (errorText error) :: model.errors } ! [] FavoriteRemoved result -> case result of Ok _ -> model ! [] Err error -> { model | errors = (errorText error) :: model.errors } ! [] LocalTimeline append result -> case result of Ok { decoded, links } -> { model | localTimeline = updateTimeline append decoded links model.localTimeline } ! [] Err error -> { model | errors = (errorText error) :: model.errors } ! [] Notifications append result -> case result of Ok { decoded, links } -> let aggregated = Mastodon.Helper.aggregateNotifications decoded in { model | notifications = updateTimeline append aggregated links model.notifications } ! [] Err error -> { model | errors = (errorText error) :: model.errors } ! [] GlobalTimeline append result -> case result of Ok { decoded, links } -> { model | globalTimeline = updateTimeline append decoded links model.globalTimeline } ! [] Err error -> { model | errors = (errorText error) :: model.errors } ! [] Reblogged result -> case result of Ok _ -> model ! [] Err error -> { model | errors = (errorText error) :: model.errors } ! [] StatusPosted _ -> { model | draft = defaultDraft } ! [ Command.scrollColumnToTop "home-timeline" , Command.updateDomStatus defaultDraft.status ] StatusDeleted result -> case result of Ok { decoded } -> deleteStatusFromAllTimelines decoded model ! [] Err error -> { model | errors = (errorText error) :: model.errors } ! [] Unreblogged result -> case result of Ok _ -> model ! [] Err error -> { model | errors = (errorText error) :: model.errors } ! [] AccountReceived result -> case result of Ok { decoded } -> { model | currentView = AccountView decoded } ! [ Command.loadAccountTimeline model.client decoded.id model.accountTimeline.links.next ] Err error -> { model | currentView = preferredTimeline model , errors = (errorText error) :: model.errors } ! [] AccountTimeline append result -> case result of Ok { decoded, links } -> { model | accountTimeline = updateTimeline append decoded links model.accountTimeline } ! [] Err error -> { model | errors = (errorText error) :: model.errors } ! [] AccountFollowers result -> case result of Ok { decoded } -> -- TODO: store next link { model | accountFollowers = decoded } ! [ Command.loadRelationships model.client <| List.map .id decoded ] Err error -> { model | errors = (errorText (Debug.log "error" error)) :: model.errors } ! [] AccountFollowing result -> case result of Ok { decoded } -> -- TODO: store next link { model | accountFollowing = decoded } ! [ Command.loadRelationships model.client <| List.map .id decoded ] Err error -> { model | errors = (errorText error) :: model.errors } ! [] AccountRelationship result -> case result of Ok { decoded } -> case decoded of [ relationship ] -> { model | accountRelationship = Just relationship } ! [] _ -> model ! [] Err error -> { model | errors = (errorText error) :: model.errors } ! [] AccountRelationships result -> case result of Ok { decoded } -> -- TODO: store next link { model | accountRelationships = decoded } ! [] Err error -> { model | errors = (errorText error) :: model.errors } ! [] HomeTimeline append result -> case result of Ok { decoded, links } -> { model | homeTimeline = updateTimeline append decoded links model.homeTimeline } ! [] Err error -> { model | errors = (errorText error) :: model.errors } ! [] AutoSearch result -> let draft = model.draft in case result of Ok { decoded } -> { model | draft = { draft | showAutoMenu = showAutoMenu decoded draft.autoAtPosition draft.autoQuery , autoAccounts = decoded } } -- Force selection of the first item after each -- Successfull request ! [ Task.perform identity (Task.succeed ((DraftEvent << ResetAutocomplete) True)) ] Err error -> { model | draft = { draft | showAutoMenu = False } , errors = (errorText error) :: model.errors } ! [] showAutoMenu : List Account -> Maybe Int -> String -> Bool showAutoMenu accounts atPosition query = case ( List.isEmpty accounts, atPosition, query ) of ( _, Nothing, _ ) -> False ( True, _, _ ) -> False ( _, _, "" ) -> False ( False, Just _, _ ) -> True 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 | homeTimeline = prependToTimeline status model.homeTimeline } ! [] Err error -> { model | errors = error :: model.errors } ! [] Mastodon.WebSocket.StatusDeleteEvent result -> case result of Ok id -> deleteStatusFromAllTimelines id model ! [] Err error -> { model | errors = error :: model.errors } ! [] Mastodon.WebSocket.NotificationEvent result -> case result of Ok notification -> let oldNotifications = model.notifications newNotifications = { oldNotifications | entries = Mastodon.Helper.addNotificationToAggregates notification oldNotifications.entries } in { model | notifications = newNotifications } ! [] 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 = prependToTimeline status model.localTimeline } ! [] Err error -> { model | errors = error :: model.errors } ! [] Mastodon.WebSocket.StatusDeleteEvent result -> case result of Ok id -> deleteStatusFromAllTimelines id model ! [] 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 = prependToTimeline status model.globalTimeline } ! [] Err error -> { model | errors = error :: model.errors } ! [] Mastodon.WebSocket.StatusDeleteEvent result -> case result of Ok id -> deleteStatusFromAllTimelines id model ! [] Err error -> { model | errors = error :: model.errors } ! [] _ -> model ! [] update : Msg -> Model -> ( Model, Cmd Msg ) update msg model = case msg of NoOp -> model ! [] ClearError index -> { model | errors = removeAt index model.errors } ! [] 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 ! [ Command.registerApp model ] OpenThread status -> model ! [ Command.loadThread model.client status ] CloseThread -> { model | currentView = preferredTimeline model } ! [] FollowAccount id -> model ! [ Command.follow model.client id ] UnfollowAccount id -> model ! [ Command.unfollow model.client id ] DeleteStatus id -> model ! [ Command.deleteStatus model.client id ] ReblogStatus id -> processReblog id True model ! [ Command.reblogStatus model.client id ] UnreblogStatus id -> processReblog id False model ! [ Command.unreblogStatus model.client id ] AddFavorite id -> processFavourite id True model ! [ Command.favouriteStatus model.client id ] RemoveFavorite id -> processFavourite id False model ! [ Command.unfavouriteStatus model.client id ] DraftEvent draftMsg -> case model.currentUser of Just user -> updateDraft draftMsg user model Nothing -> model ! [] ViewerEvent viewerMsg -> let ( viewer, commands ) = updateViewer viewerMsg model.viewer in { model | viewer = viewer } ! [ commands ] SubmitDraft -> model ! [ Command.postStatus model.client <| toStatusRequestBody model.draft ] LoadAccount accountId -> { model | accountTimeline = emptyTimeline "account-timeline" , accountFollowers = [] , accountFollowing = [] , accountRelationships = [] , accountRelationship = Nothing } ! [ Command.loadAccount model.client accountId ] TimelineLoadNext id next -> model ! [ Command.loadNextTimeline model.client model.currentView id next ] ViewAccountFollowers account -> { model | currentView = AccountFollowersView account model.accountFollowers } ! [ Command.loadAccountFollowers model.client account.id ] ViewAccountFollowing account -> { model | currentView = AccountFollowingView account model.accountFollowing } ! [ Command.loadAccountFollowing model.client account.id ] ViewAccountStatuses account -> { model | currentView = AccountView account } ! [] UseGlobalTimeline flag -> let newModel = { model | useGlobalTimeline = flag } in { newModel | currentView = preferredTimeline newModel } ! [] CloseAccount -> { model | currentView = preferredTimeline model , accountTimeline = emptyTimeline "account-timeline" , accountFollowing = [] , accountFollowers = [] } ! [] FilterNotifications filter -> { model | notificationFilter = filter } ! [] ScrollColumn ScrollTop column -> model ! [ Command.scrollColumnToTop column ] ScrollColumn ScrollBottom column -> model ! [ Command.scrollColumnToBottom column ] updateAutocompleteConfig : Autocomplete.UpdateConfig Msg Account updateAutocompleteConfig = Autocomplete.updateConfig { toId = .id >> toString , onKeyDown = \code maybeId -> if code == 38 || code == 40 then Nothing else if code == 13 then Maybe.map (DraftEvent << SelectAccount) maybeId else Just <| (DraftEvent << ResetAutocomplete) False , onTooLow = Just <| (DraftEvent << ResetAutocomplete) True , onTooHigh = Just <| (DraftEvent << ResetAutocomplete) False , onMouseEnter = \_ -> Nothing , onMouseLeave = \_ -> Nothing , onMouseClick = \id -> Just <| (DraftEvent << SelectAccount) id , separateSelections = False } acceptableAccounts : String -> List Account -> List Account acceptableAccounts query accounts = let lowerQuery = String.toLower query in if query == "" then [] else List.filter (String.contains lowerQuery << String.toLower << .username) accounts subscriptions : Model -> Sub Msg subscriptions model = case model.client of Just client -> let subs = [ Mastodon.WebSocket.subscribeToWebSockets client Mastodon.WebSocket.UserStream NewWebsocketUserMessage ] ++ (if model.currentView == GlobalTimelineView then [ Mastodon.WebSocket.subscribeToWebSockets client Mastodon.WebSocket.GlobalPublicStream NewWebsocketGlobalMessage ] else if model.currentView == LocalTimelineView then [ Mastodon.WebSocket.subscribeToWebSockets client Mastodon.WebSocket.LocalPublicStream NewWebsocketLocalMessage ] else [] ) in Sub.batch <| (List.map (Sub.map WebSocketEvent) subs) ++ [ Sub.map (DraftEvent << SetAutoState) Autocomplete.subscription ] Nothing -> Sub.batch []