Types for in suggestion calls

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
-      --       ]
+-- where
+-- dispatchEvent payload =
+--       [ liftEffect do
+--               --refactor: if experiments depends on im on webpack this can be safe
+--               FSUC.broadcast setChatExperiment payload
+--               pure Nothing
+--       ]

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

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
       }

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: []

src/Shared/Experiments/Impersonation.purs

@@ -63,35 +63,34 @@ 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
             , HE.span (HA.class' "header-plus") if model.section == s then "-" else "+"
             ]
 
       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 ]
                     ]

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
+      Impersonation ip → SEI.view model
+      WordChain → SEW.view model

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 _

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

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