Merge branch 'fradrive/company' into test
This commit is contained in:
commit
29df39f3b5
@ -2,7 +2,12 @@
|
||||
|
||||
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
|
||||
|
||||
## [27.4.48](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.47...t27.4.48) (2023-11-03)
|
||||
## [27.4.48](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.47...v27.4.48) (2023-11-07)
|
||||
|
||||
|
||||
### Bug Fixes
|
||||
|
||||
* **lms:** mark as ended only if not seen for at least one day ([8165892](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8165892b2e4f945780bb8420cfc4eed50fdd294d))
|
||||
|
||||
## [27.4.47](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.46...v27.4.47) (2023-11-03)
|
||||
|
||||
|
||||
@ -13,8 +13,12 @@ FirmUserActMkSuper: Zum Firmenansprechpartner ernennen
|
||||
FirmSuperActNotify: Mitteilung versenden
|
||||
FirmSuperActRMSuperDef: Standard Firmenansprechpartner entfernen
|
||||
FirmSuperActRMSuperAll: Als aktiven Ansprechpartner komplett entfernen
|
||||
FirmsNotification: Firmen Benachrichtigung versenden
|
||||
FirmNotification fsh@CompanyShorthand: Benachrichtigung an #{fsh} versenden
|
||||
FilterSupervisor: Hat aktiven Ansprechpartner
|
||||
FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der #{fsh} angehört
|
||||
FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, #{fsh} der angehört
|
||||
FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der selbst nicht #{fsh} angehört
|
||||
FilterForeignSupervisor: Hat firmenfremde Ansprechpartner
|
||||
FilterFirmPostalAddress: Postalische Firmenadresse vorhanden
|
||||
FilterFirmPostalAddress: Postalische Firmenadresse vorhanden
|
||||
FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig
|
||||
FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh}
|
||||
@ -13,8 +13,12 @@ FirmUserActMkSuper: Mark as company supervisor
|
||||
FirmSuperActNotify: Send message
|
||||
FirmSuperActRMSuperDef: Remove as default supervisor
|
||||
FirmSuperActRMSuperAll: Remove all active supervisions for this company
|
||||
FirmsNotification: Send company notification
|
||||
FirmNotification fsh: Send notification to company #{fsh}
|
||||
FilterSupervisor: Has active supervisor
|
||||
FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh}
|
||||
FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh}
|
||||
FilterForeignSupervisor: Has company-external supervisors
|
||||
FilterFirmPostalAddress: Postal company addresse known
|
||||
FilterFirmPostalAddress: Postal company addresse known
|
||||
FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh}
|
||||
FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users
|
||||
@ -15,7 +15,6 @@ ResetPassword: FRADrive-Passwort ändern bzw. setzen
|
||||
MailSubjectChangeUserDisplayEmail: E-Mail-Adresse in FRADrive verwenden
|
||||
MailIntroChangeUserDisplayEmail displayEmail@UserEmail: Der oben genannte Benutzer/Die oben genannte Benutzerin möchte „#{displayEmail}“ als E-Mail-Adresse in FRADrive verwenden. Wenn Sie diese Aktion nicht selbst ausgelöst haben, ignorieren Sie diese Mitteilung bitte!
|
||||
MailTitleChangeUserDisplayEmail displayName@Text: #{displayName} möchte diese E-Mail-Adresse in FRADrive verwenden
|
||||
CommCourseSubject: Kursartmitteilung
|
||||
InvitationAcceptDecline: Einladung annehmen/ablehnen
|
||||
InvitationFromTip displayName@Text: Sie erhalten diese Einladung, weil #{displayName} ihren Versand in FRADrive ausgelöst hat.
|
||||
InvitationFromTipAnonymous: Sie erhalten diese Einladung, weil ein nicht eingeloggter Benutzer/eine nichteingeloggte Benutzerin ihren Versand in FRADrive ausgelöst hat.
|
||||
|
||||
@ -15,7 +15,6 @@ ResetPassword: Reselt FRADrive password
|
||||
MailSubjectChangeUserDisplayEmail: Set email address in FRADrive
|
||||
MailIntroChangeUserDisplayEmail displayEmail: The user mentioned above wants to set “#{displayEmail}” as their own email address. If you have not caused this email to be sent, please ignore it!
|
||||
MailTitleChangeUserDisplayEmail displayName: #{displayName} wants to set this email address as their own in FRADrive
|
||||
CommCourseSubject: Course type message
|
||||
InvitationAcceptDecline: Accept/Decline invitation
|
||||
InvitationFromTip displayName: You are receiving this invitation because #{displayName} has caused it to be sent from within FRADrive.
|
||||
InvitationFromTipAnonymous: You are receiving this invitiation because an user who didn't log in has caused it to be send from within FRADrive.
|
||||
|
||||
@ -136,6 +136,7 @@ MenuLmsReport: Ergebnisse E‑Learning
|
||||
MenuFirms: Firmen
|
||||
MenuFirmUsers: Angehörige
|
||||
MenuFirmSupervisors: Ansprechpartner
|
||||
MenuFirmsComm: Mitteilung
|
||||
|
||||
MenuSap: SAP Schnittstelle
|
||||
|
||||
|
||||
@ -137,6 +137,7 @@ MenuLmsReport: E‑learning Results
|
||||
MenuFirms: Companies
|
||||
MenuFirmUsers: Associates
|
||||
MenuFirmSupervisors: Supervisors
|
||||
MenuFirmsComm: Messaging
|
||||
|
||||
MenuSap: SAP Interface
|
||||
|
||||
|
||||
@ -83,7 +83,7 @@ TableCompanyNos: Company numbers
|
||||
TableCompanyUser: Associate
|
||||
TableCompanyNrUsers: Associates
|
||||
TableCompanyNrSupers: Supervisors
|
||||
TableCompanyNrEmpSupervised: Supervsied employees
|
||||
TableCompanyNrEmpSupervised: Supervised employees
|
||||
TableCompanyNrEmpRerouted: Employees having reroute
|
||||
TableCompanyNrEmpRerPost: Employees having postal reroute
|
||||
TableCompanyNrSupersActive: Associates having supervisors
|
||||
|
||||
@ -13,6 +13,7 @@ RGCourseUnacceptedApplicants: Nicht akzeptierte Bewerber:innen
|
||||
RecipientToggleAll: Alle/Keine
|
||||
CommCourseTestSubject customSubject@Text !ident-ok: [TEST] #{customSubject}
|
||||
UtilCommCourseSubject: Kursartmitteilung
|
||||
UtilCommFirmSubject: Firmenmitteilung
|
||||
CommRecipients: Empfänger:innen
|
||||
CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht
|
||||
CommRecipientsList: Die an Sie selbst verschickte Kopie der Nachricht wird, zu Archivierungszwecken, eine vollständige Liste aller Empfänger:innen enthalten. Die Empfängerliste wird im CSV-Format an die E-Mail angehängt. Andere Empfänger:innen erhalten die Liste nicht. Bitte entfernen Sie dementsprechend den Anhang bevor Sie die E-Mail weiterleiten oder anderweitig mit Dritten teilen.
|
||||
|
||||
@ -13,6 +13,7 @@ RGCourseUnacceptedApplicants: Applicants not accepted
|
||||
RecipientToggleAll: All/None
|
||||
CommCourseTestSubject customSubject: [TEST] #{customSubject}
|
||||
UtilCommCourseSubject: Course type message
|
||||
UtilCommFirmSubject: Company message
|
||||
CommRecipients: Recipients
|
||||
CommRecipientsTip: You always receive a copy of the message
|
||||
CommRecipientsList: For archival purposes the copy of the message sent to you will contain a complete list of all recipients. The list of recipients will be attached to the email in CSV-format. Other recipients do not receive the list. Thus, please remove the attachment before you forward the email or otherwise share it with third parties.
|
||||
|
||||
@ -184,4 +184,5 @@ LmsReportLog
|
||||
result LmsState -- (0|1|2) 0=LmsFailed[too many tries], 1=LmsOpen, 2=LmsPassed[success]
|
||||
lock Bool -- (0|1)
|
||||
timestamp UTCTime default=now()
|
||||
missing Bool default=false
|
||||
deriving Generic
|
||||
4
routes
4
routes
@ -113,8 +113,10 @@
|
||||
/for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self
|
||||
/for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self
|
||||
|
||||
/firm FirmAllR GET POST !supervisor
|
||||
/firms FirmAllR GET POST !supervisor
|
||||
/firms/comm FirmsCommR GET POST
|
||||
/firm/#CompanyShorthand FirmR GET POST
|
||||
/firm/#CompanyShorthand/comm FirmCommR GET POST
|
||||
/firm/#CompanyShorthand/users FirmUsersR GET POST !supervisor
|
||||
/firm/#CompanyShorthand/supers FirmSupersR GET POST !supervisor
|
||||
|
||||
|
||||
@ -124,9 +124,11 @@ breadcrumb ProblemAvsSynchR = i18nCrumb MsgProblemsAvsSynchHeading $ Just
|
||||
breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just ProblemAvsSynchR
|
||||
|
||||
breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing
|
||||
breadcrumb FirmsCommR = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR
|
||||
breadcrumb FirmR{} = i18nCrumb MsgMenuAdminHeading $ Just FirmAllR -- TODO: change heading or remove
|
||||
breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirmUsers $ Just FirmAllR
|
||||
breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors $ Just $ FirmUsersR fsh
|
||||
breadcrumb (FirmCommR fsh)= i18nCrumb MsgMenuFirmsComm $ Just $ FirmUsersR fsh
|
||||
|
||||
breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing
|
||||
breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR
|
||||
|
||||
@ -11,6 +11,8 @@ module Handler.Firm
|
||||
, getFirmR , postFirmR
|
||||
, getFirmUsersR , postFirmUsersR
|
||||
, getFirmSupersR, postFirmSupersR
|
||||
, getFirmCommR , postFirmCommR
|
||||
, getFirmsCommR, postFirmsCommR
|
||||
)
|
||||
where
|
||||
|
||||
@ -18,6 +20,7 @@ import Import
|
||||
|
||||
-- import Jobs
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Communication
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
@ -272,11 +275,11 @@ mkFirmAllTable isAdmin uid = do
|
||||
, singletonMap "avsnr" $ SortColumn (E.^. CompanyAvsId)
|
||||
, singletonMap "postal-pref" $ SortColumn (E.^. CompanyPrefersPostal)
|
||||
, singletonMap "users" $ SortColumn firmCountUsers
|
||||
, singletonMap "supervisors" $ SortColumn firmCountSupervisors
|
||||
, singletonMap "supervisors" $ SortColumn firmHasSupervisors
|
||||
-- , singletonMap "emp-supervised" $ SortColumn firmCountEmployeeSupervised
|
||||
-- , singletonMap "emp-rerouted" $ SortColumn firmCountEmployeeRerouted
|
||||
-- , singletonMap "emp-rer-post" $ SortColumn firmCountEmployeeRerPost
|
||||
, singletonMap "reroute-def" $ SortColumn firmCountDefaultReroutes
|
||||
, singletonMap "reroute-def" $ SortColumn firmHasDefaultReroutes
|
||||
-- , singletonMap "foreigners" $ SortColumn firmCountForeignSupervisors
|
||||
-- , singletonMap "reroute-act" $ SortColumn firmCountActiveReroutes
|
||||
-- , singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes'
|
||||
@ -363,9 +366,15 @@ postFirmAllR = do
|
||||
uid <- requireAuthId
|
||||
isAdmin <- hasReadAccessTo AdminR
|
||||
(firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins
|
||||
formResult firmRes $ \case
|
||||
(FirmAllActNotifyData , fids) -> addMessage Info $ text2Html $ "Notify " <> tshow (length fids) <> " companies. TODO"
|
||||
(FirmAllActResetSupervisionData, fids) -> addMessage Info $ text2Html $ "Reset " <> tshow (length fids) <> " companies. TODO"
|
||||
formResult firmRes $ \case
|
||||
(FirmAllActResetSupervisionData, fids) -> addMessage Info $ text2Html $ "Reset " <> tshow (length fids) <> " companies. TODO"
|
||||
(FirmAllActNotifyData , fids) -> do
|
||||
usrs <- runDB $ E.select $ E.distinct $ do
|
||||
(usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser)
|
||||
E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList (Set.toList fids)
|
||||
return $ usr E.^. UserId
|
||||
cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser]
|
||||
redirect (FirmsCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
|
||||
siteLayoutMsg MsgMenuFirms $ do
|
||||
setTitleI MsgMenuFirms
|
||||
$(i18nWidgetFile "firm-all")
|
||||
@ -494,8 +503,10 @@ mkFirmUserTable isAdmin cid = do
|
||||
Just True -> E.exists checkSuper
|
||||
Just False -> E.notExists checkSuper
|
||||
]
|
||||
-- superField = selectField $ ????
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev
|
||||
, prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift termField) (fslI MsgTableTerm)
|
||||
, prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor)
|
||||
, prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh)
|
||||
, prismAForm (singletonFilter "has-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorForeign fsh)
|
||||
@ -541,7 +552,7 @@ getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html
|
||||
getFirmUsersR = postFirmUsersR
|
||||
postFirmUsersR fsh = do
|
||||
isAdmin <- hasReadAccessTo AdminR
|
||||
let fshId = CompanyKey fsh
|
||||
let cid = CompanyKey fsh
|
||||
(( Entity{entityVal=Company{..}}
|
||||
, E.Value nrCompanyUsers
|
||||
, E.Value nrCompanySupervisors
|
||||
@ -551,10 +562,10 @@ postFirmUsersR fsh = do
|
||||
, E.Value nrCompanyEmployeeRerPost
|
||||
, E.Value nrCompanyDefaultReroutes
|
||||
, E.Value nrCompanyActiveReroutes
|
||||
) , (fusrRes, fusrTable)) <- runDB $ (,)
|
||||
) , (fusrRes, fusrTable)) <- runDB $ (,)
|
||||
<$> fromMaybeM notFound (E.selectOne $ do
|
||||
cmpy <- E.from $ E.table @Company
|
||||
E.where_ $ cmpy E.^. CompanyId E.==. E.val fshId
|
||||
E.where_ $ cmpy E.^. CompanyId E.==. E.val cid
|
||||
return ( cmpy
|
||||
, cmpy & firmCountUsers
|
||||
, cmpy & firmCountSupervisors
|
||||
@ -565,11 +576,18 @@ postFirmUsersR fsh = do
|
||||
, cmpy & firmCountDefaultReroutes
|
||||
, cmpy & firmCountActiveReroutes
|
||||
))
|
||||
<*> mkFirmUserTable isAdmin fshId
|
||||
-- superVs <- E.select $ do
|
||||
-- usr <- E.from $ E.table @User
|
||||
-- E.where_ $ E.exists $ firmQuerySupervisedBy cmpyId Nothing usr
|
||||
-- return usr
|
||||
<*> mkFirmUserTable isAdmin cid
|
||||
|
||||
formResult fusrRes $ \case
|
||||
(FirmUserActNotifyData , fids) -> addMessage Info $ text2Html $ "Notify " <> tshow (length fids) <> " employees. TODO"
|
||||
formResult fusrRes $ \case
|
||||
(FirmUserActMkSuperData, fids) -> addMessage Info $ text2Html $ "Make " <> tshow (length fids) <> " employees to supervisors. TODO"
|
||||
(FirmUserActNotifyData , fids) -> do
|
||||
cuids <- traverse encrypt $ Set.toList fids :: Handler [CryptoUUIDUser]
|
||||
redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
|
||||
|
||||
siteLayout (citext2widget companyName) $ do
|
||||
setTitle $ toHtml $ CI.original companyShorthand <> " (" <> tshow companyAvsId <> ")"
|
||||
$(widgetFile "firm-users")
|
||||
@ -597,7 +615,7 @@ type SuperCompanyTableExpr = E.SqlExpr (Entity User)
|
||||
querySuperUser :: SuperCompanyTableExpr -> E.SqlExpr (Entity User)
|
||||
querySuperUser = id
|
||||
|
||||
type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64)
|
||||
type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64, [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)])
|
||||
|
||||
resultSuperUser :: Lens' SuperCompanyTableData (Entity User)
|
||||
resultSuperUser = _dbrOutput . _1
|
||||
@ -608,12 +626,27 @@ resultSuperCompanySupervised = _dbrOutput . _2 . _unValue
|
||||
resultSuperCompanyReroutes :: Lens' SuperCompanyTableData Word64
|
||||
resultSuperCompanyReroutes = _dbrOutput . _3 . _unValue
|
||||
|
||||
resultSuperCompanies :: Lens' SuperCompanyTableData [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)]
|
||||
resultSuperCompanies = _dbrOutput . _4
|
||||
|
||||
|
||||
instance HasEntity SuperCompanyTableData User where
|
||||
hasEntity = resultSuperUser
|
||||
|
||||
instance HasUser SuperCompanyTableData where
|
||||
hasUser = resultSuperUser . _entityVal
|
||||
|
||||
firmQuerySupervisedBy :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlQuery ()
|
||||
firmQuerySupervisedBy cid mbFltr usr = do
|
||||
(usrSpr :& usrCmp) <- E.from $ E.table @UserSupervisor
|
||||
`E.innerJoin` E.table @UserCompany
|
||||
`E.on` (\(usrSpr :& usrCmp) -> usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser)
|
||||
let basecond = usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
|
||||
E.&&. usrCmp E.^. UserCompanyCompany E.==. E.val cid
|
||||
E.where_ $ maybe basecond ((basecond E.&&.).($ usrSpr)) mbFltr
|
||||
|
||||
firmCountForSupervisor :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlExpr (E.Value Word64)
|
||||
firmCountForSupervisor = ((E.subSelectCount .) .) . firmQuerySupervisedBy
|
||||
|
||||
mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Set UserId), Widget)
|
||||
mkFirmSuperTable isAdmin cid = do
|
||||
@ -621,34 +654,31 @@ mkFirmSuperTable isAdmin cid = do
|
||||
-- fsh = unCompanyKey cid
|
||||
resultDBTable = DBTable{..}
|
||||
where
|
||||
dbtSQLQuery = \usr -> do
|
||||
-- refactor this
|
||||
let subs = do
|
||||
(usrSpr :& usrCmp) <- E.from $ E.table @UserSupervisor
|
||||
`E.innerJoin` E.table @UserCompany
|
||||
`E.on` (\(usrSpr :& usrCmp) -> usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser)
|
||||
E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
|
||||
E.&&. usrCmp E.^. UserCompanyCompany E.==. E.val cid
|
||||
subs' = do
|
||||
(usrSpr :& usrCmp) <- E.from $ E.table @UserSupervisor
|
||||
`E.innerJoin` E.table @UserCompany
|
||||
`E.on` (\(usrSpr :& usrCmp) -> usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser)
|
||||
E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
|
||||
E.&&. usrCmp E.^. UserCompanyCompany E.==. E.val cid
|
||||
E.&&. usrSpr E.^. UserSupervisorRerouteNotifications
|
||||
E.where_ $ E.exists subs
|
||||
return (usr, E.subSelectCount subs, E.subSelectCount subs')
|
||||
dbtSQLQuery = \usr -> do
|
||||
E.where_ $ E.exists $ firmQuerySupervisedBy cid Nothing usr
|
||||
return ( usr
|
||||
, usr & firmCountForSupervisor cid Nothing
|
||||
, usr & firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications))
|
||||
)
|
||||
dbtRowKey = querySuperUser >>> (E.^. UserId)
|
||||
dbtProj = dbtProjId
|
||||
dbtProj = dbtProjSimple $ \(usr, supervised, rerouted) -> do
|
||||
cmps <- E.select $ do
|
||||
(cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
|
||||
E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val (entityKey usr)
|
||||
E.orderBy [E.asc $ cmp E.^. CompanyName]
|
||||
return (cmp E.^. CompanyName, cmp E.^. CompanyShorthand, usrCmp E.^. UserCompanySupervisor)
|
||||
return (usr, supervised, rerouted, cmps)
|
||||
dbtColonnade = formColonnade $ mconcat
|
||||
[ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey))
|
||||
, colUserNameModalHdr MsgTableSupervisor ForProfileDataR
|
||||
, sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultSuperUser -> entUsr) -> cellHasMatrikelnummerLinked entUsr
|
||||
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultSuperCompanies -> cmps) ->
|
||||
intercalate semicolonCell [companyCell cmpShort cmpName isSuper | (E.Value cmpName, E.Value cmpShort, E.Value isSuper) <- cmps]
|
||||
, sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultSuperUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t
|
||||
, sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultSuperUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
|
||||
, colUserEmail
|
||||
, sortable Nothing (i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr
|
||||
, sortable Nothing (i18nCell MsgTableCompanyNrEmpRerouted ) $ \(view resultSuperCompanyReroutes -> nr) -> wgtCell $ word2widget nr
|
||||
, sortable (Just "supervised") (i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr
|
||||
, sortable (Just "rerouted") (i18nCell MsgTableCompanyNrEmpRerouted ) $ \(view resultSuperCompanyReroutes -> nr) -> wgtCell $ word2widget nr
|
||||
]
|
||||
dbtSorting = mconcat
|
||||
[ single $ sortUserNameLink querySuperUser
|
||||
@ -656,6 +686,14 @@ mkFirmSuperTable isAdmin cid = do
|
||||
, singletonMap "matriculation" $ SortColumn $ querySuperUser >>> (E.^. UserMatrikelnummer)
|
||||
, singletonMap "personal-number" $ SortColumn $ querySuperUser >>> (E.^. UserCompanyPersonalNumber)
|
||||
, singletonMap "postal-pref" $ SortColumn $ querySuperUser >>> (E.^. UserPrefersPostal)
|
||||
, singletonMap "supervised" $ SortColumn $ querySuperUser >>> firmCountForSupervisor cid Nothing
|
||||
, singletonMap "rerouted" $ SortColumn $ querySuperUser >>> firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications))
|
||||
, singletonMap "user-company" $ SortColumn (\row -> E.subSelect $ do
|
||||
(cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
|
||||
E.where_ $ usrCmp E.^. UserCompanyUser E.==. querySuperUser row E.^. UserId
|
||||
E.orderBy [E.asc $ cmp E.^. CompanyName]
|
||||
return (cmp E.^. CompanyName)
|
||||
)
|
||||
]
|
||||
dbtFilter = mconcat
|
||||
[ single $ fltrUserNameEmail querySuperUser
|
||||
@ -710,9 +748,12 @@ postFirmSupersR fsh = do
|
||||
<*> mkFirmSuperTable isAdmin fshId
|
||||
|
||||
formResult fsprRes $ \case
|
||||
(FirmSuperActNotifyData , fids) -> addMessage Info $ text2Html $ "Notify " <> tshow (length fids) <> " supervisors. TODO"
|
||||
(FirmSuperActRMSuperDefData, fids) -> addMessage Info $ text2Html $ "Remove " <> tshow (length fids) <> " default supervisors. TODO"
|
||||
(FirmSuperActRMSuperAllData, fids) -> addMessage Info $ text2Html $ "Make " <> tshow (length fids) <> " default and active supervisors. TODO"
|
||||
(FirmSuperActNotifyData , fids) -> do
|
||||
cuids <- traverse encrypt $ Set.toList fids :: Handler [CryptoUUIDUser]
|
||||
redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])
|
||||
|
||||
|
||||
siteLayout (citext2widget fsh) $ do
|
||||
setTitle $ citext2Html fsh
|
||||
@ -735,3 +776,81 @@ postFirmSupersR fsh = do
|
||||
<section>
|
||||
^{fsprTable}
|
||||
|]
|
||||
|
||||
|
||||
getFirmCommR, postFirmCommR :: CompanyShorthand -> Handler Html
|
||||
getFirmCommR = postFirmCommR
|
||||
postFirmCommR fsh = handleFirmCommR (SomeRoute $ FirmUsersR fsh) (Just fsh)
|
||||
|
||||
|
||||
getFirmsCommR, postFirmsCommR :: Handler Html
|
||||
getFirmsCommR = postFirmsCommR
|
||||
postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR) Nothing
|
||||
|
||||
|
||||
handleFirmCommR :: SomeRoute UniWorX -> Maybe CompanyShorthand -> Handler Html
|
||||
handleFirmCommR ultDest mbFsh = do
|
||||
let decryptUserId :: CryptoUUIDUser -> Handler UserId
|
||||
decryptUserId = decrypt
|
||||
|
||||
mbCid = CompanyKey <$> mbFsh
|
||||
|
||||
{-
|
||||
queryEmpys :: CompanyId -> Handler [UserId]
|
||||
queryEmpys cid = E.unValue <<$>> runDB (E.select $ do
|
||||
(emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser)
|
||||
E.where_ $ uc E.^. UserCompanyCompany E.==. E.val cid
|
||||
return $ emp E.^. UserId
|
||||
)
|
||||
-}
|
||||
|
||||
selected <- mapM decryptUserId =<< lookupGlobalGetParams GetRecipient -- retrieve selected users
|
||||
empys <- ifMaybeM mbCid selected (\cid -> -- get all employees or stick with selected users, if no company was pre-selected (to limit choices)
|
||||
E.unValue <<$>> runDB (E.select $ do
|
||||
(emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser)
|
||||
E.where_ $ uc E.^. UserCompanyCompany E.==. E.val cid
|
||||
return $ emp E.^. UserId
|
||||
))
|
||||
|
||||
cmpys <- E.unValue <<$>> runDB (E.select $ do
|
||||
cmpy <- E.from $ E.table @Company
|
||||
E.where_ $ E.exists $ do
|
||||
usrCmpy <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usrCmpy E.^. UserCompanyUser `E.in_` E.valList selected
|
||||
E.&&. usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
|
||||
return $ cmpy E.^.CompanyId
|
||||
)
|
||||
let queryCmpy :: Bool -> CompanyId -> E.SqlQuery (E.SqlExpr (Entity User))
|
||||
queryCmpy sORe acid = do
|
||||
(usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser)
|
||||
E.where_ $ uc E.^. UserCompanyCompany E.==. E.val acid
|
||||
E.&&. (if sORe
|
||||
then -- supervisors only
|
||||
E.exists $ do
|
||||
usrSpr <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
|
||||
E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList empys
|
||||
else -- selected employees for this company only
|
||||
usr E.^. UserId `E.in_` E.valList empys
|
||||
)
|
||||
return usr
|
||||
|
||||
commR CommunicationRoute
|
||||
{ crHeading = SomeMessage $ maybe MsgFirmsNotification MsgFirmNotification mbFsh
|
||||
, crUltDest = ultDest
|
||||
, crJobs = crJobsFirmCommunication mbFsh -- :: Communication -> ConduitT () Job (YesodDB UniWorX) ()
|
||||
, crTestJobs = crTestFirmCommunication mbFsh -- :: Communication -> ConduitT () Job (YesodDB UniWorX) ()
|
||||
, crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult
|
||||
, crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))]
|
||||
[(RGFirmSupervisor $ unCompanyKey acid, queryCmpy True acid) | acid <- cmpys ] <>
|
||||
[(RGFirmEmployees $ unCompanyKey acid, queryCmpy False acid) | acid <- cmpys, maybe True (acid ==) mbCid]
|
||||
}
|
||||
|
||||
{- Auswahlbox für Mitteilung:
|
||||
Wenn Firma gewählt, dann zeige:
|
||||
Alle Supervisor von Leuten in X, gruppiert nach deren Firma
|
||||
Alle Teilnehmer von X
|
||||
Wenn keine Firma gewählt, dann zeige:
|
||||
Alle Supervisor von gewählten Leuten, gruppiert nach deren Firma
|
||||
Alle gewählten Personen, gruppiert nach deren Firma
|
||||
-}
|
||||
|
||||
@ -8,6 +8,7 @@ module Handler.Utils.Communication
|
||||
, Communication(..)
|
||||
, commR
|
||||
, crJobsCourseCommunication, crTestJobsCourseCommunication
|
||||
, crJobsFirmCommunication, crTestFirmCommunication
|
||||
-- * Re-Exports
|
||||
, Job(..)
|
||||
) where
|
||||
@ -27,9 +28,11 @@ import qualified Data.Conduit.Combinators as C
|
||||
|
||||
|
||||
data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors | RGCourseTutors | RGCourseParticipantsInTutorial | RGCourseUnacceptedApplicants
|
||||
-- WARNING: no RenderMessage instance, but a pattern match in templates/widgets/communication/recipientLayout.hamlet that needs to be extended
|
||||
| RGTutorialParticipants CryptoUUIDTutorial
|
||||
| RGExamRegistered CryptoUUIDExam
|
||||
| RGSheetSubmittor CryptoUUIDSheet
|
||||
| RGFirmSupervisor CompanyShorthand | RGFirmEmployees CompanyShorthand
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
|
||||
instance LowerBounded RecipientGroup where
|
||||
@ -107,6 +110,28 @@ crTestJobsCourseCommunication jCourse comm = do
|
||||
crJobsCourseCommunication jCourse comm' .| C.filter ((== Right jSender) . jRecipientEmail)
|
||||
|
||||
|
||||
crJobsFirmCommunication :: Maybe CompanyShorthand -> Communication -> ConduitT () Job (YesodDB UniWorX) ()
|
||||
crJobsFirmCommunication jCompany Communication{..} = do
|
||||
jSender <- requireAuthId
|
||||
let jMailContent = cContent
|
||||
allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients
|
||||
jMailObjectUUID <- liftIO getRandom
|
||||
jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case
|
||||
Left email -> return . Address Nothing $ CI.original email
|
||||
Right rid -> userAddress <$> getJust rid
|
||||
forM_ allRecipients $ \jRecipientEmail ->
|
||||
yield JobSendFirmCommunication{..}
|
||||
|
||||
crTestFirmCommunication :: Maybe CompanyShorthand -> Communication -> ConduitT () Job (YesodDB UniWorX) ()
|
||||
crTestFirmCommunication jCompany comm = do
|
||||
jSender <- requireAuthId
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
let comm' = comm & _cContent . _ccSubject %~ Just . mr . MsgCommCourseTestSubject . fromMaybe (mr MsgUtilCommFirmSubject)
|
||||
crJobsFirmCommunication jCompany comm' .| C.filter ((== Right jSender) . jRecipientEmail)
|
||||
|
||||
|
||||
|
||||
|
||||
commR :: CommunicationRoute -> Handler Html
|
||||
commR CommunicationRoute{..} = do
|
||||
cUser <- maybeAuth
|
||||
@ -132,7 +157,7 @@ commR CommunicationRoute{..} = do
|
||||
let
|
||||
lookupUser :: UserId -> User
|
||||
lookupUser lId
|
||||
= entityVal . unsafeHead . filter ((== lId) . entityKey) $ concat (view _2 <$> suggestedRecipients) ++ chosenRecipients
|
||||
= entityVal . unsafeHead . filter ((== lId) . entityKey) $ concatMap (view _2) suggestedRecipients ++ chosenRecipients
|
||||
|
||||
let chosenRecipients' = Map.fromList $
|
||||
[ ( (BoundedPosition $ RecipientGroup g, pos)
|
||||
|
||||
@ -29,6 +29,9 @@ type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with Wit
|
||||
spacerCell :: IsDBTable m a => DBCell m a
|
||||
spacerCell = cell [whamlet| |]
|
||||
|
||||
semicolonCell :: IsDBTable m a => DBCell m a
|
||||
semicolonCell = cell [whamlet|; |]
|
||||
|
||||
tellCell :: IsDBTable m a => a -> DBCell m a -> DBCell m a
|
||||
tellCell = flip mappend . writerCell . tell
|
||||
|
||||
|
||||
@ -164,7 +164,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
|
||||
maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut qprefix identsInUse)
|
||||
-- runMaybeT $ do
|
||||
-- lid <- MaybeT $ randomLMSIdentBu qprefix identsInUse
|
||||
-- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid
|
||||
-- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid
|
||||
inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser
|
||||
case inserted of
|
||||
Nothing -> do
|
||||
@ -187,7 +187,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
||||
quali <- getJust qid -- may throw an error, aborting the job
|
||||
let qshort = CI.original $ qualificationShorthand quali
|
||||
$logInfoS "LMS" $ "Processing e-learning results for qualification " <> qshort
|
||||
now <- liftIO getCurrentTime
|
||||
now <- liftIO getCurrentTime
|
||||
-- end users that expired by doing nothing
|
||||
expiredUsers <- E.select $ do
|
||||
(quser :& luser) <- E.from $
|
||||
@ -201,9 +201,10 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
||||
-- E.&&. E.isNothing (luser E.^. LmsUserStatus)
|
||||
-- E.&&. E.isNothing (luser E.^. LmsUserEnded)
|
||||
E.&&. E.not_ (validQualification now quser)
|
||||
pure (quser E.^. QualificationUserUser, luser E.?. LmsUserId)
|
||||
nrBlocked <- qualificationUserBlocking qid (E.unValue . fst <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once
|
||||
let expiredLearners = [luid | (_, E.Value (Just luid)) <- expiredUsers]
|
||||
pure (luser E.?. LmsUserId, quser E.^. QualificationUserUser)
|
||||
nrBlocked <- qualificationUserBlocking qid (E.unValue . snd <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once
|
||||
let expiredLearners = [ luid | (E.Value (Just luid), _) <- expiredUsers ]
|
||||
-- let expiredLearners = catMaybes (E.unValue . fst <$> expiredUsers)
|
||||
nrExpired <- E.updateCount $ \luser -> do
|
||||
E.set luser [LmsUserStatus E.=. E.justVal LmsExpired, LmsUserStatusDay E.=. E.justVal now]
|
||||
E.where_ $ E.isNothing (luser E.^. LmsUserStatus)
|
||||
@ -213,7 +214,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
||||
|
||||
when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers
|
||||
notifyInvalidDrivers <- E.select $ do
|
||||
(quser :& qblock) <- E.from $
|
||||
(quser :& qblock) <- E.from $
|
||||
E.table @QualificationUser
|
||||
`E.leftJoin` E.table @QualificationUserBlock
|
||||
`E.on` (\(quser :& qblock) -> qblock E.?. QualificationUserBlockQualificationUser E.?=. quser E.^. QualificationUserId
|
||||
@ -266,7 +267,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
|
||||
act = whenM (exists [LmsReportQualification ==. qid]) $ do -- executing twice must be prohibited due to assertion that ALL learners are always sent (D fails otherwise)
|
||||
now <- liftIO getCurrentTime
|
||||
-- DEBUG 2rows; remove later
|
||||
totalrows <- count [LmsReportQualification ==. qid]
|
||||
totalrows <- count [LmsReportQualification ==. qid]
|
||||
$logInfoS "LMS" $ "Report processing " <> tshow totalrows <> " rows for qualification " <> tshow qid
|
||||
when (totalrows > 0) $ do
|
||||
let -- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now -- no longer necessary, since LMS reports dates only
|
||||
@ -292,7 +293,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
|
||||
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
|
||||
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners
|
||||
E.&&. lrFltr luser lreport
|
||||
return (luser, lreport)
|
||||
return (luser, lreport)
|
||||
-- A) reset status for learners that had their tries just resetted as indicated by LmsOpen
|
||||
E.update $ \luser -> do
|
||||
E.set luser [ LmsUserStatus E.=. E.nothing
|
||||
@ -315,13 +316,13 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
|
||||
in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner
|
||||
-- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit), notified during expiry
|
||||
let lrFltrBlock luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed
|
||||
procBlock (Entity luid luser, Entity _ lreport) = do
|
||||
procBlock (Entity luid luser, Entity _ lreport) = do
|
||||
let repDay = lmsReportDate lreport <|> Just now
|
||||
ok_block <- qualificationUserBlocking qid [lmsUserUser luser] False (lmsReportDate lreport) (Right $ QualificationBlockFailedELearningBy $ lmsUserIdent luser) True -- only valid qualifications are blocked; transcribes to audit log
|
||||
update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. repDay]
|
||||
return $ Sum ok_block
|
||||
in lrepQry lrFltrBlock
|
||||
>>= foldMapM procBlock
|
||||
in lrepQry lrFltrBlock
|
||||
>>= foldMapM procBlock
|
||||
>>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " status set to blocked for qualification " <> tshow qid -- debug, remove later
|
||||
-- D) renew qualifications for all successfull learners
|
||||
let lrFltrSuccess luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsPassed
|
||||
@ -329,14 +330,14 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
|
||||
let repDay = lmsReportDate lreport <|> Just now
|
||||
reason = Just $ Right $ QualificationRenewELearningBy $ lmsUserIdent luser
|
||||
-- LMS WORKAROUND 2: [supposedly fixed now] sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
|
||||
-- let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning
|
||||
-- let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning
|
||||
-- ok_unblock <- qualificationUserUnblockByReason qid [lmsUserUser luser] repTime (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log
|
||||
-- when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid} having success reported after initially failed e-learning|])
|
||||
-- END LMS WORKAROUND 2
|
||||
-- END LMS WORKAROUND 2
|
||||
ok_renew <- renewValidQualificationUsers qid reason repDay [lmsUserUser luser]-- only valid qualifications are truly renewed; transcribes to audit log
|
||||
update luid [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. repDay]
|
||||
return $ Sum ok_renew
|
||||
in lrepQry lrFltrSuccess
|
||||
in lrepQry lrFltrSuccess
|
||||
>>= foldMapM procRenew
|
||||
>>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " renewed and status set to success for qualification " <> tshow qid -- debug, remove later
|
||||
-- E) mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected)
|
||||
@ -379,8 +380,8 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
|
||||
>>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as unlocked and received for qualification " <> tshow qid -- debug, remove later
|
||||
updateReceivedLocked True
|
||||
>>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as locked and received for qualification " <> tshow qid -- debug, remove later
|
||||
-- G) Truncate LmsReport for qid, after updating log
|
||||
E.insertSelect $ do
|
||||
-- G) Truncate LmsReport for qid, after updating log
|
||||
E.insertSelect $ do
|
||||
lreport <- E.from $ E.table @LmsReport
|
||||
let samelog = E.subSelect $ do
|
||||
lrl <- E.from $ E.table @LmsReportLog
|
||||
@ -388,7 +389,8 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
|
||||
E.&&. lrl E.^. LmsReportLogIdent E.==. lreport E.^. LmsReportIdent
|
||||
E.orderBy [E.desc $ lrl E.^. LmsReportLogTimestamp]
|
||||
return $ lreport E.^. LmsReportResult E.==. lrl E.^. LmsReportLogResult
|
||||
E.&&. lreport E.^. LmsReportLock E.==. lrl E.^. LmsReportLogLock
|
||||
E.&&. lreport E.^. LmsReportLock E.==. lrl E.^. LmsReportLogLock
|
||||
E.&&. E.not_ (lrl E.^. LmsReportLogMissing)
|
||||
E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid
|
||||
E.&&. E.not_ (E.isTrue samelog)
|
||||
return (LmsReportLog
|
||||
@ -397,7 +399,31 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
|
||||
E.<&> (lreport E.^. LmsReportDate )
|
||||
E.<&> (lreport E.^. LmsReportResult )
|
||||
E.<&> (lreport E.^. LmsReportLock )
|
||||
E.<&> (lreport E.^. LmsReportTimestamp ))
|
||||
E.<&> (lreport E.^. LmsReportTimestamp )
|
||||
E.<&> E.false)
|
||||
E.insertSelect $ do
|
||||
lrl <- E.from $ E.table @LmsReportLog
|
||||
E.where_ $ E.not_ (lrl E.^. LmsReportLogMissing)
|
||||
E.&&. lrl E.^. LmsReportLogQualification E.==. E.val qid
|
||||
E.&&. E.notExists (do
|
||||
lreport <- E.from $ E.table @LmsReport
|
||||
E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid
|
||||
E.&&. lreport E.^. LmsReportIdent E.==. lrl E.^. LmsReportLogIdent
|
||||
)
|
||||
E.&&. E.notExists (do
|
||||
lrl_old <- E.from $ E.table @LmsReportLog
|
||||
E.where_ $ lrl_old E.^. LmsReportLogQualification E.==. E.val qid
|
||||
E.&&. lrl_old E.^. LmsReportLogIdent E.==. lrl E.^. LmsReportLogIdent
|
||||
E.&&. lrl_old E.^. LmsReportLogTimestamp E.>. lrl E.^. LmsReportLogTimestamp
|
||||
)
|
||||
return (LmsReportLog
|
||||
E.<# (lrl E.^. LmsReportLogQualification)
|
||||
E.<&> (lrl E.^. LmsReportLogIdent )
|
||||
E.<&> E.nothing
|
||||
E.<&> (lrl E.^. LmsReportLogResult )
|
||||
E.<&> (lrl E.^. LmsReportLogLock )
|
||||
E.<&> E.val now
|
||||
E.<&> E.true)
|
||||
repProc <- deleteWhereCount [LmsReportQualification ==. qid]
|
||||
$logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|]
|
||||
|
||||
@ -489,7 +515,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act
|
||||
| otherwise -> return () -- users likely not yet started
|
||||
|
||||
(Entity luid luser, Just (Entity _lulid lulist)) -> do
|
||||
let lReceived = lmsUserlistTimestamp lulist
|
||||
let lReceived = lmsUserlistTimestamp lulist
|
||||
update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications
|
||||
|
||||
when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available
|
||||
|
||||
@ -4,6 +4,7 @@
|
||||
|
||||
module Jobs.Handler.SendCourseCommunication
|
||||
( dispatchJobSendCourseCommunication
|
||||
, dispatchJobSendFirmCommunication
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -37,7 +38,35 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours
|
||||
_mailFrom .= userAddressFrom sender
|
||||
addMailHeader "Cc" [st|#{mr MsgCommUndisclosedRecipients}:;|]
|
||||
addMailHeader "Auto-Submitted" "no"
|
||||
setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgCommCourseSubject) SomeMessage ccSubject
|
||||
setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgUtilCommCourseSubject) SomeMessage ccSubject
|
||||
addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/courseCommunication.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
forM_ ccAttachments $ addPart' . toMailPart
|
||||
when (jRecipientEmail == Right jSender) $
|
||||
addPart' $ do
|
||||
partIsAttachmentCsv MsgCommAllRecipients
|
||||
toMailPart (MsgCommAllRecipientsSheet, toDefaultOrderedCsvRendered jAllRecipientAddresses)
|
||||
|
||||
|
||||
dispatchJobSendFirmCommunication :: Either UserEmail UserId
|
||||
-> Set Address
|
||||
-> Maybe CompanyShorthand
|
||||
-> UserId
|
||||
-> UUID
|
||||
-> CommunicationContent
|
||||
-> JobHandler UniWorX
|
||||
dispatchJobSendFirmCommunication jRecipientEmail jAllRecipientAddresses _jCompany jSender jMailObjectUUID CommunicationContent{..} = JobHandlerException $ do
|
||||
-- (sender,mbComp) <- runDB $ (,)
|
||||
-- <$> getJust jSender
|
||||
-- <*> ifMaybeM jCompany Nothing get
|
||||
sender <- runDB $ getJust jSender
|
||||
either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do
|
||||
MsgRenderer mr <- getMailMsgRenderer
|
||||
|
||||
void $ setMailObjectUUID jMailObjectUUID
|
||||
_mailFrom .= userAddressFrom sender
|
||||
addMailHeader "Cc" [st|#{mr MsgCommUndisclosedRecipients}:;|]
|
||||
addMailHeader "Auto-Submitted" "no"
|
||||
setSubjectI $ maybe (SomeMessage MsgUtilCommFirmSubject) SomeMessage ccSubject
|
||||
addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/courseCommunication.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
forM_ ccAttachments $ addPart' . toMailPart
|
||||
when (jRecipientEmail == Right jSender) $
|
||||
|
||||
@ -74,6 +74,13 @@ data Job
|
||||
, jMailObjectUUID :: UUID
|
||||
, jMailContent :: CommunicationContent
|
||||
}
|
||||
| JobSendFirmCommunication { jRecipientEmail :: Either UserEmail UserId
|
||||
, jAllRecipientAddresses :: Set Address
|
||||
, jCompany :: Maybe CompanyShorthand
|
||||
, jSender :: UserId
|
||||
, jMailObjectUUID :: UUID
|
||||
, jMailContent :: CommunicationContent
|
||||
}
|
||||
| JobInvitation { jInviter :: Maybe UserId
|
||||
, jInvitee :: UserEmail
|
||||
, jInvitationUrl :: Text
|
||||
|
||||
@ -139,7 +139,8 @@ migrateManual = do
|
||||
, ("idx_qualification_user_block_unblock","CREATE INDEX idx_qualification_user_block_unblock ON \"qualification_user_block\" (\"unblock\")")
|
||||
, ("idx_qualification_user_block_from" ,"CREATE INDEX idx_qualification_user_block_from ON \"qualification_user_block\" (\"from\")")
|
||||
, ("idx_print_job_apc_ident" ,"CREATE INDEX idx_print_job_apc_ident ON \"print_job\" (\"apc_ident\")")
|
||||
, ("idx_user_avs_card_person_id" ,"CREATE INDEX idx_user_avs_card_person_id ON \"user_avs_card\" (\"person_id\")")
|
||||
, ("idx_user_avs_card_person_id" ,"CREATE INDEX idx_user_avs_card_person_id ON \"user_avs_card\" (\"person_id\")")
|
||||
, ("idx_lms_report_log_q_ident_time" ,"CREATE INDEX idx_lms_report_log_q_ident_time ON \"lms_report_log\" (\"qualification\",\"ident\",\"timestamp\")")
|
||||
]
|
||||
where
|
||||
addIndex :: Text -> Sql -> Migration
|
||||
|
||||
@ -23,8 +23,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
<tr .table__row .table__row--head>
|
||||
<th .table__th>_{MsgTableCompanyNrSupersDefault}
|
||||
<th .table__th>_{MsgTableCompanyNrRerouteDefault}
|
||||
<th .table__th>_{MsgPrefersPostal}
|
||||
<th .table__th>
|
||||
<th .table__th colspan=2>_{MsgPrefersPostal}
|
||||
<tr .table__row>
|
||||
<td .table__td>#{nrCompanySupervisors}
|
||||
<td .table__td>#{nrCompanyDefaultReroutes}
|
||||
|
||||
@ -31,6 +31,10 @@ $if not (null activeCategories)
|
||||
^{rgSheetSubmittorCaption sid}
|
||||
$of RecipientGroup RGCourseUnacceptedApplicants
|
||||
_{MsgRGCourseUnacceptedApplicants}
|
||||
$of RecipientGroup (RGFirmSupervisor fsh)
|
||||
_{MsgFirmSupervisorOf fsh}
|
||||
$of RecipientGroup (RGFirmEmployees fsh)
|
||||
_{MsgFirmEmployeeOf fsh}
|
||||
|
||||
$if hasContent category
|
||||
<fieldset .recipient-category__fieldset uw-interactive-fieldset .interactive-fieldset__target data-conditional-input=#{checkedIdent category}>
|
||||
|
||||
Reference in New Issue
Block a user