refactor(qualification): work on blocking WIP

src/Database/Esqueleto/Utils.hs

@@ -468,7 +468,7 @@ max, min :: PersistField a
 max a b = bool a b $ b E.>. a
 min a b = bool a b $ b E.<. a
 
--- these alternatives for max/min ought to be more efficient; note that NULL is avoided by greatest/least
+-- these alternatives for max/min ought to be more efficient; note that NULL is avoided by PostgreSQL greatest/least
 greatest :: PersistField a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a)
 greatest a b = E.unsafeSqlFunction "GREATEST" $ E.toArgList (a,b)
 

src/Handler/LMS.hs

@@ -651,7 +651,10 @@ postLmsR sid qsh = do
     (LmsActRestartData{..}, selectedUsers) -> do
       let usersList = Set.toList selectedUsers      
       delUsers <- runDB $ do 
-        when (lmsActRestartUnblock == Just True) $ do
+        when (lmsActRestartUnblock == Just True && ) $ do
+          authBy <- maybeAuthId
+          TODO
+          let unblock = toMaybe (lmsActRestartUnblock == Just True) (nowaday, "Manueller LMS Neustart", authBy)
           unblockUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList 
             [ QualificationUserQualification ==. qid
             , QualificationUserUser <-. usersList
@@ -666,8 +669,8 @@ postLmsR sid qsh = do
             , QualificationUserUser <-. usersList
             , QualificationUserBlockedDue ==. Nothing
             , QualificationUserValidUntil <. cutoff
-            ] []
+            ] []          
-          forM_ shortUsers $ upsertQualificationUser qid nowaday cutoff Nothing
+          forM_ shortUsers $ upsertQualificationUser qid nowaday cutoff Nothing Nothing
 
         fromIntegral <$> deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList]
 

src/Handler/Utils/Qualification.hs

@@ -62,12 +62,11 @@ selectValidQualifications qid mbUids nowaday =
 ------------------------
 
 
-upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB ()
+upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> Maybe (Day, Text, Maybe UserId) -> UserId -> DB () -- may also unblock
-upsertQualificationUser  qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do
+upsertQualificationUser  qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal mbUnblockBecause qualificationUserUser = do
   Entity quid _ <- upsert
     QualificationUser
-      { qualificationUserFirstHeld        = qualificationUserLastRefresh
+      { qualificationUserFirstHeld        = qualificationUserLastRefresh      
-      , qualificationUserBlockedDue       = Nothing
       , qualificationUserScheduleRenewal  = fromMaybe True mbScheduleRenewal
       , qualificationUserLastNotified     = toMidnight qualificationUserLastRefresh
       , ..
@@ -76,10 +75,15 @@ upsertQualificationUser  qualificationUserQualification qualificationUserLastRef
       [ QualificationUserScheduleRenewal    =. scheduleRenewal              | Just scheduleRenewal <- [mbScheduleRenewal]
       ] ++
       [ QualificationUserValidUntil         =. qualificationUserValidUntil
-      , QualificationUserLastRefresh        =. qualificationUserLastRefresh
+      , QualificationUserLastRefresh        =. qualificationUserLastRefresh      
-      , QualificationUserBlockedDue         =. Nothing
       ]
     )
+  whenIsJust mbUnblockBecause $ \(qualificationUserBlockFrom, qualificationUserBlockReason, qualificationUserBlockBlocker) -> do    
+    block <- selectFirst [ QualificationUserBlockQualificationUser ==. quid ] [ Desc QualificationUserBlackFrom ]
+    whenIsJust block $ \qub ->
+      unless (qub ^. _qualificationUserBlockUnblock) $
+        insert QualificationUserBlock{ qualificationUserBlockQualificationUser = quid, qualificationUserBlockUnblock = True, ..}
+
   audit TransactionQualificationUserEdit
     { transactionQualificationUser            = quid
     , transactionQualification                = qualificationUserQualification
@@ -131,10 +135,26 @@ qualificationUserBlocking ::
   , MonadHandler m
   , MonadCatch m
   , Num n
-  ) => QualificationId -> [UserId] -> Bool -> Maybe QualificationBlocked -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
+  ) => QualificationId -> [UserId] -> Bool -> Text -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
 
-qualificationUserBlocking qid uids notify qb = do
+qualificationUserBlocking qid uids unblock reason notify qb = do
+  authUsr <- liftHandler maybeAuthId
   now <- liftIO getCurrentTime
