From 97800303438a361a73bb6573b506490af29940d0 Mon Sep 17 00:00:00 2001
From: Steffen Jost <jost@tcs.ifi.lmu.de>
Date: Sun, 31 Mar 2019 21:15:46 +0200
Subject: [PATCH] Session: newness for StudyTerms lasts longer

---
 messages/uniworx/de.msg |  2 ++
 src/Foundation.hs       |  2 +-
 src/Handler/Admin.hs    | 29 ++++++++++++++++++-----------
 src/Utils.hs            |  4 ++--
 4 files changed, 23 insertions(+), 14 deletions(-)

diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index 2c90d5524..7d51240f3 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -1,3 +1,5 @@
+PrintDebugForStupid name@Text: Debug message "#{name}"
+
 BtnSubmit: Senden
 BtnAbort: Abbrechen
 BtnDelete: Löschen
diff --git a/src/Foundation.hs b/src/Foundation.hs
index b2ed47c49..0d8e5d909 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -1001,7 +1001,7 @@ siteLayout' headingOverride widget = do
     | isModal -> getMessages
     | otherwise -> do
         applySystemMessages
-        authTagPivots <- fromMaybe Set.empty <$> getSessionJson SessionInactiveAuthTags
+        authTagPivots <- fromMaybe Set.empty <$> takeSessionJson SessionInactiveAuthTags
         forM_ authTagPivots $
           \authTag -> addMessageWidget Info $ modal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute]))
         getMessages
diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs
index ad3b77383..19b84adf3 100644
--- a/src/Handler/Admin.hs
+++ b/src/Handler/Admin.hs
@@ -286,6 +286,9 @@ instance Button UniWorX ButtonAdminStudyTerms where
   btnClasses BtnCandidatesDeleteAll       = [BCIsButton, BCDanger]
 -- END Button needed only here
 
+sessionKeyNewStudyTerms :: Text
+sessionKeyNewStudyTerms = "key-new-study-terms"
+
 getAdminFeaturesR, postAdminFeaturesR :: Handler Html
 getAdminFeaturesR = postAdminFeaturesR
 postAdminFeaturesR = do
@@ -295,34 +298,38 @@ postAdminFeaturesR = do
           , formEncoding = btnEnctype
           , formSubmit = FormNoSubmit
           }
-    (infConflicts,infAccepted) <- case btnResult of
+    infConflicts <- case btnResult of
       FormSuccess BtnCandidatesInfer -> do
         (infConflicts, infAmbiguous, infRedundant, infAccepted) <- Candidates.inferHandler
         unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousCandidatesRemoved $ length infAmbiguous
         unless (null infRedundant) . addMessageI Info . MsgRedundantCandidatesRemoved $ length infRedundant
-        if
-          | null infAccepted
-            -> addMessageI Info      MsgNoCandidatesInferred
-          | otherwise
-            -> addMessageI Success . MsgCandidatesInferred $ length infAccepted
-        return (infConflicts, infAccepted)
+        let newKeys = map (StudyTermsKey' . fst) infAccepted
+        setSessionJson sessionKeyNewStudyTerms newKeys
+        -- addMessageI Error $ MsgPrintDebugForStupid $ tshow newKeys
+        if  | null infAccepted
+              -> addMessageI Info      MsgNoCandidatesInferred
+            | otherwise
+               -> addMessageI Success . MsgCandidatesInferred $ length infAccepted
+        return infConflicts
       FormSuccess BtnCandidatesDeleteConflicts -> runDB $ do
         confs <- Candidates.conflicts
         incis <- Candidates.getIncidencesFor (entityKey <$> confs)
         deleteWhere [StudyTermCandidateIncidence <-. (E.unValue <$> incis)]
         addMessageI Success $ MsgIncidencesDeleted $ length incis
-        return ([],[])
+        return []
       FormSuccess BtnCandidatesDeleteAll -> runDB $ do
         deleteWhere ([] :: [Filter StudyTermCandidate])
         addMessageI Success MsgAllIncidencesDeleted
-        (, []) <$> Candidates.conflicts
-      _other -> (, []) <$> runDB Candidates.conflicts
+        Candidates.conflicts
+      _other -> runDB Candidates.conflicts
 
+    newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson sessionKeyNewStudyTerms
+    -- addMessageI Error $ MsgPrintDebugForStupid $ tshow newStudyTermKeys
     (   (degreeResult,degreeTable)
       , (studyTermsResult,studytermsTable)
       , ((), candidateTable)) <- runDB $ (,,)
       <$> mkDegreeTable
-      <*> mkStudytermsTable (Set.fromList $ map (StudyTermsKey' . fst) infAccepted)
+      <*> mkStudytermsTable (Set.fromList newStudyTermKeys)
                             (Set.fromList $ map entityKey infConflicts)
       <*> mkCandidateTable
 
diff --git a/src/Utils.hs b/src/Utils.hs
index f6ebd76d6..bd0998561 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -610,9 +610,9 @@ modifySessionJson (toPathPiece -> key) f = lookupSessionJson key >>= maybe (dele
 tellSessionJson :: (PathPiece k, FromJSON v, ToJSON v, MonadHandler m, Monoid v) => k -> v -> m ()
 tellSessionJson key val = modifySessionJson key $ Just . (`mappend` val) . fromMaybe mempty
 
-getSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v)
+takeSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v)
 -- ^ `lookupSessionJson` followed by `deleteSession`
-getSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key)
+takeSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key)
 
 --------------------
 -- GET Parameters --