fix(firm): fix #157 by removing redundant duplicated code in firm user and supervision handling
This commit is contained in:
parent
d65fb2f4cd
commit
28e2739e51
@ -27,11 +27,16 @@ FirmActChangeContactFirmResult: Firmenkontaktinformationen geändert. Betrifft n
|
||||
FirmUserActNotify: Mitteilung versenden
|
||||
FirmUserActResetSupervision: Ansprechpartner auf Firmenstandard zurücksetzen
|
||||
FirmUserActSetSupervisor: Ansprechpartner ändern
|
||||
FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern
|
||||
FirmUserActChangeDetails: Firmenassoziation bearbeiten
|
||||
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.")}
|
||||
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)}
|
||||
FirmUserActMkSuper: Zum Firmenansprechpartner ernennen
|
||||
FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern
|
||||
FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{bool mempty (", " <> tshow rem <> " zuvor gelöscht") (rem > 0)}
|
||||
FirmSuperActNotify: Mitteilung versenden
|
||||
FirmSuperActSwitchSuper: Standard Firmenansprechpartner abändern
|
||||
@ -57,5 +62,9 @@ TableIsDefaultSupervisor: Standardansprechpartner
|
||||
TableIsDefaultReroute: Standardumleitung
|
||||
FormFieldPostal: Benachrichtigungseinstellung
|
||||
FormFieldPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner
|
||||
FirmUserChanges n@Int64: Benachrichtigungseinstellung für #{n} Firmenangehörige wurden geändert
|
||||
FirmSupervisionKeyData: Kennzahlen Ansprechpartner
|
||||
FirmSupervisionKeyData: Kennzahlen Ansprechpartner
|
||||
CompanyUserPriority: Firmenpriorität
|
||||
CompanyUserPriorityTip: Firmenpriorität ist lediglich relativ zu anderen Firmenassoziation der Person
|
||||
CompanyUserUseCompanyAddress: Verwendet Firmenkontaktaddresse
|
||||
CompanyUserUseCompanyAddressTip: sofern im Benutzer keine Postanschrift hinterlegt ist
|
||||
CompanyUserUseCompanyPostalError: Postalische Adresse muss leer bleiben, damit die Firmenanschrift genutzt wird!
|
||||
|
||||
@ -27,15 +27,20 @@ FirmActChangeContactFirmResult: Company contact data changed, affecting future c
|
||||
FirmUserActNotify: Send message
|
||||
FirmUserActResetSupervision: Reset supervisors to company default
|
||||
FirmUserActSetSupervisor: Change supervision
|
||||
FirmUserActChangeContact: Change contact data for selected company associates
|
||||
FirmUserActChangeDetails: Edit company association
|
||||
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.")}
|
||||
FirmNewSupervisor: Appoint new individual supervisors
|
||||
FirmSetSupervisor: Add existing supervisors
|
||||
FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: #{nspr} individal supervisors set for #{nusr} company associates#{bool "." (" and " <> tshow nrem <> " other individual supervisions terminated.") (nrem >0)}
|
||||
FirmSetSupersReport nusr nspr nrem: #{nspr} individual supervisors set for #{nusr} company associates#{bool "." (" and " <> tshow nrem <> " other individual supervisions terminated.") (nrem >0)}
|
||||
FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> tshow rem <> " deleted before") (rem > 0)}
|
||||
FirmUserActChangeContact: Change contact data for selected company associates
|
||||
FirmUserActMkSuper: Mark as company supervisor
|
||||
FirmSuperActNotify: Send message
|
||||
FirmSuperActSwitchSuper: Change default company supervisor
|
||||
FirmSuperActSwitchSuperInfo: Does not affect company-external supervisors and does not change any active individal supervisions. Additionally use reset action, if desired.
|
||||
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
|
||||
FirmsNotification: Send company notification e-mail
|
||||
@ -57,5 +62,9 @@ TableIsDefaultSupervisor: Default supervisor
|
||||
TableIsDefaultReroute: Default reroute
|
||||
FormFieldPostal: Notification type
|
||||
FormFieldPostalTip: Affects all notifications to this person, not just reroutes to this supervisor
|
||||
FirmUserChanges n: Notification settings changed for #{n} company associates
|
||||
FirmSupervisionKeyData: Supervision key data
|
||||
FirmSupervisionKeyData: Supervision key data
|
||||
CompanyUserPriority: Company priority
|
||||
CompanyUserPriorityTip: Company priority is relative to other company associations for a user
|
||||
CompanyUserUseCompanyAddress: Use company postal address
|
||||
CompanyUserUseCompanyAddressTip: if and only if the postal address of the user is empty
|
||||
CompanyUserUseCompanyPostalError: Individual postal address must left empty for the company address to be used!
|
||||
|
||||
@ -12,7 +12,7 @@ QualificationAuditDurationTooltip n@Int: Optionaler Zeitraum zur Löschung von E
|
||||
QualificationAuditDurationReuseError: Diese Qualifikation nutzt das E‑Learning einer anderen Qualifikation, für die derzeit keinen Löschzeitraum konfiguriert wurde.
|
||||
QualificationRefreshWithin: Erneurerungszeitraum
|
||||
QualificationRefreshWithinTooltip: Optionaler Zeitraum vor Ablauf für automatischen Start des E‑Learnings und Versand einer Benachrichtigung per Brief oder Email.
|
||||
QualificationRefreshReminder: 2. Erinnerung
|
||||
QualificationRefreshReminder: Zweite Erinnerung
|
||||
QualificationRefreshReminderTooltip: Optionaler Zeitraum vor Ablauf zur Versendung einer zweiten Erinnerung per Brief oder Email mit identischen Zugangsdaten, sofern in diesem Zeitraum vor Ablauf noch keine Ablaufbenachrichtigung versendet wurde.
|
||||
QualificationElearningStart: Wird das E‑Learning automatisch gestartet?
|
||||
QualificationElearningRenew: Verlängert ein erfolgreiches E‑Learning die Qualifikation automatisch um die reguläre Gültigkeitsdauer?
|
||||
|
||||
@ -12,7 +12,7 @@ QualificationAuditDurationTooltip n@Int: Optional period for deletion of e‑lea
|
||||
QualificationAuditDurationReuseError: This qualification reuses the e‑learning from another qualification, which has no audit duration configured.
|
||||
QualificationRefreshWithin: Refresh within
|
||||
QualificationRefreshWithinTooltip: Optional period before expiry to start e‑learning and send a notification by post or email.
|
||||
QualificationRefreshReminder: 2. Reminder
|
||||
QualificationRefreshReminder: Second reminder
|
||||
QualificationRefreshReminderTooltip: Optional period before expiry to send a second notification by post or email once more, provided that no renewal notification was sent in this period before expiry.
|
||||
QualificationElearningStart: Is e‑learning automatically started?
|
||||
QualificationElearningRenew: Does successful e‑learning automatically extend a qualification by the default validity period?
|
||||
|
||||
@ -26,4 +26,6 @@ AvsNoLicenceGuest: Keine Fahrberechtigung (Gast, Fahrberechtigungserwerb nicht m
|
||||
|
||||
PaginationSize: Einträge pro Seite
|
||||
PaginationPage: Angzeigte Seite
|
||||
PaginationError: Paginierung Parameter dürfen nicht negativ sein
|
||||
PaginationError: Paginierung Parameter dürfen nicht negativ sein
|
||||
|
||||
NullDeletes: Zum Löschen NULL eingeben.
|
||||
@ -26,4 +26,6 @@ AvsNoLicenceGuest: No driving licence (Guest account, cannot acquire a diriving
|
||||
|
||||
PaginationSize: Rows per Page
|
||||
PaginationPage: Page to show
|
||||
PaginationError: Pagination parameter must not be negative
|
||||
PaginationError: Pagination parameter must not be negative
|
||||
|
||||
NullDeletes: Enter NULL to delete.
|
||||
@ -19,6 +19,7 @@ import Import
|
||||
|
||||
-- import Jobs
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Company
|
||||
import Handler.Utils.Communication
|
||||
import Handler.Utils.Avs (guessAvsUser)
|
||||
|
||||
@ -32,8 +33,8 @@ import qualified Data.CaseInsensitive as CI
|
||||
import Database.Persist.Postgresql
|
||||
import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
||||
import qualified Database.Esqueleto.Legacy as EL (on)
|
||||
import qualified Database.Esqueleto.PostgreSQL as E
|
||||
import qualified Database.Esqueleto.Legacy as EL (on) -- needed for legacy join expected by dbTable
|
||||
-- import qualified Database.Esqueleto.PostgreSQL as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
@ -83,6 +84,7 @@ data FirmActionData = FirmActNotifyData
|
||||
}
|
||||
| FirmActChangeContactUserData
|
||||
{ firmActCCUPostalAddr :: Maybe StoredMarkup
|
||||
, firmActCCUUseCompanyPostal :: Maybe Bool
|
||||
, firmActCCUPostalPref :: Maybe Bool
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
@ -92,8 +94,8 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts)
|
||||
where
|
||||
mkAct True FirmActNotify = singletonMap FirmActNotify $ pure FirmActNotifyData
|
||||
mkAct _ FirmActResetSupervision = singletonMap FirmActResetSupervision $ FirmActResetSupervisionData
|
||||
<$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
|
||||
<*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True )
|
||||
<$> aopt boolField' (fslI MsgFirmActResetSuperKeep) (Just $ Just False)
|
||||
<*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True )
|
||||
mkAct _ FirmActAddSupervisors = singletonMap FirmActAddSupervisors $ FirmActAddSupervisorsData
|
||||
<$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
|
||||
<*> areq checkBoxField (fslI MsgTableIsDefaultReroute) (Just True)
|
||||
@ -103,10 +105,11 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts)
|
||||
mkAct _ FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData
|
||||
<$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing
|
||||
<*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUtilEmptyNoChangeTip) Nothing
|
||||
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
|
||||
<*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFirmDefaultPreferenceInfo) Nothing
|
||||
<* aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive))
|
||||
mkAct _ FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData
|
||||
<$> 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
|
||||
mkAct _ _ = mempty
|
||||
ucdefSuperReasons :: HandlerFor UniWorX (OptionList Text)
|
||||
@ -152,7 +155,7 @@ firmActionHandler route isAdmin = flip formResult faHandler
|
||||
E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser
|
||||
)
|
||||
else return 0
|
||||
newSupers <- addDefaultSupervisorsFor Nothing madId (firmActResetMutualSupervision /= Just False) fids
|
||||
newSupers <- addDefaultSupervisorsFor (Just $ tshow SupervisorReasonCompanyDefault) madId (firmActResetMutualSupervision /= Just False) fids
|
||||
addMessageI Success $ MsgFirmResetSupervision delSupers newSupers
|
||||
reloadKeepGetParams route -- reload to reflect changes
|
||||
|
||||
@ -191,21 +194,30 @@ firmActionHandler route isAdmin = flip formResult faHandler
|
||||
addMessageI Success MsgFirmActChangeContactFirmResult
|
||||
reloadKeepGetParams route
|
||||
|
||||
faHandler (FirmActChangeContactUserData{..}, Set.toList -> [cid]) =
|
||||
let changes = catMaybes
|
||||
[ (UserPostAddress E.=.) . E.justVal <$> canonical firmActCCUPostalAddr -- note that Nothing means no change and not delete address!
|
||||
, (UserPrefersPostal E.=.) . E.val <$> firmActCCUPostalPref
|
||||
]
|
||||
in unless (null changes) $ do
|
||||
nrChanged <- runDB $ E.updateCount $ \usr -> do
|
||||
E.set usr changes
|
||||
E.where_ $ E.exists $ do
|
||||
usrCmpy <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid
|
||||
E.&&. usrCmpy E.^. UserCompanyUser E.==. usr E.^. UserId
|
||||
addMessageI Success $ MsgFirmUserChanges nrChanged
|
||||
reloadKeepGetParams route -- reload to reflect changes
|
||||
|
||||
faHandler (FirmActChangeContactUserData{..}, Set.toList -> [cid])
|
||||
| firmActCCUUseCompanyPostal == Just True, isJust firmActCCUPostalAddr =
|
||||
addMessageI Error MsgCompanyUserUseCompanyPostalError
|
||||
| otherwise = do
|
||||
let changes = catMaybes
|
||||
[ toMaybe (firmActCCUUseCompanyPostal == Just True) (UserPostAddress E.=. E.nothing) -- precondition ensures that only one update applies for UserPostAddress
|
||||
, (UserPostAddress E.=.) . E.justVal <$> canonical firmActCCUPostalAddr -- note that Nothing means no change and not delete address!
|
||||
, (UserPrefersPostal E.=.) . E.val <$> firmActCCUPostalPref
|
||||
]
|
||||
(total, nrChanged) <- runDB $ do
|
||||
nrUsrChange <- E.updateCount $ \usr -> do
|
||||
E.set usr changes
|
||||
E.where_ $ E.exists $ do
|
||||
usrCmpy <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid
|
||||
E.&&. usrCmpy E.^. UserCompanyUser E.==. usr E.^. UserId
|
||||
nrUseComp <- case firmActCCUUseCompanyPostal of
|
||||
Just x -> updateWhereCount [UserCompanyCompany ==. cid] [UserCompanyUseCompanyAddress =. x]
|
||||
Nothing -> return 0
|
||||
nrCid <- count [UserCompanyCompany ==. cid]
|
||||
return (fromIntegral nrCid, max nrUsrChange nrUseComp)
|
||||
let allok = bool Warning Success $ nrChanged == total
|
||||
addMessageI allok $ MsgFirmUserActChangeResult nrChanged total
|
||||
reloadKeepGetParams route -- reload to reflect changes
|
||||
faHandler _ = addMessageI Error MsgErrorUnknownFormAction
|
||||
|
||||
|
||||
@ -256,81 +268,6 @@ resetSupervisors cid employees = do
|
||||
nr_add <- addDefaultSupervisors superReasonComDef cid employees
|
||||
return $ max nr_del nr_add
|
||||
|
||||
-- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company
|
||||
addDefaultSupervisors :: Maybe Text -> CompanyId -> NonEmpty UserId -> DB Int64
|
||||
addDefaultSupervisors reason cid employees = do
|
||||
E.insertSelectWithConflictCount UniqueUserSupervisor
|
||||
(do
|
||||
(spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees
|
||||
E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid
|
||||
E.&&. spr E.^. UserCompanySupervisor
|
||||
E.distinct $ return $ UserSupervisor
|
||||
E.<# (spr E.^. UserCompanyUser)
|
||||
E.<&> usr
|
||||
E.<&> (spr E.^. UserCompanySupervisorReroute)
|
||||
E.<&> E.justVal cid
|
||||
E.<&> E.val reason
|
||||
)
|
||||
(\old new ->
|
||||
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
|
||||
, UserSupervisorCompany E.=. E.justVal cid
|
||||
, UserSupervisorReason E.=. E.coalesce [old E.^. UserSupervisorReason, new E.^. UserSupervisorReason] -- keep any existing reason
|
||||
])
|
||||
|
||||
-- like `addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual
|
||||
addDefaultSupervisorsFor :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Maybe UserId -> Bool -> mono -> DB Int64
|
||||
addDefaultSupervisorsFor reason mbSuperId mutualSupervision cids = do
|
||||
E.insertSelectWithConflictCount UniqueUserSupervisor
|
||||
(do
|
||||
(spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
|
||||
E.where_ $ E.and $ guardMonoid (not mutualSupervision)
|
||||
[ E.not_ $ usr E.^. UserCompanySupervisor ]
|
||||
<> maybeEmpty mbSuperId (\sprId -> [E.exists $ do
|
||||
superv <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ superv E.^. UserSupervisorSupervisor E.==. E.val sprId
|
||||
E.&&. superv E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser
|
||||
])
|
||||
<> [ spr E.^. UserCompanySupervisor
|
||||
, spr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
, usr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
]
|
||||
E.distinct $ return $ UserSupervisor
|
||||
E.<# (spr E.^. UserCompanyUser)
|
||||
E.<&> (usr E.^. UserCompanyUser)
|
||||
E.<&> (spr E.^. UserCompanySupervisorReroute)
|
||||
E.<&> E.just (spr E.^. UserCompanyCompany)
|
||||
E.<&> E.val reason
|
||||
)
|
||||
(\old new ->
|
||||
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
|
||||
, UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
|
||||
, UserSupervisorReason E.=. E.coalesce [old E.^. UserSupervisorReason, new E.^. UserSupervisorReason] -- keep any existing reason
|
||||
] )
|
||||
|
||||
-- like `addDefaultSupervisors`, but selects all employees of given companies from database
|
||||
addDefaultSupervisorsAll :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Bool -> mono -> DB Int64
|
||||
addDefaultSupervisorsAll reason mutualSupervision cids = do
|
||||
E.insertSelectWithConflictCount UniqueUserSupervisor
|
||||
(do
|
||||
(spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
|
||||
E.where_ $ E.and $ guardMonoid (not mutualSupervision)
|
||||
[ E.not_ $ usr E.^. UserCompanySupervisor ]
|
||||
<> [ spr E.^. UserCompanySupervisor
|
||||
, spr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
, usr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
]
|
||||
E.distinct $ return $ UserSupervisor
|
||||
E.<# (spr E.^. UserCompanyUser)
|
||||
E.<&> (usr E.^. UserCompanyUser)
|
||||
E.<&> (spr E.^. UserCompanySupervisorReroute)
|
||||
E.<&> E.just (spr E.^. UserCompanyCompany)
|
||||
E.<&> E.val reason
|
||||
)
|
||||
(\old new ->
|
||||
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
|
||||
, UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
|
||||
, UserSupervisorReason E.=. E.coalesce [old E.^. UserSupervisorReason, new E.^. UserSupervisorReason] -- keep any existing reason
|
||||
] )
|
||||
|
||||
|
||||
------------------------------
|
||||
@ -808,7 +745,9 @@ data FirmUserAction = FirmUserActNotify
|
||||
| FirmUserActResetSupervision
|
||||
| FirmUserActSetSupervisor
|
||||
| FirmUserActMkSuper
|
||||
| FirmUserActChangeDetails
|
||||
| FirmUserActChangeContact
|
||||
| FirmUserActRemove
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
@ -829,9 +768,17 @@ data FirmUserActionData = FirmUserActNotifyData
|
||||
}
|
||||
| FirmUserActMkSuperData
|
||||
{ firmUserActMkSuperReroute :: Maybe Bool }
|
||||
| FirmUserActChangeDetailsData
|
||||
{ firmUserActDetailPriority :: Maybe Int
|
||||
, firmUserActDetailReason :: Maybe Text
|
||||
}
|
||||
| FirmUserActChangeContactData
|
||||
{ firmUserActPostalAddr :: Maybe StoredMarkup
|
||||
, firmUserActPostalPref :: Maybe Bool
|
||||
{ firmUserActPostalAddr :: Maybe StoredMarkup
|
||||
, firmUserActUseCompanyPostal :: Maybe Bool
|
||||
, firmUserActPostalPref :: Maybe Bool
|
||||
}
|
||||
| FirmUserActRemoveData
|
||||
{ firmUserActRemoveKeepSuper :: Bool
|
||||
}
|
||||
deriving (Eq, Ord, Show, Generic)
|
||||
|
||||
@ -843,7 +790,7 @@ queryUserUser = $(sqlIJproj 2 1)
|
||||
queryUserUserCompany :: UserCompanyTableExpr -> E.SqlExpr (Entity UserCompany)
|
||||
queryUserUserCompany = $(sqlIJproj 2 2)
|
||||
|
||||
type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64) -- , E.Value Bool)
|
||||
type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64, E.Value Bool)
|
||||
|
||||
resultUserUser :: Lens' UserCompanyTableData (Entity User)
|
||||
resultUserUser = _dbrOutput . _1
|
||||
@ -857,8 +804,8 @@ resultUserCompanySupervisors = _dbrOutput . _3 . _unValue
|
||||
resultUserCompanyReroutes :: Lens' UserCompanyTableData Word64
|
||||
resultUserCompanyReroutes = _dbrOutput . _4 . _unValue
|
||||
|
||||
-- resultUserCompanyPrimary :: Lens' UserCompanyTableData Bool
|
||||
-- resultUserCompanyPrimary = _dbrOutput . _5 . _unValue
|
||||
resultUserCompanyPrimary :: Lens' UserCompanyTableData Bool
|
||||
resultUserCompanyPrimary = _dbrOutput . _5 . _unValue
|
||||
|
||||
instance HasEntity UserCompanyTableData User where
|
||||
hasEntity = resultUserUser
|
||||
@ -900,12 +847,12 @@ mkFirmUserTable isAdmin cid = do
|
||||
dbtSQLQuery = \(usr `E.InnerJoin` usrCmp) -> do
|
||||
EL.on $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser
|
||||
E.where_ $ usrCmp E.^. UserCompanyCompany E.==. E.val cid
|
||||
-- let isPrimary = E.notExists (do
|
||||
-- other <- E.from $ E.table @UserCompany
|
||||
-- E.where_ $ other E.^. UserCompanyUser E.==. usrCmp E.^. UserCompanyUser
|
||||
-- E.&&. other E.^. UserCompanyPriority E.>. usrCmp E.^. UserCompanyPriority
|
||||
-- )
|
||||
return (usr, usrCmp, firmCountUserSupervisors usrCmp, firmCountUserSupervisorsReroute usrCmp)
|
||||
let isPrimary = E.notExists (do
|
||||
other <- E.from $ E.table @UserCompany
|
||||
E.where_ $ other E.^. UserCompanyUser E.==. usrCmp E.^. UserCompanyUser
|
||||
E.&&. other E.^. UserCompanyPriority E.>. usrCmp E.^. UserCompanyPriority
|
||||
)
|
||||
return (usr, usrCmp, firmCountUserSupervisors usrCmp, firmCountUserSupervisorsReroute usrCmp, isPrimary)
|
||||
dbtRowKey = queryUserUser >>> (E.^. UserId)
|
||||
dbtProj = dbtProjId
|
||||
dbtColonnade = formColonnade $ mconcat
|
||||
@ -916,8 +863,16 @@ mkFirmUserTable isAdmin cid = do
|
||||
, sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers ) $ \(view resultUserCompanySupervisors -> nr) -> wgtCell $ word2widget nr
|
||||
, sortable (Just "reroutes") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultUserCompanyReroutes -> nr) -> wgtCell $ word2widget nr
|
||||
, sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUserUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
|
||||
, sortable Nothing (i18nCell MsgCompanyUserUseCompanyAddress) $ \row ->
|
||||
let noUsrAddr = isNothing $ row ^. resultUserUser . _userPostAddress
|
||||
useCompA = row ^. resultUserUserCompany . _entityVal . _userCompanyUseCompanyAddress
|
||||
in tickmarkCell $ noUsrAddr && useCompA
|
||||
, colUserEmail
|
||||
, sortable (Just "usr-reason") (i18nCell MsgTableCompanyReason) $ \(view $ resultUserUserCompany . _entityVal . _userCompanyReason -> r) -> cellMaybe textCell r
|
||||
, sortable (Just "priority") (i18nCell MsgCompanyUserPriority) $ \row ->
|
||||
let prio :: Int = row ^. resultUserUserCompany . _entityVal . _userCompanyPriority
|
||||
isPrime = row ^. resultUserCompanyPrimary
|
||||
in numCell prio <> spacerCell <> ifIconCell isPrime IconTop
|
||||
, sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultUserUser -> entUsr) -> cellEditUserModal entUsr
|
||||
]
|
||||
dbtSorting = mconcat
|
||||
@ -929,6 +884,7 @@ mkFirmUserTable isAdmin cid = do
|
||||
, singletonMap "supervisors" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors
|
||||
, singletonMap "reroutes" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute
|
||||
, singletonMap "usr-reason" $ SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyReason)
|
||||
, singletonMap "priority" $ SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyPriority)
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[ single $ fltrUserNameEmail queryUserUser
|
||||
@ -1005,6 +961,13 @@ mkFirmUserTable isAdmin cid = do
|
||||
, prismAForm (singletonFilter "is-primary-company" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmPrimary)
|
||||
]
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
userReasons :: HandlerFor UniWorX (OptionList Text)
|
||||
userReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $
|
||||
fmap (setOf $ folded . _Value . _Just) . E.select . E.distinct $ do
|
||||
usrc <- E.from $ E.table @UserCompany
|
||||
E.where_ $ E.isJust (usrc E.^. UserCompanyReason)
|
||||
E.&&. usrc E.^. UserCompanyCompany E.==. E.val cid
|
||||
return $ usrc E.^. UserCompanyReason
|
||||
superReasons :: HandlerFor UniWorX (OptionList Text)
|
||||
superReasons = fmap (mkOptionList . map (\t -> Option t t t) . Set.toAscList) . runDB $
|
||||
fmap (setOf $ folded . _Value . _Just) . E.select . E.distinct $ do
|
||||
@ -1026,9 +989,15 @@ mkFirmUserTable isAdmin cid = do
|
||||
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (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 postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing
|
||||
<$> 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 FirmUserActRemove $ FirmUserActRemoveData
|
||||
<$> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False)
|
||||
]
|
||||
dbtParams = DBParamsForm
|
||||
{ dbParamsFormMethod = POST
|
||||
@ -1128,20 +1097,45 @@ postFirmUsersR fsh = do
|
||||
<* 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
|
||||
|
||||
(FirmUserActMkSuperData{..}, Set.toList -> uids) -> do
|
||||
nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)]
|
||||
addMessageI Info $ MsgFirmActAddSupersSet nrMkSuper Nothing
|
||||
nrUpd <- runDB $ updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)]
|
||||
addMessageI Success $ MsgFirmActAddSupersSet nrUpd Nothing
|
||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||
(FirmUserActChangeContactData{..}, Set.toList -> uids) ->
|
||||
let changes = catMaybes
|
||||
[ (UserPostAddress =.) . Just <$> canonical firmUserActPostalAddr -- note that Nothing means no change and not delete address!
|
||||
, (UserPrefersPostal =.) <$> firmUserActPostalPref
|
||||
]
|
||||
in unless (null changes) $ do
|
||||
nrChanged <- runDB $ updateWhereCount [UserId <-. uids] changes
|
||||
addMessageI Success $ MsgFirmUserChanges nrChanged
|
||||
(FirmUserActChangeDetailsData{..}, Set.toList -> uids) -> do
|
||||
let upReason = case canonical firmUserActDetailReason of
|
||||
Nothing -> Nothing
|
||||
Just "NULL" -> Just $ UserCompanyReason =. Nothing
|
||||
other -> Just $ UserCompanyReason =. other
|
||||
nrUpd <- runDB $ updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] $ catMaybes [upReason, (UserCompanyPriority =.) <$> firmUserActDetailPriority]
|
||||
let total = fromIntegral $ length uids
|
||||
allok = bool Warning Success $ nrUpd == total
|
||||
addMessageI allok $ MsgFirmUserActChangeDetailsResult nrUpd total
|
||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||
(FirmUserActChangeContactData{..}, Set.toList -> uids)
|
||||
| firmUserActUseCompanyPostal == Just True, isJust firmUserActPostalAddr ->
|
||||
addMessageI Error MsgCompanyUserUseCompanyPostalError
|
||||
| otherwise -> do
|
||||
let changes = catMaybes
|
||||
[ toMaybe (firmUserActUseCompanyPostal == Just True) (UserPostAddress =. Nothing) -- precondition ensures that only one update applies for UserPostAddress
|
||||
, (UserPostAddress =.) . Just <$> canonical firmUserActPostalAddr -- note that Nothing means no change and not delete address!
|
||||
, (UserPrefersPostal =.) <$> firmUserActPostalPref
|
||||
]
|
||||
nrChanged <- runDB $ do
|
||||
nrUsrChange <- updateWhereCount [UserId <-. uids] changes
|
||||
nrUseComp <- case firmUserActUseCompanyPostal of
|
||||
Just x -> updateWhereCount [UserCompanyCompany ==. cid, UserCompanyUser <-. uids] [UserCompanyUseCompanyAddress =. x]
|
||||
Nothing -> return 0
|
||||
return $ max nrUsrChange nrUseComp
|
||||
let total = fromIntegral $ length uids
|
||||
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
|
||||
let total = fromIntegral $ length uids
|
||||
allok = bool Warning Success $ nrUc == total
|
||||
addMessageI allok $ MsgFirmuserActRemoveResult nrUc nrSuper nrSubs
|
||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||
|
||||
formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupervisors, FirmActChangeContactFirm, FirmActChangeContactUser]
|
||||
|
||||
|
||||
@ -439,7 +439,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
|
||||
-- let oldCompDefSuperFltr = mconcat [UserSupervisorCompany ~~. oldCompanyId, UserSupervisorReason ~=. superReasonComDef]
|
||||
-- deleteWhere $ (UserSupervisorSupervisor ==. usrId) : oldCompDefSuperFltr
|
||||
-- oldAPs <- deleteWhereCount $ (UserSupervisorUser ==. usrId) : oldCompDefSuperFltr
|
||||
-- addCompanySupervisors newCompanyId usrId
|
||||
-- addDefaultSupervisors newCompanyId usrId
|
||||
-- newAPs <- count $ (UserSupervisorUser ==. usrId) : (UserSupervisorCompany ==. Just newCompanyId) : (UserSupervisorReason ~=. superReasonComDef)
|
||||
-- when (oldAPs > 0 && newAPs <= 0) $ reportAdminProblem $ AdminProblemNewlyUnsupervised usrId oldCompanyId newCompanyId
|
||||
-- return pst_up
|
||||
@ -553,7 +553,7 @@ createAvsUserById muid api = do
|
||||
let userComp = UserCompany uid cid False False 1 True Nothing -- default value for new company insertion, if no update can be done
|
||||
void $ insertUnique userComp -- Nothing indicates that the user is already linked to the company (which is unlikely here)
|
||||
-- Supervision
|
||||
addCompanySupervisors cid uid
|
||||
void $ addDefaultSupervisors Nothing cid $ singleton uid
|
||||
-- Save AVS data for future updates
|
||||
insert_ $ usrAvs uid (Just cpi) (Just firmInfo) usrCardNo -- unlikely that uid cannot be linked with avsid, but throw if it is not possible
|
||||
return uid
|
||||
|
||||
@ -21,6 +21,14 @@ import qualified Database.Esqueleto.PostgreSQL as E
|
||||
import Handler.Utils.Users
|
||||
import Handler.Utils.Widgets
|
||||
|
||||
-- Snippet to restrict to primary company only
|
||||
-- E.&&. E.notExists (do
|
||||
-- othr <- E.from $ E.table @UserCompany
|
||||
-- E.where_ $ othr E.^. UserCompanyPriority E.>. userCompany E.^. UserCompanyPriority
|
||||
-- E.&&. othr E.^. UserCompanyUser E.==. userCompany E.^. UserCompanyUser
|
||||
-- E.&&. othr E.^. UserCompanyCompany E.!=. E.val cid -- redundant due to > above, but likely performance improving
|
||||
-- )
|
||||
|
||||
company2msg :: CompanyId -> SomeMessage UniWorX
|
||||
company2msg = text2message . ciOriginal . unCompanyKey
|
||||
|
||||
@ -51,38 +59,90 @@ wgtCompanies = \uid -> do
|
||||
(accPri,accTop,accRem) = procCmp maxPri cs
|
||||
in (max cmpPrio accPri, bool accTop (cmpWgt : accTop) isTop, bool (cmpWgt : accRem) accRem isTop) -- lazy evaluation after repmin example, don't factor out the bool!
|
||||
|
||||
-- TODO: use this function in company view Handler.Firm #157
|
||||
-- | add all company supervisors for a given users
|
||||
addCompanySupervisors :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryWrite backend, PersistUniqueWrite backend)
|
||||
=> Key Company -> Key User -> ReaderT backend m ()
|
||||
addCompanySupervisors cid uid =
|
||||
E.insertSelectWithConflict
|
||||
UniqueUserSupervisor
|
||||
( do
|
||||
userCompany <- E.from $ E.table @UserCompany
|
||||
E.where_ $ userCompany E.^. UserCompanyCompany E.==. E.val cid
|
||||
E.&&. userCompany E.^. UserCompanySupervisor
|
||||
-- E.&&. E.notExists (do -- restrict to primary company only
|
||||
-- othr <- E.from $ E.table @UserCompany
|
||||
-- E.where_ $ othr E.^. UserCompanyPriority E.>. userCompany E.^. UserCompanyPriority
|
||||
-- E.&&. othr E.^. UserCompanyUser E.==. userCompany E.^. UserCompanyUser
|
||||
-- E.&&. othr E.^. UserCompanyCompany E.!=. E.val cid -- redundant due to > above, but likely performance improving
|
||||
-- )
|
||||
|
||||
return $ UserSupervisor
|
||||
E.<# (userCompany E.^. UserCompanyUser)
|
||||
E.<&> E.val uid
|
||||
E.<&> (userCompany E.^. UserCompanySupervisorReroute)
|
||||
E.<&> E.justVal cid
|
||||
E.<&> E.justVal (tshow SupervisorReasonCompanyDefault)
|
||||
)
|
||||
(\current excluded -> -- Supervision between chosen individuals exists already; keep old reason and company, if exists
|
||||
[ UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] -- do we want this? Ok, since we delete unconditionally first?!
|
||||
, UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason ]
|
||||
]
|
||||
-- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company
|
||||
-- if no reason is given, SupervisorReasonCompanyDefault is used, except if reason == Just "NULL"
|
||||
addDefaultSupervisors :: Maybe Text -> CompanyId -> NonEmpty UserId -> DB Int64
|
||||
addDefaultSupervisors reason cid employees = do
|
||||
E.insertSelectWithConflictCount UniqueUserSupervisor
|
||||
(do
|
||||
(spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees
|
||||
E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid
|
||||
E.&&. spr E.^. UserCompanySupervisor
|
||||
E.distinct $ return $ UserSupervisor
|
||||
E.<# (spr E.^. UserCompanyUser)
|
||||
E.<&> usr
|
||||
E.<&> (spr E.^. UserCompanySupervisorReroute)
|
||||
E.<&> E.justVal cid
|
||||
E.<&> case reason of
|
||||
Nothing -> E.justVal $ tshow SupervisorReasonCompanyDefault
|
||||
Just "NULL" -> E.nothing
|
||||
other -> E.val other
|
||||
)
|
||||
(\old new ->
|
||||
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
|
||||
, UserSupervisorCompany E.=. E.justVal cid
|
||||
, UserSupervisorReason E.=. E.coalesce [new E.^. UserSupervisorReason, old E.^. UserSupervisorReason] -- keep existing reason, if no new one was given
|
||||
])
|
||||
|
||||
|
||||
-- like `Handler.Utils.addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual
|
||||
-- TODO: check redundancies
|
||||
addDefaultSupervisorsFor :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Maybe UserId -> Bool -> mono -> DB Int64
|
||||
addDefaultSupervisorsFor reason mbSuperId mutualSupervision cids = do
|
||||
E.insertSelectWithConflictCount UniqueUserSupervisor
|
||||
(do
|
||||
(spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
|
||||
E.where_ $ E.and $ guardMonoid (not mutualSupervision)
|
||||
[ E.not_ $ usr E.^. UserCompanySupervisor ]
|
||||
<> maybeEmpty mbSuperId (\sprId -> [E.exists $ do
|
||||
superv <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ superv E.^. UserSupervisorSupervisor E.==. E.val sprId
|
||||
E.&&. superv E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser
|
||||
])
|
||||
<> [ spr E.^. UserCompanySupervisor
|
||||
, spr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
, usr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
]
|
||||
E.distinct $ return $ UserSupervisor
|
||||
E.<# (spr E.^. UserCompanyUser)
|
||||
E.<&> (usr E.^. UserCompanyUser)
|
||||
E.<&> (spr E.^. UserCompanySupervisorReroute)
|
||||
E.<&> E.just (spr E.^. UserCompanyCompany)
|
||||
E.<&> E.val reason
|
||||
)
|
||||
(\old new ->
|
||||
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
|
||||
, UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
|
||||
, UserSupervisorReason E.=. E.coalesce [new E.^. UserSupervisorReason, old E.^. UserSupervisorReason] -- keep existing reason, if no new one was given
|
||||
] )
|
||||
|
||||
-- like `addDefaultSupervisors`, but selects all employees of given companies from database
|
||||
-- TODO: check redundancies
|
||||
addDefaultSupervisorsAll :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe Text -> Bool -> mono -> DB Int64
|
||||
addDefaultSupervisorsAll reason mutualSupervision cids = do
|
||||
E.insertSelectWithConflictCount UniqueUserSupervisor
|
||||
(do
|
||||
(spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany)
|
||||
E.where_ $ E.and $ guardMonoid (not mutualSupervision)
|
||||
[ E.not_ $ usr E.^. UserCompanySupervisor ]
|
||||
<> [ spr E.^. UserCompanySupervisor
|
||||
, spr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
, usr E.^. UserCompanyCompany `E.in_` E.vals cids
|
||||
]
|
||||
E.distinct $ return $ UserSupervisor
|
||||
E.<# (spr E.^. UserCompanyUser)
|
||||
E.<&> (usr E.^. UserCompanyUser)
|
||||
E.<&> (spr E.^. UserCompanySupervisorReroute)
|
||||
E.<&> E.just (spr E.^. UserCompanyCompany)
|
||||
E.<&> E.val reason
|
||||
)
|
||||
(\old new ->
|
||||
[ UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications
|
||||
, UserSupervisorCompany E.=. new E.^. UserSupervisorCompany
|
||||
, UserSupervisorReason E.=. E.coalesce [old E.^. UserSupervisorReason, new E.^. UserSupervisorReason] -- keep any existing reason
|
||||
] )
|
||||
|
||||
-- | removes user supervisorship on switch. WARNING: problems are not yet written to DB via reportProblem yet
|
||||
switchAvsUserCompany :: Bool -> Bool -> UserId -> CompanyId -> DB ([Update User], [AdminProblem])
|
||||
switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = do
|
||||
@ -108,7 +168,7 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
|
||||
case mbUsrComp of
|
||||
Nothing -> do -- create company user
|
||||
void $ insertUnique newUserComp
|
||||
addCompanySupervisors newCompanyId uid
|
||||
void $ addDefaultSupervisors Nothing newCompanyId $ singleton uid
|
||||
return (usrUpdate, mempty)
|
||||
Just UserCompany{userCompanyCompany=oldCompanyId, userCompanyPriority=oldPrio, userCompanySupervisor=oldSuper, userCompanySupervisorReroute=oldSuperReroute, userCompanyReason=oldAssocReason}
|
||||
| newCompanyId == oldCompanyId -> return mempty -- nothing to do
|
||||
@ -140,7 +200,7 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
|
||||
oldAPs <- if keepOldCompanySupervs
|
||||
then updateWhereCount oldSubFltr [UserSupervisorReason =. Nothing]
|
||||
else deleteWhereCount oldSubFltr
|
||||
addCompanySupervisors newCompanyId uid
|
||||
void $ addDefaultSupervisors Nothing newCompanyId $ singleton uid
|
||||
newAPs <- count $ (UserSupervisorCompany ==. Just newCompanyId) : superDeftFltr
|
||||
let isNoLongerSupervised = not keepOldCompanySupervs && oldAPs > 0 && newAPs <= 0
|
||||
problems = bcons oldSuper (AdminProblemSupervisorNewCompany uid oldCompanyId newCompanyId oldSuperReroute)
|
||||
@ -149,4 +209,15 @@ switchAvsUserCompany usrPostEmailUpds keepOldCompanySupervs uid newCompanyId = d
|
||||
return (usrUpdate ,problems)
|
||||
where
|
||||
newUserComp = UserCompany uid newCompanyId False False 1 True Nothing -- default value for new company insertion, if no update can be done
|
||||
superReasonComDef = tshow SupervisorReasonCompanyDefault
|
||||
superReasonComDef = tshow SupervisorReasonCompanyDefault
|
||||
|
||||
-- | 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):reasonFilter)
|
||||
<*> deleteWhereCount ((UserSupervisorCompany ==. Just cid):(UserSupervisorUser <-. uids):reasonFilter)
|
||||
where
|
||||
reasonFilter = [UserSupervisorReason ==. Nothing]
|
||||
||. [UserSupervisorReason <-. [Just $ tshow r | r <- [SupervisorReasonCompanyDefault, SupervisorReasonAvsSuperior]]]
|
||||
@ -77,7 +77,7 @@ import qualified Data.Text.Lazy.Builder as Builder
|
||||
-- import Control.Monad.Catch.Pure (runCatch)
|
||||
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
|
||||
|
||||
{-# ANN module ("HLint: ignore Use const" :: String) #-}
|
||||
|
||||
|
||||
@ -217,7 +217,7 @@ optionalAction'' negated minp justAct fs@FieldSettings{..} defActive csrf = do
|
||||
let actionViews = over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/optional-action")) actionViews'
|
||||
|
||||
return (doRes >>= bool (pure Nothing) (Just <$> actionRes), over _fvInput (mappend $ toWidget csrf) doView : actionViews)
|
||||
|
||||
|
||||
optionalAction :: AForm Handler a
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe Bool
|
||||
@ -236,7 +236,7 @@ optionalActionA :: AForm Handler a
|
||||
-> Maybe Bool
|
||||
-> AForm Handler (Maybe a)
|
||||
optionalActionA = optionalActionA' mpopt
|
||||
|
||||
|
||||
optionalActionNegatedA :: AForm Handler a
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe Bool
|
||||
@ -740,8 +740,7 @@ uploadModeForm fs prev = multiActionA actions fs (classifyUploadMode <$> prev)
|
||||
let iStart = maybe 0 (succ . fst) $ Map.lookupMax oldRess
|
||||
in pure $ Map.singleton iStart fileRes
|
||||
return (addRes', formWidget')
|
||||
miCell _ initFile _ nudge csrf =
|
||||
sFileForm nudge (Just initFile) csrf
|
||||
miCell _ initFile _ nudge = sFileForm nudge (Just initFile)
|
||||
miDelete :: MassInputDelete ListLength
|
||||
miDelete = miDeleteList
|
||||
miAddEmpty _ _ _ = Set.empty
|
||||
@ -966,9 +965,9 @@ genericFileField mkOpts = Field{..}
|
||||
$logDebugS "genericFileField.getPermittedFiles" $ "Additional: " <> tshow fieldAdditionalFiles
|
||||
$logDebugS "genericFileField.getPermittedFiles" $ "Session: " <> tshow sessionFiles'
|
||||
return $ mconcat
|
||||
[ Map.filter (views _3 $ (||) <$> not . fieldOptionForce <*> not . fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
|
||||
[ Map.filter (views _3 $ (||) <$> not . fieldOptionForce <*> not . fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
|
||||
, sessionFiles'
|
||||
, Map.filter (views _3 $ (&&) <$> fieldOptionForce <*> fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
|
||||
, Map.filter (views _3 $ (&&) <$> fieldOptionForce <*> fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
|
||||
]
|
||||
|
||||
handleUpload :: FileField FileReference -> Maybe Text -> ConduitT (File Handler) FileReference (YesodDB UniWorX) ()
|
||||
@ -1002,7 +1001,7 @@ genericFileField mkOpts = Field{..}
|
||||
fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe FileUploads))
|
||||
fieldParse vals files' = runExceptT $ do
|
||||
let files = filter (not . null . fileName) files'
|
||||
|
||||
|
||||
opts@FileField{..} <- liftHandler mkOpts
|
||||
|
||||
mIdent <- fmap getFirst . flip foldMapM vals $ \v ->
|
||||
@ -1116,7 +1115,7 @@ genericFileField mkOpts = Field{..}
|
||||
fuiChecked
|
||||
| Right sentVals' <- sentVals
|
||||
= fuiTitle `Set.member` sentVals'
|
||||
| Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
|
||||
| Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
|
||||
= fieldOptionDefault
|
||||
| otherwise = False
|
||||
fuiSession = fuiTitle `Map.notMember` view _FileReferenceFileReferenceTitleMap fieldAdditionalFiles
|
||||
@ -1201,7 +1200,7 @@ zipFileField :: Bool -- ^ Unpack zips?
|
||||
-> Bool -- ^ Empty files ok?
|
||||
-> Field Handler FileUploads
|
||||
zipFileField doUnpack permittedExtensions emptyOk = zipFileField' doUnpack permittedExtensions emptyOk Nothing
|
||||
|
||||
|
||||
zipFileField' :: Bool -- ^ Unpack zips?
|
||||
-> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions
|
||||
-> Bool -- ^ Empty files ok?
|
||||
@ -1315,16 +1314,16 @@ sheetTypeAFormReq cId fs template = wFormToAForm $ do
|
||||
|
||||
editableExams <- fmap Map.keysSet . flip mapFilterM (foldMap (\(Entity eId exam, Entity _ course, _) -> Map.singleton eId (exam, course)) examParts'') $ \(Exam{..}, Course{..}) ->
|
||||
hasWriteAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EEditR
|
||||
|
||||
|
||||
return (examParts'', editableExams)
|
||||
|
||||
let
|
||||
examParts' = flip foldMap examParts'' $ \(eEnt@(Entity eId _), _, epEnt) -> guardOn @[] (eId `Set.member` editableExams) (eEnt, epEnt)
|
||||
examParts = flip sortOn examParts' $ \(Entity _ Exam{..}, Entity _ ExamPart{..}) -> (examName, examPartNumber)
|
||||
|
||||
|
||||
doExamPartPoints = fmap classifySheetType template == Just ExamPartPoints'
|
||||
|| not (null examParts)
|
||||
|
||||
|
||||
acts = Map.fromList $ catMaybes
|
||||
[ pure ( Normal', Normal <$> gradingReq )
|
||||
, pure ( Bonus' , Bonus <$> gradingReq )
|
||||
@ -1346,7 +1345,7 @@ sheetTypeAFormReq cId fs template = wFormToAForm $ do
|
||||
Informational' -> return $ i18n MsgSheetTypeInfoInformational
|
||||
NotGraded' -> return $ i18n MsgSheetTypeInfoNotGraded
|
||||
ExamPartPoints' -> return $ i18n MsgSheetTypeInfoExamPartPoints
|
||||
|
||||
|
||||
aFormToWForm . explainedMultiActionA acts opts fs $ classifySheetType <$> template
|
||||
|
||||
sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
|
||||
@ -1468,7 +1467,7 @@ jsonField fieldKind = Field{..}
|
||||
{- was only used in workflows; if needed recreate MsgYAMLFieldDecodeFailure
|
||||
yamlField :: ( ToJSON a, FromJSON a
|
||||
, MonadHandler m
|
||||
, RenderMessage (HandlerSite m) FormMessage
|
||||
, RenderMessage (HandlerSite m) FormMessage
|
||||
)
|
||||
=> Field m a
|
||||
yamlField = Field{..}
|
||||
@ -1483,7 +1482,14 @@ yamlField = Field{..}
|
||||
#{either id (decodeUtf8 . Yaml.encode) val}
|
||||
|]
|
||||
fieldEnctype = UrlEncoded
|
||||
-}
|
||||
-}
|
||||
|
||||
|
||||
boolField' :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> Field m Bool
|
||||
boolField' = boolField (Just $ SomeMessage MsgBoolIrrelevant)
|
||||
|
||||
boolField :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
@ -2309,7 +2315,7 @@ examModeForm mPrev = examMode
|
||||
<*> customPresetForm examRequiredEquipmentEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examRequiredEquipmentPresetWidget) (apreq htmlField (fslI MsgExamModeFormRequiredEquipment)) (fslI MsgExamModeFormRequiredEquipment & setTooltip MsgExamModeFormRequiredEquipmentIdentificationTip) (examRequiredEquipment <$> mPrev)
|
||||
where
|
||||
examMode examSynchronicity examOnline examAids examRequiredEquipment = ExamMode{..}
|
||||
|
||||
|
||||
examAidsEither :: Iso' ExamAids (Either StoredMarkup ExamAidsPreset)
|
||||
examAidsEither = iso examAidsToEither examAidsFromEither
|
||||
where examAidsToEither (ExamAidsPreset p) = Right p
|
||||
|
||||
@ -10,7 +10,7 @@ module Utils.Form where
|
||||
|
||||
import ClassyPrelude.Yesod hiding (addMessage, addMessageI, cons, Proxy(..), identifyForm, addClass, mreq, areq, wreq, urlField)
|
||||
import Yesod.Auth (YesodAuth(maybeAuthId))
|
||||
|
||||
|
||||
import Data.Kind (Type, Constraint)
|
||||
import qualified Yesod.Form as Yesod
|
||||
import Yesod.Core.Instances ()
|
||||
@ -94,7 +94,7 @@ _olOptionsGrouped :: Traversal' (OptionList a) (Text, [Option a])
|
||||
_olOptionsGrouped f = \case
|
||||
x@OptionList{} -> pure x
|
||||
x@OptionListGrouped{} -> (\olOptionsGrouped -> x{olOptionsGrouped}) <$> traverse f (olOptionsGrouped x)
|
||||
|
||||
|
||||
_olReadExternal :: Lens' (OptionList a) (Text -> Maybe a)
|
||||
_olReadExternal f = \case
|
||||
x@OptionList{} -> (\olReadExternal -> x{olReadExternal}) <$> f (olReadExternal x)
|
||||
@ -103,7 +103,7 @@ _olReadExternal f = \case
|
||||
-- if a field is required, but none should be there
|
||||
noField :: Monad m => Field m a
|
||||
noField = Field{..}
|
||||
where
|
||||
where
|
||||
fieldParse _ _ = return $ Right Nothing
|
||||
fieldView _ _ _ _ _ = mempty
|
||||
fieldEnctype = UrlEncoded
|
||||
@ -576,52 +576,52 @@ runButtonForm' btns fid = do
|
||||
return (btnForm, res)
|
||||
|
||||
|
||||
-- | like runButtonForm, but may include a hash value enclosed in a hidden field to ensure
|
||||
-- | like runButtonForm, but may include a hash value enclosed in a hidden field to ensure
|
||||
-- that the button press still applies to the correct situation
|
||||
runButtonFormHash ::( PathPiece ident, Eq ident, RenderAFormSite site
|
||||
runButtonFormHash ::( PathPiece ident, Eq ident, RenderAFormSite site
|
||||
, Button site ButtonSubmit, Button site a, Finite a, Hashable h)
|
||||
=> h -> ident -> HandlerT site IO (WidgetT site IO (), Maybe a)
|
||||
runButtonFormHash (hash -> hVal) fid = do
|
||||
currentRoute <- getCurrentRoute
|
||||
let bForm = disambiguateButtons $ combinedButtonFieldF ""
|
||||
hForm = aopt hiddenField "" $ Just $ Just hVal
|
||||
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html ->
|
||||
hForm = aopt hiddenField "" $ Just $ Just hVal
|
||||
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html ->
|
||||
flip (renderAForm FormStandard) html $ (,) <$> bForm <*> hForm
|
||||
let btnForm = wrapForm btnWdgt def { formAction = SomeRoute <$> currentRoute
|
||||
, formEncoding = btnEnctype
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
res <- formResultMaybe btnResult $ \case
|
||||
res <- formResultMaybe btnResult $ \case
|
||||
(btn, Just rVal) | hVal == rVal -> return $ Just btn -- hash value from hidden field must be present and matching
|
||||
_ -> do
|
||||
addMessageI Error MsgBtnFormOutdated
|
||||
_ -> do
|
||||
addMessageI Error MsgBtnFormOutdated
|
||||
whenIsJust currentRoute redirect -- redirect is needed to reset hidden-field value
|
||||
return Nothing
|
||||
return (btnForm, res)
|
||||
|
||||
-- | like runButtonFormHash, but showing only a given list of buttons, especially for buttons that are not in the Finite typeclass.
|
||||
runButtonFormHash' :: ( PathPiece ident, Eq ident, RenderAFormSite site
|
||||
runButtonFormHash' :: ( PathPiece ident, Eq ident, RenderAFormSite site
|
||||
, Button site ButtonSubmit, Button site a, Hashable h)
|
||||
=> h -> [a] -> ident -> HandlerT site IO (WidgetT site IO (), Maybe a)
|
||||
runButtonFormHash' (hash -> hVal) btns fid = do
|
||||
currentRoute <- getCurrentRoute
|
||||
let bForm = disambiguateButtons $ combinedButtonField btns ""
|
||||
hForm = aopt hiddenField "" $ Just $ Just hVal
|
||||
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html ->
|
||||
hForm = aopt hiddenField "" $ Just $ Just hVal
|
||||
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html ->
|
||||
flip (renderAForm FormStandard) html $ (,) <$> bForm <*> hForm
|
||||
let btnForm = wrapForm btnWdgt def { formAction = SomeRoute <$> currentRoute
|
||||
, formEncoding = btnEnctype
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
res <- formResultMaybe btnResult $ \case
|
||||
res <- formResultMaybe btnResult $ \case
|
||||
(btn, Just rVal) | hVal == rVal -> return $ Just btn -- hash value from hidden field must be present and matching
|
||||
_ -> do
|
||||
addMessageI Error MsgBtnFormOutdated
|
||||
_ -> do
|
||||
addMessageI Error MsgBtnFormOutdated
|
||||
whenIsJust currentRoute redirect -- redirect is needed to reset hidden-field value
|
||||
return Nothing
|
||||
return (btnForm, res)
|
||||
|
||||
|
||||
|
||||
-------------------
|
||||
-- Custom Fields --
|
||||
-------------------
|
||||
@ -801,7 +801,7 @@ intMinMaxField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) Fo
|
||||
intMinMaxField lower upper = intF{ fieldView=newView }
|
||||
where
|
||||
intF@Field{ fieldView=oldView } = intField
|
||||
newView theId name attrs val isReq = oldView theId name (newAttrs <> attrs) val isReq
|
||||
newView theId name attrs = oldView theId name (newAttrs <> attrs)
|
||||
newAttrs = [ (a,tshow v) | (a,Just v) <- [("min", lower),("max", upper)] ]
|
||||
|
||||
daysField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m NominalDiffTime
|
||||
@ -873,10 +873,10 @@ cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . m
|
||||
-- cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text)
|
||||
-- cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . splitConditionally) (T.intercalate "; " . Set.toList)
|
||||
-- where splitConditionally :: Text -> [Text]
|
||||
-- splitConditionally t
|
||||
-- splitConditionally t
|
||||
-- | ';' `telem` t = T.split (==';') t
|
||||
-- | ',' `telem` t = T.split (==',') t
|
||||
-- | otherwise = T.split C.isSeparator t
|
||||
-- | otherwise = T.split C.isSeparator t
|
||||
-- -- Our version of Data.Text does not yet support T.elem
|
||||
-- telem :: Char -> Text -> Bool
|
||||
-- telem c = T.any (==c)
|
||||
@ -885,10 +885,10 @@ cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . m
|
||||
-- cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text)
|
||||
-- cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . splitConditionally) (T.intercalate "; " . Set.toList)
|
||||
-- where splitConditionally :: Text -> [Text]
|
||||
-- splitConditionally t
|
||||
-- splitConditionally t
|
||||
-- | ';' `telem` t = T.split (==';') t
|
||||
-- | ',' `telem` t = T.split (==',') t
|
||||
-- | otherwise = T.split C.isSeparator t
|
||||
-- | otherwise = T.split C.isSeparator t
|
||||
-- -- Our version of Data.Text does not yet support T.elem
|
||||
-- telem :: Char -> Text -> Bool
|
||||
-- telem c = T.any (==c)
|
||||
@ -978,7 +978,7 @@ multiSelectField' optMsg mkOpts = Field{..}
|
||||
let
|
||||
rendered = case val of
|
||||
Left _ -> []
|
||||
Right xs -> [optionExternalValue o | o <- opts ^.. _olOptions, x <- xs, x == optionInternalValue o]
|
||||
Right xs -> [optionExternalValue o | o <- opts ^.. _olOptions, x <- xs, x == optionInternalValue o]
|
||||
isSel Nothing = ClassyPrelude.Yesod.null rendered
|
||||
isSel (Just opt) = optionExternalValue opt `elem` rendered
|
||||
[whamlet|
|
||||
@ -1112,7 +1112,7 @@ urlFieldText :: ( Monad m
|
||||
)
|
||||
=> Field m Text
|
||||
urlFieldText = urlField' (pack . ($ mempty) . uriToString id) id
|
||||
|
||||
|
||||
|
||||
-----------
|
||||
-- Forms --
|
||||
@ -1183,7 +1183,7 @@ type RenderAFormSite site = ( RenderMessage site AFormMessage
|
||||
, RenderMessage site UrlFieldMessage
|
||||
, MonadSecretBox (HandlerFor site)
|
||||
, MonadSecretBox (MaybeT (RWST (Maybe (Env, FileEnv), site, [Lang]) Enctype Ints (Lazy.WriterT [FieldView site] (HandlerFor site))))
|
||||
, YesodAuth site, HasAppSettings site
|
||||
, YesodAuth site, HasAppSettings site
|
||||
)
|
||||
|
||||
renderAForm :: (MonadHandler m, RenderAFormSite (HandlerSite m)) => FormLayout -> FormRender m a
|
||||
@ -1272,7 +1272,7 @@ doFormHoneypots :: ( MonadHandler m
|
||||
doFormHoneypots = and2M
|
||||
(getsYesod . views _appBotMitigations $ Set.member SettingBotMitigationUnauthorizedFormHoneypots)
|
||||
(is _Nothing <$> maybeAuthId)
|
||||
|
||||
|
||||
honeypotSecrets :: ( MonadSecretBox m
|
||||
, MonadThrow m
|
||||
)
|
||||
@ -1285,8 +1285,8 @@ honeypotSecrets = secretBoxCSPRNGPure (encodeUtf8 $ tshow 'honeypotSecrets) (Bin
|
||||
secretsNum = 10
|
||||
|
||||
randomIdent = decodeUtf8 . Base64.encodeUnpadded . BS.pack <$> replicateM 18 getRandom
|
||||
|
||||
|
||||
|
||||
|
||||
aformHoneypot :: forall m a.
|
||||
( RenderAFormSite (HandlerSite m)
|
||||
, MonadHandler m
|
||||
|
||||
@ -121,6 +121,7 @@ data Icon
|
||||
| IconUserEdit
|
||||
-- IconMagic -- indicates automatic updates
|
||||
| IconReroute -- for notification rerouting
|
||||
| IconTop -- indicating highest number/quantity/priority for something
|
||||
|
||||
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
|
||||
deriving anyclass (Universe, Finite, NFData)
|
||||
@ -220,6 +221,7 @@ iconText = \case
|
||||
IconUserEdit -> "user-edit"
|
||||
-- IconMagic -> "wand-magic"
|
||||
IconReroute -> "directions"
|
||||
IconTop -> "arrow-to-top"
|
||||
nullaryPathPiece ''Icon $ camelToPathPiece' 1
|
||||
deriveLift ''Icon
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user