Merge branch 'fradrive/jost'
This commit is contained in:
commit
90613faf72
@ -1,4 +1,4 @@
|
||||
# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
|
||||
# SPDX-FileCopyrightText: 2023-24 Steffen Jost <s.jost@fraport.de>
|
||||
#
|
||||
# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -15,11 +15,15 @@ FirmActionInfo: Betrifft alle Firmenangehörigen unter Ihrer Aufsicht.
|
||||
FirmActNotify: Mitteilung versenden
|
||||
FirmActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen
|
||||
FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten?
|
||||
FirmActRemoveSupers: Alle rein firmenbezogenen Ansprechpartnerbeziehungen für diese Personen entfernen?
|
||||
FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig
|
||||
FirmActResetSupersKeepAll: Alle behalten
|
||||
FirmActResetSupersRemoveAps: Nur Standardansprechpartner entfernen
|
||||
FirmActResetSupersRemoveAll: Alle entfernen
|
||||
FirmActAddSupervisors: Ansprechpartner hinzufügen
|
||||
FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden
|
||||
FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner geändert #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert.
|
||||
RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber keine aktiven Ansprechpartnerbeziehungen wurden deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)}
|
||||
RemoveSupervisors ndef@Int64: #{ndef} Standardansprechpartner entfernt.
|
||||
FirmActChangeContactUser: Kontaktinformationen von allen Firmenangehörigen ändern
|
||||
FirmActChangeContactFirm: Kontaktinformationen der Firma ändern
|
||||
FirmActChangeContactFirmInfo: Firmenkontaktinformationen werden nur für neue Firmenangehörige verwendet, für die sonst keine Kontaktinformationen vorliegen.
|
||||
@ -33,7 +37,8 @@ FirmUserActRemove: Firmenassoziation entfernen
|
||||
FirmUserActMkSuper: Zum Firmenansprechpartner ernennen
|
||||
FirmUserActChangeDetailsResult n@Int64 t@Int64: Firmenassoziation von #{n}/#{t} #{pluralDE n "Firmenangehörigen" "Firmenangehörige"} wurden aktualisiert
|
||||
FirmUserActChangeResult n@Int64 t@Int64: Benachrichtigungseinstellung für #{n}/#{t} #{pluralDE n "Firmenangehörigen" "Firmenangehörige"} wurden geändert
|
||||
FirmuserActRemoveResult uc@Int64 sup@Int64 sub@Int64: #{uc} #{pluralDE uc "Firmenassoziation" "Firmenassoziationen"} entfernt. #{noneMoreDE sup "" (tshow sup <> "Ansprechpartnerbeziehungen wegen entferntem Ansprechpartner gelöschtt. ")} #{noneMoreDE sub "" (tshow sup <> "Ansprechpartnerbeziehungen wegen entfernten Angesprochenen gelöscht.")}
|
||||
FirmUserActRemoveResult uc@Int64: #{uc} #{pluralDE uc "Firmenassoziation" "Firmenassoziationen"} entfernt.
|
||||
FirmRemoveSupervision sup@Int64 sub@Int64: #{noneMoreDE sup "" (tshow sup <> " Ansprechpartnerbeziehungen wegen entferntem Ansprechpartner gelöscht. ")} #{noneOneMoreDE sub "Keine Ansprechpartnerbeziehung" "Eine Ansprechpartnerbeziehung" (tshow sup <> " Ansprechpartnerbeziehungen")} wegen entferntem Angesprochenem gelöscht.
|
||||
FirmNewSupervisor: Neue individuelle Ansprechpartner hinzufügen
|
||||
FirmSetSupervisor: Existierende Ansprechpartner hinzufügen
|
||||
FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: Für #{nusr} Firmenangehörige wurden #{nspr} individuelle Ansprechpartner eingetragen#{bool "." (" und " <> tshow nrem <> " individuelle Ansprechpartnerbeziehungen gelöscht.") (nrem >0)}
|
||||
@ -42,7 +47,7 @@ FirmSuperActNotify: Mitteilung versenden
|
||||
FirmSuperActSwitchSuper: Standard Firmenansprechpartner abändern
|
||||
FirmSuperActSwitchSuperInfo: Betrifft keine firmenfremden Ansprechpartner und ändert keine aktiven individuellen Ansprechpartnerbeziehungen. Gegebenfalls im Anschluss die Funktion "Ansprechpartner auf Firmenstandard zurücksetzen" nutzen.
|
||||
FirmSuperActRMSuperDef: Firmenansprechpartner entfernen
|
||||
FirmSuperActRMSuperActive: Auch aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden
|
||||
FirmSuperActRMSuperActive: Aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden?
|
||||
FirmsNotification: Firmen E-Mail versenden
|
||||
FirmNotification fsh@CompanyShorthand: E-Mail an #{fsh} senden
|
||||
FirmsNotificationTitle: Firmen benachrichtigen
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
|
||||
# SPDX-FileCopyrightText: 2023-24 Steffen Jost <s.jost@fraport.de>
|
||||
#
|
||||
# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -15,11 +15,15 @@ FirmActionInfo: Affects alle company associates under your supervision.
|
||||
FirmActNotify: Send message
|
||||
FirmActResetSupervision: Reset supervisors for all company associates
|
||||
FirmActResetSuperKeep: Additionally keep existing supervisors of company associates?
|
||||
FirmActRemoveSupers: Terminate all company related supervisonships?
|
||||
FirmActResetMutualSupervision: Supervisors supervise each other
|
||||
FirmActResetSupersKeepAll: Keep all
|
||||
FirmActResetSupersRemoveAps: Remove default supervisors only
|
||||
FirmActResetSupersRemoveAll: Remove all
|
||||
FirmActAddSupervisors: Add supervisors
|
||||
FirmActAddSupersEmpty: No supervisors added
|
||||
FirmActAddSupersSet n postal: #{n} default company supervisors changed #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated.
|
||||
RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but no active supervisions were deactivated" (" and " <> tshow nact <> " active supervisions terminated") (nact > 0)}
|
||||
RemoveSupervisors ndef: #{ndef} default supervisors removed.
|
||||
FirmActChangeContactUser: Change contact data for all company associates
|
||||
FirmActChangeContactFirm: Change company contact data
|
||||
FirmActChangeContactFirmInfo: The company contact data is only used for new company associates that would habe no contact information of their own otherwise.
|
||||
@ -33,7 +37,8 @@ FirmUserActRemove: Delete company association
|
||||
FirmUserActMkSuper: Mark as company supervisor
|
||||
FirmUserActChangeDetailsResult n t: #{n}/#{t} #{pluralENs n "company association"} updated
|
||||
FirmUserActChangeResult n t: Notification settings changed for #{n}/#{t} company #{pluralENs n "associate"}
|
||||
FirmuserActRemoveResult uc sup sub: #{pluralENsN uc "Company association"} deleted. #{noneMoreEN sup "" ((pluralENsN sup "supervision") <> " removed due to eliminated supervisors.")} #{noneMoreEN sub "" ((pluralENsN sub "supervision") <> " removed due to eliminated supervisees.")}
|
||||
FirmUserActRemoveResult uc: #{pluralENsN uc "Company association"} deleted.
|
||||
FirmRemoveSupervision sup sub: #{noneMoreEN sup "" ((pluralENsN sup "supervision") <> " removed due to eliminated supervisors.")} #{noneMoreEN sub "No supervision" (pluralENsN sub "supervision")} removed due to eliminated supervisees.
|
||||
FirmNewSupervisor: Appoint new individual supervisors
|
||||
FirmSetSupervisor: Add existing supervisors
|
||||
FirmSetSupersReport nusr nspr nrem: #{nspr} individual supervisors set for #{nusr} company associates#{bool "." (" and " <> tshow nrem <> " other individual supervisions terminated.") (nrem >0)}
|
||||
@ -42,7 +47,7 @@ FirmSuperActNotify: Send message
|
||||
FirmSuperActSwitchSuper: Change default company supervisor
|
||||
FirmSuperActSwitchSuperInfo: Does not affect company-external supervisors and does not change any active individual supervisions. Additionally use reset action, if desired.
|
||||
FirmSuperActRMSuperDef: Remove default supervisor
|
||||
FirmSuperActRMSuperActive: Also remove active supervisions within this company
|
||||
FirmSuperActRMSuperActive: Terminate active supervisions within this company?
|
||||
FirmsNotification: Send company notification e-mail
|
||||
FirmNotification fsh: Send e-mail to #{fsh}
|
||||
FirmsNotificationTitle: Company notification
|
||||
|
||||
@ -34,7 +34,7 @@ dummyForm = do
|
||||
mr <- getMessageRender
|
||||
wreq (ciField & addDatalist userList) (fslpI MsgDummyIdent (mr MsgDummyIdentPlaceholder) & addAttr "autocomplete" "username" & addName PostLoginDummy) Nothing
|
||||
where
|
||||
userList = fmap mkOptionList . runDB $ withReaderT projectBackend (map toOption <$> selectList [] [Asc UserIdent] :: ReaderT SqlBackend _ [Option UserIdent])
|
||||
userList = fmap mkOptionList . runDB $ withReaderT projectBackend (map toOption <$> selectList [UserId <=. UserKey 12] [Asc UserIdent] :: ReaderT SqlBackend _ [Option UserIdent])
|
||||
toOption (Entity _ User{..}) = Option userDisplayName userIdent (CI.original userIdent)
|
||||
|
||||
apDummy :: Text
|
||||
|
||||
@ -55,6 +55,7 @@ module Database.Esqueleto.Utils
|
||||
, day, day', dayMaybe, interval, diffDays, diffTimes
|
||||
, exprLift
|
||||
, explicitUnsafeCoerceSqlExprValue
|
||||
, psqlVersion_
|
||||
, truncateTable
|
||||
, module Database.Esqueleto.Utils.TH
|
||||
) where
|
||||
@ -814,6 +815,8 @@ instance (PersistField a1, PersistField a2, PersistField b, Finite a1, Finite a2
|
||||
]
|
||||
(E.else_ $ E.else_ $ E.veryUnsafeCoerceSqlExprValue (E.nothing :: E.SqlExpr (E.Value (Maybe ()))))
|
||||
|
||||
psqlVersion_ :: E.SqlExpr (E.Value Text)
|
||||
psqlVersion_ = E.unsafeSqlFunction "VERSION" ()
|
||||
|
||||
-- Suspected to cause trouble. Needs more testing!
|
||||
-- truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record)
|
||||
|
||||
@ -283,7 +283,7 @@ postAdminAvsR = do
|
||||
(f_set , fs_size) = showLics AvsLicenceVorfeld
|
||||
(revoke , rv_size) = showLics AvsNoLicence
|
||||
return $ Just [whamlet|
|
||||
<h2>Licence check differences:
|
||||
<h2>Licence check AVS-ID differences:
|
||||
<dl .deflist>
|
||||
<dt .deflist__dt>Grant R (#{rg_size}):
|
||||
<dd .deflist__dd>#{r_grant}
|
||||
@ -308,7 +308,7 @@ postAdminAvsR = do
|
||||
let showApids apids
|
||||
| null apids = "[ ]"
|
||||
| otherwise = Text.intercalate ", " (tshow <$> Set.toList apids)
|
||||
procLic :: AvsLicence -> Bool -> Set AvsPersonId -> Html
|
||||
procLic :: (Ord a, Show a) => AvsLicence -> Bool -> Set a -> Html
|
||||
procLic aLic up apids
|
||||
| n <- Set.size apids, n > 0 =
|
||||
let subtype = Text.cons (bool '↧' '↥' up) $ Text.singleton $ licence2char aLic
|
||||
@ -349,18 +349,43 @@ postAdminAvsR = do
|
||||
l2 = guardMonoid (synchLevel >= 2) $ procLic AvsLicenceVorfeld True $ fltrIds avsLicenceDiffGrantVorfeld --grant Vorfeld
|
||||
l3 = guardMonoid (synchLevel >= 3) $ procLic AvsLicenceVorfeld False $ fltrIds avsLicenceDiffRevokeRollfeld --downgrade Rollfeld -> Vorfeld
|
||||
l4 = guardMonoid (synchLevel >= 4) $ procLic AvsLicenceRollfeld True $ fltrIds avsLicenceDiffGrantRollfeld --grant Rollfeld
|
||||
return $ Just [shamlet|
|
||||
<h3>
|
||||
Next automatic AVS licence synchronisation:
|
||||
<dl .deflist>
|
||||
^{l4}
|
||||
^{l3}
|
||||
^{l2}
|
||||
^{l1}
|
||||
$maybe reason <- reasonFilter
|
||||
<dt .deflist__dt>Filtered "#{reason}" (#{Set.size reasonFltrdIds}):
|
||||
<dd .deflist__dd>#{showApids reasonFltrdIds}
|
||||
|]
|
||||
avsIdChanges = [shamlet|
|
||||
<h3>
|
||||
Next automatic AVS-ID licence synchronisation:
|
||||
<dl .deflist>
|
||||
^{l4}
|
||||
^{l3}
|
||||
^{l2}
|
||||
^{l1}
|
||||
$maybe reason <- reasonFilter
|
||||
<dt .deflist__dt>Filtered "#{reason}" (#{Set.size reasonFltrdIds}):
|
||||
<dd .deflist__dd>#{showApids reasonFltrdIds}
|
||||
|]
|
||||
----------------------------------------------------
|
||||
-- translate AVS-IDs to AVS-NOs for convenience only
|
||||
avsidnos <- runDBRead $ E.select $ do
|
||||
ua <- X.from $ E.table @UserAvs
|
||||
E.where_ $ ua E.^. UserAvsPersonId `E.in_` E.vals (Set.unions [avsLicenceDiffRevokeAll, avsLicenceDiffRevokeRollfeld, avsLicenceDiffGrantVorfeld, avsLicenceDiffGrantRollfeld]) -- , reasonFltrdIds])
|
||||
return (ua E.^. UserAvsPersonId, ua E.^. UserAvsNoPerson)
|
||||
let id2no = Map.fromList $ $(E.unValueN 2) <$> avsidnos
|
||||
translate = setMapMaybe (`Map.lookup` id2no)
|
||||
l1' = guardMonoid (synchLevel >= 1) $ procLic AvsNoLicence False $ translate $ fltrIds avsLicenceDiffRevokeAll --revoke Vorfeld and maybe also Rollfeld
|
||||
l2' = guardMonoid (synchLevel >= 2) $ procLic AvsLicenceVorfeld True $ translate $ fltrIds avsLicenceDiffGrantVorfeld --grant Vorfeld
|
||||
l3' = guardMonoid (synchLevel >= 3) $ procLic AvsLicenceVorfeld False $ translate $ fltrIds avsLicenceDiffRevokeRollfeld --downgrade Rollfeld -> Vorfeld
|
||||
l4' = guardMonoid (synchLevel >= 4) $ procLic AvsLicenceRollfeld True $ translate $ fltrIds avsLicenceDiffGrantRollfeld --grant Rollfeld
|
||||
autoNoDiffs = [shamlet|
|
||||
<h3>
|
||||
Next automatic licence changes translated to human readable AVS-Numbers, if known:
|
||||
<dl .deflist>
|
||||
^{l4'}
|
||||
^{l3'}
|
||||
^{l2'}
|
||||
^{l1'}
|
||||
$maybe reason <- reasonFilter
|
||||
<dt .deflist__dt>Filtered "#{reason}" (#{Set.size reasonFltrdIds}):
|
||||
<dd .deflist__dd>#{showApids $ translate reasonFltrdIds}
|
||||
|]
|
||||
return $ Just $ avsIdChanges <> autoNoDiffs
|
||||
return (basediffs, autoDiffs)
|
||||
|
||||
-- (Just BtnSynchLicences) -> do
|
||||
|
||||
@ -28,7 +28,9 @@ import Text.Hamlet
|
||||
-- import Handler.Utils.I18n
|
||||
|
||||
import Handler.Admin.Test.Download (testDownload)
|
||||
|
||||
import qualified Database.Esqueleto.Experimental as E (selectOne, unValue)
|
||||
import qualified Database.Esqueleto.PostgreSQL as E (now_)
|
||||
import qualified Database.Esqueleto.Utils as E (psqlVersion_)
|
||||
|
||||
-- BEGIN - Buttons needed only here
|
||||
data ButtonCreate = CreateMath | CreateInf | CrashApp -- Dummy for Example
|
||||
@ -226,6 +228,9 @@ postAdminTestR = do
|
||||
|
||||
UniWorX{ appSettings' = AppSettings{..} } <- getYesod
|
||||
|
||||
psqlVersion <- runDBRead $ E.selectOne $ return E.psqlVersion_
|
||||
dbTime <- runDBRead $ E.selectOne $ return E.now_
|
||||
|
||||
let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]
|
||||
siteLayout locallyDefinedPageHeading $ do
|
||||
-- defaultLayout $ do
|
||||
@ -327,6 +332,17 @@ postAdminTestR = do
|
||||
<dd .deflist__dd>#{tshow appSynchroniseAvsUsersWithin}
|
||||
|]
|
||||
|
||||
[whamlet|
|
||||
<section>
|
||||
<h2> PostgreSQL Information
|
||||
<dl .deflist>
|
||||
$maybe pver <- psqlVersion
|
||||
<dt .deflist__dt>DB Version
|
||||
<dd .deflist__dd>#{E.unValue pver}
|
||||
$maybe ptme <- dbTime
|
||||
<dt .deflist__dt>DB Time
|
||||
<dd .deflist__dd>#{tshow (E.unValue ptme)}
|
||||
|]
|
||||
|
||||
|
||||
|
||||
|
||||
@ -742,29 +742,28 @@ embedRenderMessage ''UniWorX ''FirmUserAction id
|
||||
|
||||
data FirmUserActionData = FirmUserActNotifyData
|
||||
| FirmUserActResetSupervisionData
|
||||
{ firmUserActResetKeepOldSupers :: Maybe Bool
|
||||
-- , firmUserActResetMutualSupervision :: Maybe Bool
|
||||
{ firmUserActResetSupers :: Maybe Bool
|
||||
}
|
||||
| FirmUserActSetSupervisorData
|
||||
{ firmUserActSetSuperNames :: Maybe (Set Text)
|
||||
, firmUserActSetSuperIds :: Maybe [UserId]
|
||||
, firmUserActSetSuperReason :: Maybe Text
|
||||
, firmUserActSetSuperReroute :: Bool
|
||||
, firmUserActSetSuperKeep :: Bool
|
||||
{ firmUserActSetSuperNames :: Maybe (Set Text)
|
||||
, firmUserActSetSuperIds :: Maybe [UserId]
|
||||
, firmUserActSetSuperReason :: Maybe Text
|
||||
, firmUserActSetSuperReroute :: Bool
|
||||
, firmUserActResetSupers :: Maybe Bool
|
||||
}
|
||||
| FirmUserActMkSuperData
|
||||
{ firmUserActMkSuperReroute :: Maybe Bool }
|
||||
{ firmUserActMkSuperReroute :: Maybe Bool }
|
||||
| FirmUserActChangeDetailsData
|
||||
{ firmUserActDetailPriority :: Maybe Int
|
||||
, firmUserActDetailReason :: Maybe Text
|
||||
{ firmUserActDetailPriority :: Maybe Int
|
||||
, firmUserActDetailReason :: Maybe Text
|
||||
}
|
||||
| FirmUserActChangeContactData
|
||||
{ firmUserActPostalAddr :: Maybe StoredMarkup
|
||||
, firmUserActUseCompanyPostal :: Maybe Bool
|
||||
, firmUserActPostalPref :: Maybe Bool
|
||||
{ firmUserActPostalAddr :: Maybe StoredMarkup
|
||||
, firmUserActUseCompanyPostal :: Maybe Bool
|
||||
, firmUserActPostalPref :: Maybe Bool
|
||||
}
|
||||
| FirmUserActRemoveData
|
||||
{ firmUserActRemoveKeepSuper :: Bool
|
||||
{ firmUserActRemoveSupers :: Bool
|
||||
}
|
||||
deriving (Eq, Ord, Show, Generic)
|
||||
|
||||
@ -968,25 +967,24 @@ mkFirmUserTable isAdmin cid = do
|
||||
acts = mconcat
|
||||
[ guardMonoid isAdmin $ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData
|
||||
, singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData
|
||||
<$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
|
||||
-- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True )
|
||||
<$> aopt (boolFieldCustom (SomeMessage MsgFirmActResetSupersRemoveAll) (SomeMessage MsgFirmActResetSupersRemoveAps) $ Just $ SomeMessage MsgFirmActResetSupersKeepAll) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
|
||||
, singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData
|
||||
<$> aopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
||||
<*> aopt supervisorsField (fslI MsgFirmSetSupervisor & setTooltip MsgMultiSelectTip) Nothing
|
||||
<*> aopt (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing
|
||||
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False)
|
||||
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False)
|
||||
<*> aopt (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing
|
||||
<*> areq boolField' (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False)
|
||||
<*> aopt (boolFieldCustom (SomeMessage MsgFirmActResetSupersRemoveAll) (SomeMessage MsgFirmActResetSupersRemoveAps) $ Just $ SomeMessage MsgFirmActResetSupersKeepAll) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
|
||||
, singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData
|
||||
<$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True)
|
||||
, singletonMap FirmUserActChangeDetails $ FirmUserActChangeDetailsData
|
||||
<$> aopt intField (fslI MsgCompanyUserPriority & setTooltip MsgCompanyUserPriorityTip) Nothing
|
||||
<*> aopt (textField & cfStrip & addDatalist userReasons) (fslI MsgUserCompanyReason & setTooltip (SomeMessages [SomeMessage MsgUserCompanyReasonTooltip, SomeMessage MsgNullDeletes])) Nothing
|
||||
, singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData
|
||||
<$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
|
||||
<*> aopt boolField' (fslI MsgCompanyUserUseCompanyAddress & setTooltip MsgCompanyUserUseCompanyAddressTip) Nothing
|
||||
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
|
||||
, singletonMap FirmUserActChangeDetails $ FirmUserActChangeDetailsData
|
||||
<$> aopt intField (fslI MsgCompanyUserPriority & setTooltip MsgCompanyUserPriorityTip) Nothing
|
||||
<*> aopt (textField & cfStrip & addDatalist userReasons) (fslI MsgUserCompanyReason & setTooltip (SomeMessages [SomeMessage MsgUserCompanyReasonTooltip, SomeMessage MsgNullDeletes])) Nothing
|
||||
, singletonMap FirmUserActRemove $ FirmUserActRemoveData
|
||||
<$> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False)
|
||||
<$> areq boolField' (fslI MsgFirmActRemoveSupers) (Just True)
|
||||
]
|
||||
dbtParams = DBParamsForm
|
||||
{ dbParamsFormMethod = POST
|
||||
@ -1053,6 +1051,10 @@ postFirmUsersR fsh = do
|
||||
-- return usr
|
||||
<*> mkFirmUserTable isAdmin cid
|
||||
|
||||
let resetSupers :: Maybe Bool -> NonEmpty UserId -> DB Int64
|
||||
resetSupers Nothing _ = return 0
|
||||
resetSupers (Just False) uids = deleteDefaultSupervisorsForUsers [] [] uids
|
||||
resetSupers (Just True ) uids = deleteWhereCount [UserSupervisorUser <-. toList uids]
|
||||
formResult fusrRes $ \case
|
||||
(_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice
|
||||
(FirmUserActNotifyData , uids) -> do
|
||||
@ -1060,9 +1062,7 @@ postFirmUsersR fsh = do
|
||||
redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
|
||||
(FirmUserActResetSupervisionData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do -- set guaranteed to be non-empty due to first case clause
|
||||
runDB $ do
|
||||
delSupers <- if firmUserActResetKeepOldSupers == Just False
|
||||
then deleteDefaultSupervisorsForUsers [] [] uids
|
||||
else return 0
|
||||
delSupers <- resetSupers firmUserActResetSupers uids
|
||||
newSupers <- addDefaultSupervisors Nothing cid uids
|
||||
addMessageI Info $ MsgFirmResetSupervision delSupers newSupers
|
||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||
@ -1081,8 +1081,7 @@ postFirmUsersR fsh = do
|
||||
<li>#{usr}
|
||||
|]
|
||||
in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent)
|
||||
delSupers <- runDB
|
||||
$ bool (deleteDefaultSupervisorsForUsers [cid] [] uids) (return 0) firmUserActSetSuperKeep
|
||||
delSupers <- runDB $ resetSupers firmUserActResetSupers uids
|
||||
<* putMany [UserSupervisor s u firmUserActSetSuperReroute (Just cid) firmUserActSetSuperReason | u <- toList uids, s <- newSupers]
|
||||
addMessageI Success $ MsgFirmSetSupersReport nrUsers nrSupers delSupers
|
||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||
@ -1119,11 +1118,15 @@ postFirmUsersR fsh = do
|
||||
allok = bool Warning Success $ nrChanged == total
|
||||
addMessageI allok $ MsgFirmUserActChangeResult nrChanged total
|
||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||
(FirmUserActRemoveData{}, Set.toList -> uids) -> do
|
||||
(nrUc, nrSuper, nrSubs) <- runDB $ deleteCompanyUser cid uids
|
||||
(FirmUserActRemoveData{..}, Set.toList -> uids) -> do
|
||||
let optRemove = if firmUserActRemoveSupers then id else const $ return 0
|
||||
(nrUc, nrSuper, nrSubs) <- runDB $ (,,)
|
||||
<$> deleteWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids]
|
||||
<*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor <-. uids])
|
||||
<*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorUser <-. uids])
|
||||
let total = fromIntegral $ length uids
|
||||
allok = bool Warning Success $ nrUc == total
|
||||
addMessageI allok $ MsgFirmuserActRemoveResult nrUc nrSuper nrSubs
|
||||
allok = bool Warning Success $ total == nrUc
|
||||
addMessageI allok $ someMessages [MsgFirmUserActRemoveResult nrUc, MsgFirmRemoveSupervision nrSuper nrSubs]
|
||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||
|
||||
formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupervisors, FirmActChangeContactFirm, FirmActChangeContactUser]
|
||||
@ -1153,7 +1156,7 @@ data FirmSuperActionData = FirmSuperActNotifyData
|
||||
, firmSuperActSwitchReroute :: Maybe Bool
|
||||
}
|
||||
| FirmSuperActRMSuperDefData
|
||||
{ firmSuperActRMSuperActive :: Maybe Bool }
|
||||
{ firmSuperActRMSuperActive :: Bool }
|
||||
|
||||
deriving (Eq, Ord, Show, Generic)
|
||||
|
||||
@ -1296,11 +1299,11 @@ mkFirmSuperTable isAdmin cid = do
|
||||
acts = mconcat
|
||||
[ guardMonoid isAdmin $ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData
|
||||
, singletonMap FirmSuperActSwitchSuper $ FirmSuperActSwitchSuperData
|
||||
<$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmSuperDefault) (Just $ Just True)
|
||||
<*> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultReroute) Nothing
|
||||
<$> aopt boolField' (fslI MsgFirmSuperDefault) (Just $ Just True)
|
||||
<*> aopt boolField' (fslI MsgTableIsDefaultReroute) Nothing
|
||||
<* aformMessage msgSupervisorUnchanged
|
||||
, singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData
|
||||
<$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True)
|
||||
<$> areq boolField' (fslI MsgFirmSuperActRMSuperActive) (Just True)
|
||||
]
|
||||
dbtParams = DBParamsForm
|
||||
{ dbParamsFormMethod = POST
|
||||
@ -1344,19 +1347,14 @@ postFirmSupersR fsh = do
|
||||
formResult fsprRes $ \case
|
||||
(_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice
|
||||
(FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do
|
||||
(nrRmSuper,nrRmActual) <- runDB $ (,)
|
||||
let optRemove = if firmSuperActRMSuperActive then id else const $ return 0
|
||||
(nrRmSuper,nrRmSupers,nrRmSubs) <- runDB $ (,,)
|
||||
<$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False]
|
||||
<*> if firmSuperActRMSuperActive /= Just True
|
||||
then return 0
|
||||
else E.deleteCount $ do
|
||||
spr <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ spr E.^. UserSupervisorSupervisor `E.in_` E.vals uids
|
||||
E.&&. E.exists (do
|
||||
usr <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid
|
||||
E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
|
||||
)
|
||||
addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual
|
||||
<*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorSupervisor <-. uids])
|
||||
<*> optRemove (deleteWhereCount [UserSupervisorCompany ==. Just cid, UserSupervisorUser <-. uids])
|
||||
let total = fromIntegral $ length uids
|
||||
allok = bool Warning Success $ total == nrRmSuper
|
||||
addMessageI allok $ someMessages [MsgRemoveSupervisors nrRmSuper, MsgFirmRemoveSupervision nrRmSupers nrRmSubs]
|
||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||
(FirmSuperActSwitchSuperData{..}, Set.toList -> uids) -> do
|
||||
let (fltrSpr, changes) = case (firmSuperActSwitchSuper, firmSuperActSwitchReroute) of
|
||||
|
||||
@ -20,6 +20,9 @@ import Control.Concurrent.STM.Delay
|
||||
|
||||
import System.Environment (lookupEnv) -- while git version number is not working
|
||||
|
||||
import qualified Database.Esqueleto.Experimental as E
|
||||
import qualified Database.Esqueleto.PostgreSQL as E (now_)
|
||||
|
||||
-- import Data.FileEmbed (embedStringFile)
|
||||
|
||||
getHealthR :: Handler TypedContent
|
||||
@ -114,10 +117,16 @@ getInstanceR = do
|
||||
getStatusR :: Handler Html
|
||||
getStatusR = do
|
||||
starttime <- getsYesod appStartTime
|
||||
(currtime, env_version) <- liftIO $ (,) <$> getCurrentTime <*> lookupEnv "VERSION_NR"
|
||||
dbTime <- runDBRead $ E.selectOne $ return E.now_
|
||||
(currtime,env_version) <- liftIO $ (,) <$> getCurrentTime <*> lookupEnv "VERSION_NR"
|
||||
-- ft <- formatTime' "%Y-%m-%d %H:%M:%S" currtime
|
||||
let diffTime :: UTCTime -> Text
|
||||
diffTime = pack . iso8601Show . calendarTimeTime . fromIntegral . truncate . diffUTCTime currtime
|
||||
diffTime t =
|
||||
let tdiff = diffUTCTime currtime t
|
||||
in if 64 > abs tdiff
|
||||
then tshow tdiff
|
||||
else pack . iso8601Show . calendarTimeTime . fromIntegral $ truncate tdiff
|
||||
|
||||
withUrlRenderer
|
||||
[hamlet|
|
||||
$doctype 5
|
||||
@ -129,8 +138,13 @@ getStatusR = do
|
||||
<p>
|
||||
Environment version #{env_ver}
|
||||
<p>
|
||||
Current Time <br>
|
||||
Current Application Time <br>
|
||||
#{show currtime} <br>
|
||||
$maybe dbtval <- dbTime
|
||||
$with dbt <- E.unValue dbtval
|
||||
Current Database Time <br>
|
||||
#{show dbt} #
|
||||
Difference: #{diffTime dbt} <br>
|
||||
<p>
|
||||
Instance Start <br>
|
||||
#{show starttime} #
|
||||
|
||||
@ -96,12 +96,12 @@ mkQualificationAllTable isAdmin = do
|
||||
maybeCell (qualificationDescription quali) markupCellLargeModal
|
||||
, sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $
|
||||
foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration)
|
||||
, sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $
|
||||
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin)
|
||||
, sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) $ \row ->
|
||||
let elearnstart = row ^. resultAllQualification . _qualificationElearningStart
|
||||
reminder = row ^. resultAllQualification . _qualificationRefreshReminder
|
||||
in tickmarkCell $ elearnstart && isJust reminder
|
||||
, sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $
|
||||
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin)
|
||||
, sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
|
||||
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder)
|
||||
, sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip)
|
||||
@ -543,7 +543,7 @@ postQualificationR sid qsh = do
|
||||
Ex.groupBy (qblock Ex.^. QualificationUserBlockReason)
|
||||
let countRows' :: Ex.SqlExpr (Ex.Value Int64) = Ex.countRows
|
||||
Ex.orderBy [Ex.desc countRows']
|
||||
Ex.limit 7
|
||||
Ex.limit 9
|
||||
pure (qblock Ex.^. QualificationUserBlockReason)
|
||||
mkOption :: Ex.Value Text -> Option Text
|
||||
mkOption (Ex.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
|
||||
|
||||
@ -191,18 +191,19 @@ postUsersR = do
|
||||
fmap (setOf $ folded . _Value . _Just) . Ex.select . Ex.distinct $ do
|
||||
usrc <- Ex.from $ Ex.table @UserSupervisor
|
||||
E.where_ $ E.isJust (usrc E.^. UserSupervisorReason)
|
||||
Ex.limit 9
|
||||
return $ usrc E.^. UserSupervisorReason
|
||||
acts :: Map UserAction (AForm Handler UserActionData)
|
||||
acts = mconcat
|
||||
[ singletonMap UserLdapSync $ pure UserLdapSyncData
|
||||
, singletonMap UserAvsSync $ pure UserAvsSyncData
|
||||
, singletonMap UserAddSupervisor $ UserAddSupervisorData
|
||||
<$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
||||
<*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
|
||||
<$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
||||
<*> apopt boolField' (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False)
|
||||
<*> aopt (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing
|
||||
, singletonMap UserSetSupervisor $ UserSetSupervisorData
|
||||
<$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
||||
<*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
|
||||
<$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
||||
<*> apopt boolField' (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False)
|
||||
<*> aopt (textField & cfStrip & addDatalist superReasons) (fslI MsgUserSupervisorReason & setTooltip MsgUserSupervisorReasonTooltip) Nothing
|
||||
, singletonMap UserRemoveSupervisor $ pure UserRemoveSupervisorData
|
||||
, singletonMap UserRemoveSubordinates $ pure UserRemoveSubordinatesData
|
||||
|
||||
@ -222,7 +222,8 @@ defaultSupervisorReasonFilter :: [Filter UserSupervisor]
|
||||
defaultSupervisorReasonFilter =
|
||||
[UserSupervisorReason ==. Nothing]
|
||||
||. [UserSupervisorReason ==. Just (tshow SupervisorReasonCompanyDefault)]
|
||||
-- ||. [UserSupervisorReason <-. [Just $ tshow r | r <- [SupervisorReasonCompanyDefault, SupervisorReasonAvsSuperior]]]
|
||||
||. [UserSupervisorReason ==. Just (tshow SupervisorReasonAvsSuperior )]
|
||||
-- ||. [UserSupervisorReason <-. Nothing : [Just $ tshow r | r <- [SupervisorReasonCompanyDefault, SupervisorReasonAvsSuperior]]] -- Does <-. work with Nothing?
|
||||
|
||||
-- | remove supervisors for given users; maybe restricted to those linked to given companies or supervisors
|
||||
deleteDefaultSupervisorsForUsers :: [CompanyId] -> [UserId] -> NonEmpty UserId -> DB Int64
|
||||
@ -232,14 +233,6 @@ deleteDefaultSupervisorsForUsers cids sprs usrs =
|
||||
$ bcons (notNull sprs) (UserSupervisorSupervisor <-. sprs)
|
||||
$ (UserSupervisorUser <-. toList usrs) : defaultSupervisorReasonFilter
|
||||
|
||||
-- | deletes user company association and all company related supervision
|
||||
-- WARNING: does not check for admin problems!
|
||||
deleteCompanyUser :: CompanyId -> [UserId] -> DB (Int64, Int64, Int64)
|
||||
deleteCompanyUser cid uids = (,,)
|
||||
<$> deleteWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids]
|
||||
<*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorSupervisor <-. uids) : defaultSupervisorReasonFilter)
|
||||
<*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorUser <-. uids) : defaultSupervisorReasonFilter)
|
||||
|
||||
-- | retrieve maximum company user priority fo a user
|
||||
getCompanyUserMaxPrio :: UserId -> DB Int
|
||||
getCompanyUserMaxPrio uid = do
|
||||
|
||||
@ -67,7 +67,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
|
||||
now <- liftIO getCurrentTime
|
||||
let nowaday = utctDay now
|
||||
-- send second reminders first, before enqueing even more, but only for users with currently open LMS and still valid Qualificiations
|
||||
ifNothingM (qualificationRefreshReminder quali) () $ \remindPeriod -> do
|
||||
whenIsJust (qualificationRefreshReminder quali) $ \remindPeriod -> do
|
||||
let remindDate = addGregorianDurationClip remindPeriod nowaday
|
||||
reminders <- E.select $ do
|
||||
(luser :& quser) <- E.from $ E.table @LmsUser `E.innerJoin` E.table @QualificationUser
|
||||
@ -91,33 +91,40 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
|
||||
, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = True }
|
||||
}
|
||||
_ -> return ()
|
||||
|
||||
ifNothingM (qualificationRefreshWithin quali) () $ \renewalPeriod -> do -- no refreshWithin, no first reminders
|
||||
let renewalDate = addGregorianDurationClip renewalPeriod nowaday
|
||||
renewalUsers <- E.select $ do
|
||||
quser <- E.from $ E.table @QualificationUser
|
||||
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
||||
E.&&. quser E.^. QualificationUserScheduleRenewal
|
||||
E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
|
||||
E.&&. (quser `qualificationValid` now)
|
||||
E.&&. E.notExists (do
|
||||
luser <- E.from $ E.table @LmsUser
|
||||
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
|
||||
E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
|
||||
E.&&. E.isNothing (luser E.^. LmsUserEnded)
|
||||
)
|
||||
pure quser
|
||||
let usr_job :: Entity QualificationUser -> Job
|
||||
usr_job quser =
|
||||
let uid = quser ^. _entityVal . _qualificationUserUser
|
||||
uex = quser ^. _entityVal . _qualificationUserValidUntil
|
||||
in if qualificationElearningStart quali
|
||||
then JobLmsEnqueueUser { jQualification = qid, jUser = uid }
|
||||
else JobUserNotification { jRecipient = uid, jNotification =
|
||||
NotificationQualificationExpiry { nQualification = qid, nExpiry = uex }
|
||||
}
|
||||
forM_ renewalUsers (queueDBJob . usr_job)
|
||||
logInterface "LMS" (qshort <> "-enq") True (Just $ length renewalUsers) ""
|
||||
-- send initial reminders
|
||||
whenIsJust (qualificationRefreshWithin quali) $ \renewalPeriod -> do -- no refreshWithin, no first reminders
|
||||
let renewalDate = addGregorianDurationClip renewalPeriod nowaday
|
||||
renewalUsers <- E.select $ do
|
||||
quser <- E.from $ E.table @QualificationUser
|
||||
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
||||
E.&&. quser E.^. QualificationUserScheduleRenewal
|
||||
E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate
|
||||
E.&&. (quser `qualificationValid` now)
|
||||
E.&&. E.notExists (do
|
||||
luser <- E.from $ E.table @LmsUser
|
||||
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
|
||||
E.&&. luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
|
||||
E.&&. E.isNothing (luser E.^. LmsUserEnded)
|
||||
)
|
||||
pure quser
|
||||
let usr_job :: Entity QualificationUser -> Maybe Job
|
||||
usr_job quser =
|
||||
let uid = quser ^. _entityVal . _qualificationUserUser
|
||||
uex = quser ^. _entityVal . _qualificationUserValidUntil
|
||||
unf = quser ^. _entityVal . _qualificationUserLastNotified
|
||||
nfy_cutoff = addGregorianDurationClip renewalPeriod $ utctDay unf
|
||||
do_notify = uex > nfy_cutoff || (uex == nfy_cutoff && utctDayTime now >= utctDayTime unf)
|
||||
in if
|
||||
| qualificationElearningStart quali -- repetition avoided since LmsUser does not exist
|
||||
-> Just $ JobLmsEnqueueUser { jQualification = qid, jUser = uid }
|
||||
| do_notify -- repetition avoided by QualificationUserLastNotified
|
||||
-> Just $ JobUserNotification
|
||||
{ jRecipient = uid
|
||||
, jNotification = NotificationQualificationExpiry { nQualification = qid, nExpiry = uex }
|
||||
}
|
||||
| otherwise -> Nothing
|
||||
forM_ renewalUsers (flip whenIsJust queueDBJob . usr_job)
|
||||
logInterface "LMS" (qshort <> "-enq") True (Just $ length renewalUsers) ""
|
||||
|
||||
dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX
|
||||
dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||
-- SPDX-FileCopyrightText: 2022-24 Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
@ -22,24 +22,22 @@ import Text.Hamlet
|
||||
|
||||
|
||||
dispatchNotificationQualificationExpiry :: QualificationId -> Day -> UserId -> Handler ()
|
||||
dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = userMailT jRecipient $ do
|
||||
(recipient@User{..}, Qualification{..}) <- liftHandler . runDB $ (,)
|
||||
dispatchNotificationQualificationExpiry nQualification dExpiry jRecipient = do
|
||||
now <- liftIO getCurrentTime
|
||||
encRecipient :: CryptoUUIDUser <- liftHandler $ encrypt jRecipient
|
||||
(recipient@User{..}, Qualification{..}) <- runDB $ (,)
|
||||
<$> getJust jRecipient
|
||||
<*> getJust nQualification
|
||||
|
||||
encRecipient :: CryptoUUIDUser <- liftHandler $ encrypt jRecipient
|
||||
let entRecipient = Entity jRecipient recipient
|
||||
qname = CI.original qualificationName
|
||||
expiryDate <- formatTimeUser SelFormatDate dExpiry $ Just entRecipient
|
||||
|
||||
$logDebugS "LMS" $ "Notify " <> tshow encRecipient <> " about expiry of qualification " <> qname
|
||||
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI $ MsgMailSubjectQualificationExpiry qname
|
||||
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
|
||||
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet")
|
||||
userMailT jRecipient $ do
|
||||
expiryDate <- formatTimeUser SelFormatDate dExpiry $ Just entRecipient
|
||||
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
||||
setSubjectI $ MsgMailSubjectQualificationExpiry qname
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationExpiry.hamlet")
|
||||
runDB $ updateBy (UniqueQualificationUser nQualification jRecipient) [QualificationUserLastNotified =. now]
|
||||
$logDebugS "LMS" $ "Notified " <> tshow encRecipient <> " about soonish expiry of qualification " <> qname
|
||||
|
||||
|
||||
dispatchNotificationQualificationExpired :: QualificationId -> UserId -> Handler ()
|
||||
@ -81,7 +79,7 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do
|
||||
$logInfoS "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname
|
||||
else
|
||||
$logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> qname
|
||||
else $logInfoS "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname
|
||||
else $logInfoS "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname -- should no longer happen to using quserToNotify filter in Jobs.Handler.Lms, but sometimes does after restarts
|
||||
_ -> $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> tshow nQualification
|
||||
|
||||
|
||||
|
||||
@ -146,8 +146,7 @@ dispatchJobSynchroniseAvsLicences = JobHandlerException $ do -- when (synchLevel
|
||||
, avsLicenceSynchMaxChanges = maxChanges
|
||||
} <- getsYesod $ view _appAvsLicenceSynchConf
|
||||
|
||||
let -- TODO: enable a cron job by setting
|
||||
procLic :: AvsLicence -> Bool -> Set AvsPersonId -> Handler ()
|
||||
let procLic :: AvsLicence -> Bool -> Set AvsPersonId -> Handler ()
|
||||
procLic aLic up apids
|
||||
| n <- Set.size apids, n > 0 =
|
||||
let subtype = Text.cons (bool '↧' '↥' up) $ Text.singleton $ licence2char aLic
|
||||
|
||||
@ -5,10 +5,15 @@ $#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
Bitte beachten, dass Ansprechpartner-Beziehung unabhängig von Firmenzugehörigkeit zwischen Einzelpersonen bestehen.
|
||||
Daraus folgt zum Beispiel, dass wenn <em>x</em> ein Standard-Ansprechpartner für Firma <em>a</em> ist
|
||||
und wenn <em>y</em> sowohl Firma <em>a</em> als auch <em>b</em> angehört,
|
||||
dass dann <em>x</em> als firmenfremd in der Liste der Ansprechpartner von Firma <em>b</em> angezeigt wird.
|
||||
<p>
|
||||
Bitte beachten: Ansprechpartner-Beziehung bestehen unabhängig von Firmenzugehörigkeit zwischen Einzelpersonen! #
|
||||
|
||||
<p>
|
||||
Daraus folgt zum Beispiel, dass wenn <em>x</em> ein Standard-Ansprechpartner für Firma <em>a</em> ist #
|
||||
und wenn <em>y</em> sowohl Firma <em>a</em> als auch <em>b</em> angehört, #
|
||||
dass <em>x</em> als firmenfremd in der Liste der Ansprechpartner von Firma <em>b</em> angezeigt wird. #
|
||||
Dies kann hier mit der Aktion "Firmenansprechpartner entfernen" nicht geändert werden, #
|
||||
da die Ansprechpartnerbeziehung ja über eine andere Firma weiter existiert.
|
||||
|
||||
^{firmContactInfo}
|
||||
|
||||
|
||||
@ -5,9 +5,12 @@ $#
|
||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
<section>
|
||||
Note that supervision is company independent.
|
||||
For example, if <em>x</em> is a regular supervisor for company <em>a</em> and <em>y</em> belongs to companies <em>a</em> and <em>b</em>,
|
||||
then <em>x</em> will be listed as a foreign supervisor for company <em>b</em>.
|
||||
<p>
|
||||
Note that supervisionship is company independent! #
|
||||
<p>
|
||||
For example, if <em>x</em> is a regular supervisor for company <em>a</em> and <em>y</em> belongs to companies <em>a</em> and <em>b</em>, #
|
||||
then <em>x</em> will be listed as a foreign supervisor for company <em>b</em>. #
|
||||
This cannot be changed through action "Remove default supervisor" here, since the external supervisionship persists.
|
||||
|
||||
^{firmContactInfo}
|
||||
|
||||
|
||||
Reference in New Issue
Block a user