Session: newness for StudyTerms lasts longer

messages/uniworx/de.msg

@@ -1,3 +1,5 @@
+PrintDebugForStupid name@Text: Debug message "#{name}"
+
 BtnSubmit: Senden
 BtnAbort: Abbrechen
 BtnDelete: Löschen

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

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
+        let newKeys = map (StudyTermsKey' . fst) infAccepted
-          | null infAccepted
+        setSessionJson sessionKeyNewStudyTerms newKeys
-            -> addMessageI Info      MsgNoCandidatesInferred
+        -- addMessageI Error $ MsgPrintDebugForStupid $ tshow newKeys
-          | otherwise
+        if  | null infAccepted
-            -> addMessageI Success . MsgCandidatesInferred $ length infAccepted
+              -> addMessageI Info      MsgNoCandidatesInferred
-        return (infConflicts, infAccepted)
+            | 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
+        Candidates.conflicts
-      _other -> (, []) <$> runDB 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
 

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 --