Paper planes flying by

Author: easafe

src/Client/Experiments/Update.purs

@@ -29,7 +29,6 @@ update ∷ Update ExperimentsModel ExperimentsMessage
 update model =
       case _ of
             ToggleVisibility modal → model { visible = modal == ShowExperiments } /\ []
-            ToggleSection section → F.noMessages model { section = section }
             RedirectKarma → model /\
                   [ do
                           liftEffect <<< FS.send imAppId <<< SIT.SpecialRequest <<< ToggleModal $ Screen ShowKarmaPrivileges
@@ -41,6 +40,7 @@ update model =
             DisplayQuestions questions → displayQuestions questions model
             SelectChoice question choice → selectChoice question choice model
             AnswerQuestion → answerQuestion model
+            ToggleDoppelgangerSection section → F.noMessages model { doppelganger = model.doppelganger { section = section } }
             AfterAnswerQuestion → afterAnswerQuestion model
             FetchMatches → fetchMatches model
             DisplayMatches matches → displayMatches matches model
@@ -50,6 +50,21 @@ update model =
             ThrowPlane → throwPlane model
             AfterThrowPlane id → afterThrowPlane id model
             ResizeMessageInput event → SIR.resizeInputFrom event model
+            TogglePaperPlaneSection section → togglePaperPlaneSection section model
+            DisplayFlyingPaperPlanes planes -> displayFlyingPaperPlanes planes model
+
+displayFlyingPaperPlanes ∷ Array PaperPlane → ExperimentsModel → ExperimentsModel /\ (Array (Aff (Maybe ExperimentsMessage)))
+displayFlyingPaperPlanes planes model = model { paperPlane = model.paperPlane { flyingBy = planes } } /\ []
+
+togglePaperPlaneSection ∷ PaperPlaneSection → ExperimentsModel → ExperimentsModel /\ (Array (Aff (Maybe ExperimentsMessage)))
+togglePaperPlaneSection section model = model { paperPlane = model.paperPlane { section = section } } /\ effects
+      where
+      fetch = do
+            r ← CCN.silentResponse $ request.experiments.flying {  }
+            pure <<< Just $ DisplayFlyingPaperPlanes r
+      effects
+            | model.paperPlane.section /= section && section == ShowFlyingBy && DA.null model.paperPlane.flyingBy = [fetch]
+            | otherwise = []
 
 setPlaneMessage ∷ String → ExperimentsModel → ExperimentsModel /\ (Array (Aff (Maybe ExperimentsMessage)))
 setPlaneMessage message model = model { paperPlane = model.paperPlane { message = if DS.null message then Nothing else Just message } } /\ []
@@ -79,7 +94,7 @@ resumeQuestions model = model /\ [ resume ]
             pure <<< Just $ DisplayQuestions questions
 
 displayQuestions ∷ Array Question → ExperimentsModel → ExperimentsModel /\ (Array (Aff (Maybe ExperimentsMessage)))
-displayQuestions questions model = model { section = ShowingDoppelganger ShowNextQuestion, doppelganger { questions = questions } } /\ []
+displayQuestions questions model = model { doppelganger { section = ShowNextQuestion, questions = questions } } /\ []
 
 selectChoice ∷ Int → Int → ExperimentsModel → ExperimentsModel /\ (Array (Aff (Maybe ExperimentsMessage)))
 selectChoice question choice model = model { doppelganger = model.doppelganger { selectedChoice = Just { question, choice } } } /\ []
@@ -124,7 +139,7 @@ fetchMatches model = model /\ [ fetch ]
             pure <<< Just $ DisplayMatches response
 
 displayMatches ∷ Array Match → ExperimentsModel → ExperimentsModel /\ (Array (Aff (Maybe ExperimentsMessage)))
-displayMatches matches model = model { section = ShowingDoppelganger ShowMatches, doppelganger = model.doppelganger { matches = matches } } /\ []
+displayMatches matches model = model { doppelganger = model.doppelganger { section = ShowMatches, matches = matches } } /\ []
 
 messageDoppelganger ∷ Int → ExperimentsModel → ExperimentsModel /\ (Array (Aff (Maybe ExperimentsMessage)))
 messageDoppelganger userId model = model /\ [ send ]

src/Client/css/experiments.css

@@ -41,6 +41,12 @@
     align-self: flex-end;
 }
 
+.flying-by {
+    display: flex;
+    flex-direction: column;
+    width: 534px;
+}
+
 .word-chain {
     margin: 23px 25px;
 }
@@ -89,6 +95,11 @@
     margin-bottom: 40px;
 }
 
+.paper-flown-message {
+    word-wrap: break-word;
+    overflow: auto;
+}
+
 @media (max-width:1279px) {
     #chat-experiments {
         width: 100%;
@@ -111,7 +122,7 @@
         width: auto;
     }
 
-    .paper-thrown-entry {
+    .paper-thrown-entry, .flying-by {
         width: calc(100vw - 47px);
     }
 }

