Merge branch 'master' into fradrive/newletter

CHANGELOG.md

@@ -2,6 +2,29 @@
 
 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
 
+## [27.4.70](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.69...v27.4.70) (2024-06-21)
+
+
+### Bug Fixes
+
+* **build:** hlint wants a newtype instead ([0766351](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/07663516e520814e26740d671325b7cd10855dd4))
+
+## [27.4.69](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.68...v27.4.69) (2024-06-21)
+
+
+### Bug Fixes
+
+* **avs:** fix type causing avs surname upate not working ([822c43c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/822c43c8a7db2086954ad187502ec2c4f1811d17))
+* **avs:** keep company on unchange address/email only if either is non-empty ([766b858](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/766b8589d6945df21fc6ce90d35a004655ffa471))
+* **avs:** synch job deletes used row instead of truncation ([d7acc7a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d7acc7a2d0fe5fc18929a8cb2d9c9f8a259c9944))
+
+## [27.4.68](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.67...v27.4.68) (2024-06-19)
+
+
+### Bug Fixes
+
+* **letter:** minor ([2ae11dc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2ae11dc25c000486af9acc26439a0580f5c687f2))
+
 ## [27.4.67](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.66...v27.4.67) (2024-06-17)
 
 

messages/uniworx/utils/table_column/de-de-formal.msg

@@ -103,6 +103,7 @@ TableJobLockTime: Bearbeitung seit
 TableJobLockInstance: Bearbeiter
 TableJobCreationInstance: Ersteller
 ActJobDelete: Job entfernen
+ActJobDeleteForce n@Int: Auch vor #{pluralDEnN n "Minute"} gesperrte Jobs entfernen
 TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} Jobs entfernt
 TableFilterComma: Es können mehrere alternative Suchkriterien mit Komma getrennt angegeben werden, wovon mindestens eines erfüllt werden muss.
 TableFilterCommaPlus: Mehrere alternative Suchkriterien mit Komma trennen. Mindestens ein Suchkriterium muss erfüllt werden, zusätzlich zu allen Suchkriterien mit vorangestelltem Plus-Symbol.

messages/uniworx/utils/table_column/en-eu.msg

@@ -103,6 +103,7 @@ TableJobLockTime: Lock time
 TableJobLockInstance: Worker
 TableJobCreationInstance: Creator
 ActJobDelete: Delete job
+ActJobDeleteForce n: Also delete jobs locked #{pluralENsN n "minute"} ago
 TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} queued jobs deleted
 TableFilterComma: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled.
 TableFilterCommaPlus: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled in addition to all criteria preceded by a plus symbol.

nix/docker/version.json

@@ -1,3 +1,3 @@
 {
-  "version": "27.4.67"
+  "version": "27.4.70"
 }

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "27.4.67",
+  "version": "27.4.70",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "27.4.67",
+  "version": "27.4.70",
   "description": "",
   "keywords": [],
   "author": "",

package.yaml

@@ -1,5 +1,5 @@
 name: uniworx
-version: 27.4.67
+version: 27.4.70
 dependencies:
   - base
   - yesod

src/Database/Esqueleto/Utils.hs

@@ -52,7 +52,7 @@ module Database.Esqueleto.Utils
   , day, day', dayMaybe, interval, diffDays, diffTimes
   , exprLift
   , explicitUnsafeCoerceSqlExprValue
-  , truncateTable
+  -- , truncateTable
   , module Database.Esqueleto.Utils.TH
   ) where
 
@@ -69,7 +69,7 @@ import qualified Database.Esqueleto.PostgreSQL as E
 import qualified Database.Esqueleto.Internal.Internal as E
 import Database.Esqueleto.Utils.TH
 
-import qualified Database.Persist.Postgresql as P
+-- import qualified Database.Persist.Postgresql as P
 
 import qualified Data.Text as Text
 import qualified Data.Text.Lazy as Lazy (Text)
@@ -772,6 +772,7 @@ instance (PersistField a1, PersistField a2, PersistField b, Finite a1, Finite a2
     (E.else_ $ E.else_ $ E.veryUnsafeCoerceSqlExprValue (E.nothing :: E.SqlExpr (E.Value (Maybe ()))))
 
 
-truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record) 
+-- Suspected to cause trouble. Needs more testing!
-              => record -> ReaderT backend m ()
+-- truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record) 
-truncateTable tbl = E.rawExecute ("TRUNCATE TABLE " <> P.tableName tbl <> "  RESTART IDENTITY") []
+--               => record -> ReaderT backend m ()
+-- truncateTable tbl = E.rawExecute ("TRUNCATE TABLE " <> P.tableName tbl <> "  RESTART IDENTITY") []

src/Foundation/I18n.hs

