From a035c3ba502b763a797aba566e28c2d2015f4e14 Mon Sep 17 00:00:00 2001 From: Eduardo Asafe Date: Sun, 5 Jan 2025 17:07:13 -0300 Subject: [PATCH] Types for in suggestion calls --- src/Client/Experiments/Update.purs | 18 ++++++------ src/Client/Im/Main.purs | 1 + src/Client/Im/Suggestion.purs | 35 ++++++++++++++++------- src/Server/Im/Template.purs | 1 + src/Shared/Experiments/Impersonation.purs | 35 +++++++++++------------ src/Shared/Experiments/View.purs | 8 +++--- src/Shared/Im/Types.purs | 11 +++++++ src/Shared/Im/View/SuggestionProfile.purs | 25 +++++++--------- test/Client/Model.purs | 3 +- 9 files changed, 80 insertions(+), 57 deletions(-) diff --git a/src/Client/Experiments/Update.purs b/src/Client/Experiments/Update.purs index f68106b3..ae395524 100644 --- a/src/Client/Experiments/Update.purs +++ b/src/Client/Experiments/Update.purs @@ -25,8 +25,8 @@ update model = ] JoinExperiment code → F.noMessages model - -- { current = Just code - -- } /\ dispatchEvent (Just code) + -- { current = Just code + -- } /\ dispatchEvent (Just code) ToggleSection section → F.noMessages $ model { section = section } ConfirmExperiment experiment → F.noMessages model { confirming = experiment } RedirectKarma → model /\ @@ -35,10 +35,10 @@ update model = pure Nothing ] UpdatePrivileges { privileges } → F.noMessages model { user { privileges = privileges } } - -- where - -- dispatchEvent payload = - -- [ liftEffect do - -- --refactor: if experiments depends on im on webpack this can be safe - -- FSUC.broadcast setChatExperiment payload - -- pure Nothing - -- ] \ No newline at end of file +-- where +-- dispatchEvent payload = +-- [ liftEffect do +-- --refactor: if experiments depends on im on webpack this can be safe +-- FSUC.broadcast setChatExperiment payload +-- pure Nothing +-- ] \ No newline at end of file diff --git a/src/Client/Im/Main.purs b/src/Client/Im/Main.purs index a6b91e69..8fd1d0a0 100644 --- a/src/Client/Im/Main.purs +++ b/src/Client/Im/Main.purs @@ -171,6 +171,7 @@ update st model = SpecialRequest (BlockUser id) → CIS.blockUser webSocket id model DisplayMoreSuggestions suggestions → CIS.displayMoreSuggestions suggestions model ToggleSuggestionsFromOnline → CIS.toggleSuggestionsFromOnline model + SetBugging mc → CIS.setBugging mc model --user menu ToggleInitialScreen toggle → CIU.toggleInitialScreen toggle model Logout after → CIU.logout after model diff --git a/src/Client/Im/Suggestion.purs b/src/Client/Im/Suggestion.purs index 082c1784..6bd100db 100644 --- a/src/Client/Im/Suggestion.purs +++ b/src/Client/Im/Suggestion.purs @@ -19,23 +19,31 @@ import Data.Tuple as DT import Data.Tuple.Nested ((/\)) import Debug (spy) import Effect.Class (liftEffect) +import Effect.Random as ER import Flame as F import Shared.Options.Page (suggestionsPerPage) import Web.Socket.WebSocket (WebSocket) nextSuggestion ∷ ImModel → MoreMessages -nextSuggestion model@{ suggestions, suggesting } = - let - next = DM.maybe 0 (_ + 1) suggesting - in - if next >= DA.length suggestions then - fetchMoreSuggestions model +nextSuggestion model = + if next >= DA.length model.suggestions then + fetchMoreSuggestions model + else + model + { freeToFetchSuggestions = true + , suggesting = Just next + , chatting = Nothing + } /\ [ bugUser ] + where + next = DM.maybe 0 (_ + 1) model.suggesting + bugUser = do + chance ← liftEffect $ ER.randomInt 0 100 + if chance <= 2 then + pure <<< Just $ SetBugging Experimenting + else if chance <= 5 then + pure <<< Just $ SetBugging Backing else - F.noMessages $ model - { freeToFetchSuggestions = true - , suggesting = Just next - , chatting = Nothing - } + pure Nothing previousSuggestion ∷ ImModel → MoreMessages previousSuggestion model@{ suggesting } = @@ -135,4 +143,9 @@ toggleSuggestionsFromOnline ∷ ImModel → MoreMessages toggleSuggestionsFromOnline model = fetchMoreSuggestions model { suggestionsFrom = if model.suggestionsFrom == OnlineOnly then ThisWeek else OnlineOnly , suggestionsPage = 0 + } + +setBugging ∷ MeroChatCall → ImModel → NoMessages +setBugging mc model = F.noMessages $ model + { bugging = Just mc } \ No newline at end of file diff --git a/src/Server/Im/Template.purs b/src/Server/Im/Template.purs index a2ca3bd6..e68e2734 100644 --- a/src/Server/Im/Template.purs +++ b/src/Server/Im/Template.purs @@ -57,6 +57,7 @@ template payload = do , link: Nothing , linkText: Nothing , selectedImage: Nothing + , bugging: Nothing , fullContactProfileVisible: false , freeToFetchContactList: true , erroredFields: [] diff --git a/src/Shared/Experiments/Impersonation.purs b/src/Shared/Experiments/Impersonation.purs index ff710c38..c3912049 100644 --- a/src/Shared/Experiments/Impersonation.purs +++ b/src/Shared/Experiments/Impersonation.purs @@ -63,27 +63,26 @@ view model = HE.div (HA.class' "impersonation") , profiles Celebrities [ nicolasCage ] , HE.div (HA.class' { "modal-placeholder-overlay": true, hidden: DM.isNothing impersonation }) [ HE.div (HA.class' "confirmation") - if SPV.hasPrivilege ImpersonationChatExperiment model.user then - [ {- HE.span (HA.class' "bold") $ "Start Impersonation Experiment as " <> DM.maybe "" _.name impersonation <> "?" - , HE.div (HA.class' "buttons") - [ HE.button [ HA.class' "cancel" , HA.onClick $ ConfirmImpersonation Nothing ] "Cancel" - , HE.button [ HA.class' "green-button" , HA.onClick <<< JoinExperiment $ Impersonation impersonation ] "Start" - ] -} - HE.text "Impesonation experiment is currently unavailable" - , HE.div (HA.class' "buttons") - $ HE.button [ HA.class' "green-button", HA.onClick $ ConfirmExperiment Nothing] "Dismiss" - ] - else - [ CCP.notEnoughKarma "start this chat experiment" RedirectKarma - , HE.div (HA.class' "buttons") - $ HE.button [ HA.class' "green-button", HA.onClick $ ConfirmExperiment Nothing] "Dismiss" - ] + if SPV.hasPrivilege ImpersonationChatExperiment model.user then + [ {- HE.span (HA.class' "bold") $ "Start Impersonation Experiment as " <> DM.maybe "" _.name impersonation <> "?" + , HE.div (HA.class' "buttons") + [ HE.button [ HA.class' "cancel" , HA.onClick $ ConfirmImpersonation Nothing ] "Cancel" + , HE.button [ HA.class' "green-button" , HA.onClick <<< JoinExperiment $ Impersonation impersonation ] "Start" + ] -} HE.text "Impesonation experiment is currently unavailable" + , HE.div (HA.class' "buttons") + $ HE.button [ HA.class' "green-button", HA.onClick $ ConfirmExperiment Nothing ] "Dismiss" + ] + else + [ CCP.notEnoughKarma "start this chat experiment" RedirectKarma + , HE.div (HA.class' "buttons") + $ HE.button [ HA.class' "green-button", HA.onClick $ ConfirmExperiment Nothing ] "Dismiss" + ] ] ] where impersonation = case model.confirming of - Just (Impersonation ip) -> ip - _ -> Nothing + Just (Impersonation ip) → ip + _ → Nothing header s name = HE.div [ HA.class' "impersonation-header", HA.onClick $ ToggleSection s ] [ HE.text name @@ -91,7 +90,7 @@ view model = HE.div (HA.class' "impersonation") ] profiles s = HE.div (HA.class' { hidden: model.section /= s }) <<< DA.mapWithIndex toProfile - toProfile index p = HE.div [ HA.class' "contact" , HA.onClick <<< ConfirmExperiment <<< Just <<< Impersonation $ Just p] + toProfile index p = HE.div [ HA.class' "contact", HA.onClick <<< ConfirmExperiment <<< Just <<< Impersonation $ Just p ] [ HE.div (HA.class' "avatar-contact-list-div") [ HE.img [ HA.title $ SU.fromJust p.avatar, HA.class' $ "avatar-contact-list" <> SA.avatarColorClass (Just index), HA.src $ SU.fromJust p.avatar ] ] diff --git a/src/Shared/Experiments/View.purs b/src/Shared/Experiments/View.purs index c3c205e6..fe640a4d 100644 --- a/src/Shared/Experiments/View.purs +++ b/src/Shared/Experiments/View.purs @@ -22,10 +22,10 @@ view model = HE.div (HA.class' "chat-experiments") $ case model.current of [ HE.label (HA.class' "bold") experiment.name , HE.div (HA.class' "duller experiment-description") experiment.description ] - , HE.fragment $ extra model experiment.code + , HE.fragment $ extra model experiment.code ] -extra :: ChatExperimentModel → Experiment -> Html ChatExperimentMessage +extra ∷ ChatExperimentModel → Experiment → Html ChatExperimentMessage extra model = case _ of - Impersonation ip -> SEI.view model - WordChain -> SEW.view model \ No newline at end of file + Impersonation ip → SEI.view model + WordChain → SEW.view model \ No newline at end of file diff --git a/src/Shared/Im/Types.purs b/src/Shared/Im/Types.purs index bfa79dd7..dcaafec0 100644 --- a/src/Shared/Im/Types.purs +++ b/src/Shared/Im/Types.purs @@ -143,6 +143,7 @@ type Im = , suggesting ∷ Maybe Int , chatting ∷ Maybe Int , smallScreen ∷ Boolean + , bugging ∷ Maybe MeroChatCall --used to signal that the page should be reloaded , hash ∷ String --visibility switches @@ -158,6 +159,8 @@ type Im = type ImModel = Record Im +data MeroChatCall = Backing | Experimenting + newtype TimeoutIdWrapper = TimeoutIdWrapper TimeoutId data AfterLogout @@ -283,6 +286,7 @@ data ImMessage | ResumeSuggesting | DisplayMoreSuggestions (Array Suggestion) | ToggleSuggestionsFromOnline + | SetBugging MeroChatCall --chat | SetSelectedImage (Maybe String) @@ -527,6 +531,9 @@ instance Enum MessageStatus where instance DecodeJson TimeoutIdWrapper where decodeJson = Right <<< UC.unsafeCoerce +instance DecodeJson MeroChatCall where + decodeJson = DADGR.genericDecodeJson + instance DecodeJson SuggestionsFrom where decodeJson = DADGR.genericDecodeJson @@ -569,6 +576,9 @@ instance EncodeJson TimeoutIdWrapper where instance EncodeJson SuggestionsFrom where encodeJson = DAEGR.genericEncodeJson +instance EncodeJson MeroChatCall where + encodeJson = DAEGR.genericEncodeJson + instance EncodeJson AfterLogout where encodeJson = DAEGR.genericEncodeJson @@ -660,6 +670,7 @@ derive instance Generic AfterLogout _ derive instance Generic ReportReason _ derive instance Generic MessageContent _ derive instance Generic MessageError _ +derive instance Generic MeroChatCall _ derive instance Generic WebSocketPayloadClient _ derive instance Generic FullWebSocketPayloadClient _ derive instance Generic WebSocketPayloadServer _ diff --git a/src/Shared/Im/View/SuggestionProfile.purs b/src/Shared/Im/View/SuggestionProfile.purs index 173e33d9..5e477781 100644 --- a/src/Shared/Im/View/SuggestionProfile.purs +++ b/src/Shared/Im/View/SuggestionProfile.purs @@ -11,13 +11,10 @@ import Client.Common.Privilege as CCP import Data.Array ((!!), (..), (:)) import Data.Array as DA import Data.Either (Either(..)) -import Data.HashMap as HS import Data.Int as DI import Data.Maybe (Maybe(..)) import Data.Maybe as DM import Data.Time.Duration (Days(..)) -import Data.Tuple (Tuple(..)) -import Data.Tuple as DT import Flame (Html) import Flame.Html.Attribute as HA import Flame.Html.Element (class ToNode) @@ -44,36 +41,36 @@ import Shared.User as SUR -- | Displays either the current chat or a list of chat suggestions suggestionProfile ∷ ImModel → Html ImMessage -suggestionProfile model@{ suggestions, contacts, suggesting, chatting, fullContactProfileVisible, user } = - if (user.profileVisibility > NoTemporaryUsers || not (SP.hasPrivilege StartChats user)) && notChatting then +suggestionProfile model = + if (model.user.profileVisibility > NoTemporaryUsers || not (SP.hasPrivilege StartChats model.user)) && notChatting then suggestionWarning - else if DA.null suggestions && notChatting then + else if DA.null model.suggestions && notChatting then emptySuggestions else - case chatting, suggesting of + case model.chatting, model.suggesting of i@(Just index), _ → let - contact@{ user: { name, availability } } = contacts !@ index + contact = model.contacts !@ index in - if availability == Unavailable then - unavailable name - else if fullContactProfileVisible then + if contact.user.availability == Unavailable then + unavailable contact.user.name + else if model.fullContactProfileVisible then fullProfile FullContactProfile i model contact.user else compactProfile model contact Nothing, (Just index) → suggestionCards model index _, _ → emptySuggestions where - notChatting = DM.isNothing chatting + notChatting = DM.isNothing model.chatting - emptySuggestions = HE.div (HA.class' { "suggestion empty retry": true, hidden: DM.isJust chatting }) + emptySuggestions = HE.div (HA.class' { "suggestion empty retry": true, hidden: DM.isJust model.chatting }) ( if model.suggestionsFrom == OnlineOnly then onlineOnlyFilter model : (SIVR.retryForm "No users currently online :(" $ SpecialRequest NextSuggestion) else SIVR.retryForm "Could not find suggestions" $ SpecialRequest NextSuggestion ) - suggestionWarning = HE.div (HA.class' { "suggestion": true, hidden: DM.isJust chatting }) $ welcome model + suggestionWarning = HE.div (HA.class' { "suggestion": true, hidden: DM.isJust model.chatting }) $ welcome model -- | Contact was deleted, made private or they blocked the logged user unavailable ∷ String → Html ImMessage diff --git a/test/Client/Model.purs b/test/Client/Model.purs index 6d4143e8..517995b9 100644 --- a/test/Client/Model.purs +++ b/test/Client/Model.purs @@ -30,8 +30,9 @@ model = , freeToFetchSuggestions: true , typingIds: [] , initialScreen: true - , suggestionsFrom : ThisWeek + , suggestionsFrom: ThisWeek , temporaryEmail: Nothing + , bugging: Nothing , temporaryPassword: Nothing , suggestionsPage: 0 , lastTyping: DateTimeWrapper $ EU.unsafePerformEffect EN.nowDateTime