src/Server/Database/PaperPlanes.purs

@@ -13,7 +13,7 @@ type PaperPlanes =
       , thrower ∷ Int
       , message ∷ String
       , created ∷ Column DateTime Default
-      , caughtByAt :: Maybe DateTime
+      , by_at :: Maybe DateTime
       , by :: Maybe Int
       , status ∷ PlaperPlaneStatus
       )
@@ -30,5 +30,5 @@ _message = Proxy
 _by ∷ Proxy "by"
 _by = Proxy
 
-_caughtByAt ∷ Proxy "caught_by_at"
-_caughtByAt = Proxy
+_byAt ∷ Proxy "by_at"
+_byAt = Proxy

src/Server/Experiments/Action.purs

@@ -10,7 +10,7 @@ import Debug (spy)
 import Run.Except as RE
 import Server.Effect (ServerEffect)
 import Server.Experiments.Database as SED
-import Shared.Experiments.Types (Question, Match)
+import Shared.Experiments.Types (Match, Question, PaperPlane)
 import Shared.Options.Doppelganger (changelogEntry, totalQuestions)
 import Shared.Options.PaperPlane (maxPaperPlanes)
 import Shared.ResponseError (ResponseError(..))
@@ -21,7 +21,8 @@ experiments loggedUserId = do
       user ← SED.fetchExperimentUser loggedUserId
       count ← SED.fetchAnswerCount loggedUserId
       thrown ← SED.fetchPaperPlanes loggedUserId
-      pure { experiments: list, user, completedDoppelganger: count == totalQuestions, thrown }
+      flyingBy ← SED.fetchPaperPlanesFlying loggedUserId
+      pure { experiments: list, user, completedDoppelganger: count == totalQuestions, thrown, flyingBy }
 
 buildQuestions ∷ Int → ServerEffect (Array Question)
 buildQuestions loggedUserId = do
@@ -42,8 +43,11 @@ fetchMatches loggedUserId = do
 saveAnswer ∷ Int → Int → ServerEffect Unit
 saveAnswer loggedUserId choice = SED.saveAnswer loggedUserId choice
 
-throwPlane ∷ Int → String → ServerEffect {id :: Int }
+throwPlane ∷ Int → String → ServerEffect { id ∷ Int }
 throwPlane loggedUserId message = do
-      c <- SED.countPaperPlanes loggedUserId
-      when (c == Just (BI.fromInt maxPaperPlanes)) <<< RE.throw $ BadRequest { reason: "too many planes"}
-      SED.savePlane loggedUserId message
+      c ← SED.countPaperPlanes loggedUserId
+      when (c == Just (BI.fromInt maxPaperPlanes)) <<< RE.throw $ BadRequest { reason: "too many planes" }
+      SED.savePlane loggedUserId message
+
+flyingPlanes ∷ Int → ServerEffect (Array PaperPlane)
+flyingPlanes loggedUserId = SED.fetchPaperPlanesFlying loggedUserId

src/Server/Experiments/Database.purs

@@ -19,7 +19,7 @@ import Server.Database.DoppelgangerChoices (_asked, _choice, doppelganger_choice
 import Server.Database.DoppelgangerQuestions (_question, doppelganger_questions)
 import Server.Database.LastSeen (_who)
 import Server.Database.Messages (_status)
-import Server.Database.PaperPlanes (_message, _thrower, paper_planes)
+import Server.Database.PaperPlanes (_by, _byAt, _message, _thrower, paper_planes)
 import Server.Database.Recoveries (_created)
 import Server.Effect (ServerEffect)
 import Server.Experiments.Database.Flat (FlatQuestion)
@@ -74,6 +74,9 @@ countPaperPlanes loggedUserId = do
 fetchPaperPlanes ∷ Int → ServerEffect (Array PaperPlane)
 fetchPaperPlanes loggedUserId = SD.query $ select (_id /\ _message /\ _status) # from paper_planes # wher (_thrower .=. loggedUserId .&&. _status .<>. Crashed) # orderBy _created
 
+fetchPaperPlanesFlying ∷ Int → ServerEffect (Array PaperPlane)
+fetchPaperPlanesFlying loggedUserId = SD.query $ select (_id /\ _message /\ _status) # from paper_planes # wher (_by .=. loggedUserId) # orderBy _byAt
+
 q ∷ Proxy "q"
 q = Proxy
 

src/Server/Experiments/Handler.purs

@@ -7,7 +7,7 @@ import Payload.ResponseTypes (Empty(..))
 import Run as R
 import Server.Experiments.Action as SEA
 import Server.Experiments.Template as SET
-import Shared.Experiments.Types (Question, Match)
+import Shared.Experiments.Types (Match, Question, PaperPlane)
 import Shared.Html (Html(..))
 
 experiments ∷ { guards ∷ { loggedUserId ∷ Int } } → ServerEffect Html
@@ -29,3 +29,6 @@ answer request = do
 throw ∷ { guards ∷ { loggedUserId ∷ Int }, body ∷ { message ∷ String } } → ServerEffect {id :: Int}
 throw request = SEA.throwPlane request.guards.loggedUserId request.body.message
 
+flying ∷ { guards ∷ { loggedUserId ∷ Int } } → ServerEffect (Array PaperPlane)
+flying request = SEA.flyingPlanes request.guards.loggedUserId
+

src/Server/Experiments/Template.purs

@@ -17,18 +17,20 @@ template payload = Html <$> F.preMount (QuerySelector "#chat-experiments")
               { experiments: payload.experiments
               , visible: true
               , user: payload.user
-              , section: HideExperiments
               , doppelganger:
                       { questions: []
                       , matches: []
                       , completed: payload.completedDoppelganger
                       , loading: false
+                      , section: ShowDoppelganger
                       , selectedChoice: Nothing
                       }
               , paperPlane:
                       { loading: false
+                      , section: ShowNew
                       , message: Nothing
                       , thrown: payload.thrown
+                      , flyingBy : payload.flyingBy
                       }
               }
       }