@@ -8,7 +8,7 @@
 --   3. add constructor to list of module exports
 
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-top-binds #-}
 
 module Foundation.I18n
   ( appLanguages, appLanguagesOpts
@@ -87,21 +87,31 @@ pluralDE num singularForm pluralForm
   | num == 1  = singularForm
   | otherwise = pluralForm
 
--- pluralDEx :: (Eq a, Num a) => Char -> a -> Text -> Text
+pluralDEx :: (Eq a, Num a) => Char -> a -> Text -> Text
--- -- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@ 
+-- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@ 
--- pluralDEx c n t = pluralDE n t $ t `snoc` c
+pluralDEx c n t = pluralDE n t $ t `snoc` c
 
--- -- | like `pluralDEe` but also prefixes with the number
+-- | like `pluralDEe` but also prefixes with the number
--- pluralDExN :: (Eq a, Num a, Show a) => Char -> a -> Text -> Text
+pluralDExN :: (Eq a, Num a, Show a) => Char -> a -> Text -> Text
--- pluralDExN c n t = tshow n <> cons ' ' (pluralDEx c n t)
+pluralDExN c n t = tshow n <> cons ' ' (pluralDEx c n t)
 
 pluralDEe :: (Eq a, Num a) => a -> Text -> Text
 -- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@ 
-pluralDEe n t = pluralDE n t $ t `snoc` 'e'
+pluralDEe = pluralDEx 'e'
 
 -- | like `pluralDEe` but also prefixes with the number
 pluralDEeN :: (Eq a, Num a, Show a) => a -> Text -> Text
-pluralDEeN n t = tshow n <> cons ' ' (pluralDEe n t)
+pluralDEeN = pluralDExN 'e'
+
+-- | postfix plural with an 'n'
+pluralDEn :: (Eq a, Num a) => a -> Text -> Text
+-- ^ @pluralENs n "Monat" = pluralEN n "Monat" "Monate"@ 
+pluralDEn = pluralDEx 'n'
+
+-- | like `pluralDEn` but also prefixes with the number
+pluralDEnN :: (Eq a, Num a, Show a) => a -> Text -> Text
+pluralDEnN = pluralDExN 'n'
+
 
 noneOneMoreDE :: (Eq a, Num a)
               =>    a -- ^ Count

src/Handler/Admin/Crontab.hs

@@ -35,6 +35,9 @@ import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.Utils as E
 -- import Database.Esqueleto.Utils.TH
 
+-- Number of minutes a job must have been locked already to allow forced deletion
+jobDeleteLockMinutes :: Int
+jobDeleteLockMinutes = 3 
 
 deriveJSON defaultOptions
   { constructorTagModifier = camelToPathPiece' 1
@@ -118,7 +121,9 @@ instance Finite JobTableAction
 nullaryPathPiece ''JobTableAction $ camelToPathPiece' 1
 embedRenderMessage ''UniWorX ''JobTableAction id
 
-newtype JobTableActionData = ActJobDeleteData
+newtype JobTableActionData = ActJobDeleteData 
+                            { jobDeleteLocked :: Bool
+                            }
   deriving (Eq, Ord, Read, Show, Generic)
 
 
@@ -164,7 +169,8 @@ postAdminJobsR = do
           ]
         dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
         acts :: Map JobTableAction (AForm Handler JobTableActionData)
-        acts = Map.singleton ActJobDelete $ pure ActJobDeleteData
+        acts = Map.singleton ActJobDelete $ ActJobDeleteData
+                <$> areq checkBoxField (fslI $ MsgActJobDeleteForce jobDeleteLockMinutes) Nothing
         dbtParams = DBParamsForm 
           { dbParamsFormAdditional = 
             renderAForm FormStandard
@@ -193,13 +199,22 @@ postAdminJobsR = do
   (jobActRes, jobsTable) <- runDB (over _1 postprocess <$> dbTable jobsDBTableValidator jobsDBTable)
 
   formResult jobActRes $ \case
-    (ActJobDeleteData, jobIds) -> do
+    (ActJobDeleteData{jobDeleteLocked}, jobIds) -> do
-      let jobReq  = length jobIds
+      now <- liftIO getCurrentTime
+      let cutoff :: UTCTime
+          cutoff = addUTCTime (nominalMinute * fromIntegral (negate jobDeleteLockMinutes)) now
+          jobReq    = length jobIds
+          lockCriteria
+            | jobDeleteLocked = 
+                [ QueuedJobLockTime ==. Nothing ] ||.
+                [ QueuedJobLockTime <=. Just cutoff ]
+            | otherwise = 
+                [ QueuedJobLockTime     ==. Nothing
+                , QueuedJobLockInstance ==. Nothing
+                ]
       rmvd <- runDB $ fromIntegral <$> deleteWhereCount
-        [ QueuedJobLockTime ==. Nothing
+        ((QueuedJobId <-. Set.toList jobIds) : lockCriteria)
-        , QueuedJobLockInstance ==. Nothing
+        
-        , QueuedJobId <-. Set.toList jobIds
-        ]
       addMessageI (bool Success Warning $ rmvd < jobReq) (MsgTableJobActDeleteFeedback rmvd jobReq)
       reloadKeepGetParams AdminJobsR
 

src/Handler/Utils/Avs.hs

@@ -399,8 +399,10 @@ updateAvsUserByADC (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = runMa
         usr_up2 <- case oldAvsFirmInfo of 
           _ | Just newCompanyId == oldCompanyId                                               -- company unchanged entirely
               -> return mempty                                                                --  => do nothing
-          (Just oafi) |  ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo       -- company address unchanged OR
+          (Just oafi) |  isJust    (view _avsFirmPostAddressSimple  oafi) 
-                      || ((==) `on` view _avsFirmPrimaryEmail)      oafi newAvsFirmInfo       -- company primary email unchanged
+                      && ((==) `on` view _avsFirmPostAddressSimple) oafi newAvsFirmInfo       -- non-empty company address unchanged OR
+                      || isJust    (view _avsFirmPrimaryEmail       oafi)
+                      && ((==) `on` view _avsFirmPrimaryEmail)      oafi newAvsFirmInfo       -- non-empty company primary email unchanged
               -> do                                                                           --  => just update user company association, keeping supervision privileges                  
                   case oldCompanyId of
                     Nothing -> void $ insertUnique newUserComp -- it's ok if this already exists

src/Handler/Utils/AvsUpdate.hs

@@ -65,7 +65,7 @@ instance MkCheckUpdate CU_AvsPersonInfo_User where
   type MCU_Rec CU_AvsPersonInfo_User = User
   type MCU_Raw CU_AvsPersonInfo_User = AvsPersonInfo
   mkCheckUpdate CU_API_UserFirstName             = CheckUpdate     UserFirstName               _avsInfoFirstName
-  mkCheckUpdate CU_API_UserSurname               = CheckUpdate     UserFirstName               _avsInfoLastName
+  mkCheckUpdate CU_API_UserSurname               = CheckUpdate     UserSurname                 _avsInfoLastName
   mkCheckUpdate CU_API_UserDisplayName           = CheckUpdate     UserDisplayName             _avsInfoDisplayName
   mkCheckUpdate CU_API_UserBirthday              = CheckUpdate     UserBirthday                _avsInfoDateOfBirth
   mkCheckUpdate CU_API_UserMobile                = CheckUpdate     UserMobile                  _avsInfoPersonMobilePhoneNo

src/Jobs/Handler/SynchroniseAvs.hs

@@ -102,27 +102,29 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause
 dispatchJobSynchroniseAvsQueue :: JobHandler UniWorX
 dispatchJobSynchroniseAvsQueue = JobHandlerException $ do    
     jobs <- runDB $ do
-      jobs <- E.select (do
+      E.select (do
           (avsSync :& usrAvs) <- E.from $  E.table @AvsSync 
                               `E.leftJoin` E.table @UserAvs
             `E.on` (\(avsSync :& usrAvs) -> avsSync E.^. AvsSyncUser E.=?. usrAvs E.?. UserAvsUser)
           let pause    = avsSync E.^. AvsSyncPause  
               lastSync = usrAvs  E.?. UserAvsLastSynch
-          E.where_ $  E.isNothing pause
+              proceed  =        E.isNothing pause
-                E.||. E.isNothing lastSync
+                          E.||. E.isNothing lastSync
-                E.||. pause E.>. E.dayMaybe lastSync
+                          E.||. pause E.>. E.dayMaybe lastSync
-          return (avsSync E.^. AvsSyncUser, usrAvs E.?. UserAvsPersonId)
+          -- E.where_ proceed -- we still want to delete all paused jobs, rather than to delay them only
+          return (avsSync E.^. AvsSyncUser, usrAvs E.?. UserAvsPersonId, proceed)
         )
-      now <- liftIO getCurrentTime
+      -- now <- liftIO getCurrentTime
-      E.truncateTable $ AvsSync (error "truncateTable: AvsSyncUser not needed") now Nothing
+      -- E.truncateTable $ AvsSync (error "truncateTable: AvsSyncUser not needed") now Nothing
-      return jobs
+      -- return jobs
     let (unlinked, linked) = foldl' discernJob mempty jobs
     $logInfoS "SynchronisAvs" [st|AVS synch performing for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
     void $ updateAvsUserByIds  linked
     void $ linktoAvsUserByUIDs unlinked
+    runDB $ deleteWhere [AvsSyncUser <-. (E.unValue . fst3 <$> jobs)]
     $logInfoS "SynchronisAvs" [st|AVS synch performed for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
     -- we do not reschedule failed synchs here in order to avoid a loop
   where 
-    discernJob (accUid, accApi) (         _ , E.Value (Just api)) = (               accUid, Set.insert api accApi)
+    discernJob accs (         _ , E.Value (Just api), E.Value True  ) = accs & over _2 (Set.insert api)
-    discernJob (accUid, accApi) (E.Value uid, E.Value  Nothing  ) = (Set.insert uid accUid,                accApi)
+    discernJob accs (E.Value uid, E.Value  Nothing  , E.Value True  ) = accs & over _1 (Set.insert uid)
-    
+    discernJob accs (         _ ,                 _ , E.Value False ) = accs