+  let nowaday = utctDay now
+  -- TODO: filter by blocked selectList ???
+
+  E.insertSelect . E.from $ \qualificationUser -> do
+    E.where_ $ qualificationUser E.^. QualificationUserQualification E.==. E.val qid 
+        E.&&.  qualificationUser E.^. QualificationUserUser E.in_ E.valList uid
+        E.&&. -- TODO: latest entry is just sql for 
+    return $ QualificationUserBlock
+      E.<#  qualificationUser E.^. QualificationUserId
+      E.<&> E.val unblock
+      E.<&> E.val nowaday
+      E.<&> E.val reason
+      E.<&> E.val authUsr
+
+
   oks <- updateWhereCount -- prevents storage of transactionQualificatioUser 
     ( [ QualificationUserBlockedDue     !=. Nothing  |  isNothing qb  -- only unblock blocked qualification; allow overwrite for existing blocks
       ] ++  

src/Handler/Utils/Users.hs

@@ -815,30 +815,25 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
   unless (Set.null qResolvable) $ deleteWhere [ LmsUserUser ==. oldUserId, LmsUserQualification <-. Set.toList qResolvable ] -- delete conflicting and finished LMS, which are still within auditDuration
   updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ]
   updateWhere [ QualificationEditUser ==. oldUserId ] [ QualificationEditUser =. newUserId ]
-  E.insertSelectWithConflict
+  usrQualis <- E.select $ E.from $ \(oldQual `E.LeftOuterJoin` newQual) -> do
-    UniqueQualificationUser
+      E.on (      newQual E.?. QualificationUserQualification E.?=. oldQual E.^. QualificationUserQualification
-    (E.from $ \qualificationUser -> do
+            E.&&. newQual E.?. QualificationUserUser          E.?=. E.val newUserId
-        E.where_ $ qualificationUser E.^. QualificationUserUser E.==. E.val oldUserId
+            )
-        return $ QualificationUser
+      E.where_ $  oldQual E.^. QualificationUserUser          E.==. E.val oldUserId          
-          E.<#  E.val newUserId
+      return (oldQual, newQual)
-          E.<&> (qualificationUser E.^. QualificationUserQualification)
+  forM_ usrQualis $ \case 
-          E.<&> (qualificationUser E.^. QualificationUserValidUntil)
+    (Entity oldQKey _, Nothing) -> update oldQKey [ QualificationUserUser =. newUserId ] -- update must succeed if there is not RHS in the join
-          E.<&> (qualificationUser E.^. QualificationUserLastRefresh)
+    (Entity oldQKey oldQUsr, Just (Entity newQKey newQUsr)) -> do
-          E.<&> (qualificationUser E.^. QualificationUserFirstHeld)
+      updateWhere [ QualificationUserBlockQualificationUser ==. oldQKey ] [ QualificationUserBlockQualificationUser =. newQKey ]
-          E.<&> (qualificationUser E.^. QualificationUserBlockedDue)
+      update newQKey 
-          E.<&> (qualificationUser E.^. QualificationUserScheduleRenewal)
+        [ QualificationUserValidUntil       =. (max `on` view _qualificationUserValidUntil     ) oldQUsr newQUsr
-          E.<&> (qualificationUser E.^. QualificationUserLastNotified)
+        , QualificationUserLastRefresh      =. (max `on` view _qualificationUserLastRefresh    ) oldQUsr newQUsr
-    )
+        , QualificationUserFirstHeld        =. (min `on` view _qualificationUserFirstHeld      ) oldQUsr newQUsr
-    (\current excluded ->
+        , QualificationUserScheduleRenewal  =. (max `on` view _qualificationUserScheduleRenewal) oldQUsr newQUsr
-      [ QualificationUserValidUntil       E.=. combineWith current excluded E.greatest QualificationUserValidUntil
+        , QualificationUserLastNotified     =. (max `on` view _qualificationUserLastNotified   ) oldQUsr newQUsr
-      , QualificationUserLastRefresh      E.=. combineWith current excluded E.greatest QualificationUserLastRefresh
+        ]
-      , QualificationUserFirstHeld        E.=. combineWith current excluded E.least    QualificationUserFirstHeld
+      delete oldQKey
-      , QualificationUserBlockedDue       E.=. combineWith current excluded E.greatest QualificationUserBlockedDue  -- Tested: PostgreSQL GREATEST/LEAST ignores NULL values
+  -- deleteWhere [ QualificationUserUser ==. oldUserId ] -- no longer needed  
-      , QualificationUserScheduleRenewal  E.=. combineWith current excluded E.greatest QualificationUserScheduleRenewal
-      , QualificationUserLastNotified     E.=. combineWith current excluded E.greatest QualificationUserLastNotified
-      ]
-    )
-  deleteWhere [ QualificationUserUser ==. oldUserId ]
 
   -- Supervision is fully merged
   E.insertSelectWithConflict