src/Server/Handler.purs

@@ -120,6 +120,7 @@ handlers reading =
               , matches: runJson reading SEH.matches
               , answer: runJson reading SEH.answer
               , throw: runJson reading SEH.throw
+              , flying: runJson reading SEH.flying
               }
       , sw
       , developmentFiles

src/Server/sql/index.sql

@@ -204,18 +204,33 @@ language plpgsql;
 create or replace function handle_paper_planes()
     returns void as
 $$
+begin
+    with updated as (update paper_planes p
+        set by_at = utc_now(), thrown = p.thrown + 1, by = (
+            select u.id
+            from users u join last_seen l on u.id = l.who join karma_leaderboard k on u.id = k.ranker
+            where p.thrower <> u.id and
+                (p.by is null or u.id <> p.by) and
+                not temporary and
+                (extract(epoch from (utc_now()) - l.date) / 3600 <= (24 * 7)) and
+                k.current_karma >= 80 and
+                ((select count(1) from paper_planes where by = u.id and status = 1) < 7)
+            order by random() limit 1)
+        where status = 1 and thrown < 7 and (by is null or extract(epoch from (utc_now()) - by_at) / 3600 > (24 * 7))
+        returning  by, 'There are planes flying by. Catch?', 2)
+    insert into changelogs(changed, description, action) select * from updated;
+end;
+$$
+language plpgsql;
+
+-- select cron.schedule('0 0 * * *', $$select handle_paper_planes()$$);
+create or replace function crash_paper_planes()
+    returns void as
+$$
 begin
     update paper_planes p
-    set by_at = utc_now(), by = (
-        select u.id
-        from users u join last_seen l on u.id = l.who join karma_leaderboard k on u.id = k.ranker
-        where (p.by is null or u.id <> p.by) and
-              not temporary and
-              (extract(epoch from (utc_now()) - l.date) / 3600 <= (24 * 7)) and
-              k.current_karma >= 80 and
-              ((select count(1) from paper_planes where by = u.id and status <> 1) < 7)
-        order by random() limit 1)
-    where status = 1 and (by is null or extract(epoch from (utc_now()) - by_at) / 3600 > (24 * 7));
+    set by_at = utc_now(), by = null, status = 3
+    where status = 1 and thrown >= 7;
 end;
 $$
 language plpgsql;
@@ -411,7 +426,7 @@ create table paper_planes(
     status smallint not null,
     by integer,
     by_at timestamptz,
-    thrown smallint default 0,
+    thrown smallint default ,
 
     constraint thrower_user foreign key (thrower) references users(id) on delete cascade
 );

src/Shared/Experiments/Doppelganger.purs

@@ -9,15 +9,15 @@ import Data.Maybe as DM
 import Flame (Html)
 import Flame.Html.Attribute as HA
 import Flame.Html.Element as HE
-import Shared.Experiments.Types (DoppelgangerSection(..), ExperimentsMessage(..), ExperimentsModel, ShowingExperiment(..))
+import Shared.Experiments.Types (DoppelgangerSection(..), ExperimentsMessage(..), ExperimentsModel)
 import Shared.Unsafe as SU
 import Web.HTML.HTMLInputElement as WHHI
 
 view ∷ ExperimentsModel → Html ExperimentsMessage
 view model = HE.div [ HA.class' "word-chain duller" ]
-      [ case model.section of
-              ShowingDoppelganger ShowNextQuestion → showNextQuestion
-              ShowingDoppelganger ShowMatches → showMatches
+      [ case model.doppelganger.section of
+              ShowNextQuestion → showNextQuestion
+              ShowMatches → showMatches
               _ →
                     if model.doppelganger.completed then
                           HE.input [ HA.type' "button", HA.onClick FetchMatches, HA.class' "green-button", HA.value "Check results" ]