@@ -826,7 +826,7 @@ postAdminAvsUserR uuid = do
-- mkCardsWgt :: (Maybe CompanyName, Map CompanyName Widget, Widget) -> Set AvsDataPersonCard -> Widget
mkCardsWgt :: (Maybe CompanyName, Widget) -> Set AvsDataPersonCard -> Widget
- mkCardsWgt (mbPrimName, swForm) crds
+ mkCardsWgt (mbPrimName, swForm) crds
| null crds = [whamlet|_{MsgAvsCardsEmpty}|]
| otherwise = do
let hasCompany = isJust $ Set.foldr ((<|>) . avsDataFirm) Nothing crds -- some if, since a true AVS status query never delivers values for these fields, but queryAvsFullStatus-workaround does
@@ -844,7 +844,7 @@ postAdminAvsUserR uuid = do
$if hasIssueDate
| _{MsgTableAvsCardIssueDate}
$if hasValidToDate
- | _{MsgTableAvsCardValidTo}
+ | _{MsgTableAvsCardValidTo}
$if hasCompany
| _{MsgTableCompany}
| _{MsgAvsPrimaryCompany}
@@ -865,7 +865,7 @@ postAdminAvsUserR uuid = do
|
$maybe d <- avsDataIssueDate
^{formatTimeW SelFormatDate d}
- $if hasValidToDate
+ $if hasValidToDate
|
$maybe d <- avsDataValidTo
^{formatTimeW SelFormatDate d}
@@ -903,13 +903,13 @@ getProblemAvsErrorR = do
E.where_ $ E.isJust $ usravs E.^. UserAvsLastSynchError
return (usravs, user) -- , E.substring (usravs E.^. UserAvsLastSynchError) (E.val ("'#\"%#\" %'") (E.val "#")) -- needs a different type on substring
qerryUsrAvs :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserAvs)
- qerryUsrAvs = $(E.sqlIJproj 2 1)
+ qerryUsrAvs = $(E.sqlIJproj 2 1)
qerryUser :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User)
qerryUser = $(E.sqlIJproj 2 2)
reserrUsrAvs :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity UserAvs)
reserrUsrAvs = _dbrOutput . _1
-- reserrUser :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity User)
- -- reserrUser = _dbrOutput . _2
+ -- reserrUser = _dbrOutput . _2
dbtRowKey = qerryUsrAvs >>> (E.^. UserAvsId)
dbtProj = dbtProjId
dbtColonnade = dbColonnade $ mconcat
@@ -949,4 +949,3 @@ getProblemAvsErrorR = do
siteLayoutMsg MsgMenuAvsSynchError $ do
setTitleI MsgMenuAvsSynchError
[whamlet|^{avsSyncErrTbl}|]
-
\ No newline at end of file
diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs
index 611c52e70..cda46ab7f 100644
--- a/src/Handler/Course/Register.hs
+++ b/src/Handler/Course/Register.hs
@@ -68,7 +68,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
| otherwise
-> return $ FormSuccess ()
- mayViewCourseAfterDeregistration <- liftHandler . runDB $ E.selectExists . E.from $ \course -> do
+ mayViewCourseAfterDeregistration <- liftHandler . runDBRead $ E.selectExists . E.from $ \course -> do
E.where_ $ course E.^. CourseId E.==. E.val cid
E.&&. ( isSchoolAdminLike muid ata (course E.^. CourseSchool)
E.||. mayEditCourse muid ata course
@@ -92,7 +92,7 @@ courseMayReRegister :: Entity Course -> DB Bool
courseMayReRegister (Entity cid Course{..}) = do
registrations <- count [ CourseParticipantState ==. CourseParticipantActive, CourseParticipantCourse ==. cid ]
let capacity = maybe True (>= registrations) courseCapacity
-
+
wouldHaveWriteAccessTo [(AuthCapacity, capacity), (AuthCourseRegistered, False)] $ CourseR courseTerm courseSchool courseShorthand CRegisterR
diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs
index d5d092777..666f4968d 100644
--- a/src/Handler/Firm.hs
+++ b/src/Handler/Firm.hs
@@ -119,7 +119,7 @@ firmActionHandler route isAdmin = flip formResult faHandler
faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected
faHandler (FirmActNotifyData, Set.toList -> fids) = do
- usrs <- runDB $ E.select $ E.distinct $ do
+ usrs <- runDBRead $ 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 fids
return $ usr E.^. UserId
@@ -325,34 +325,33 @@ addDefaultSupervisorsAll mutualSupervision cids = do
------------------------------
-- repeatedly useful queries
+usrSuperiorCompanies :: E.SqlExpr (Entity Company) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery ()
+-- usrSuperiorCompanies :: E.SqlExpr (E.Value CompanyId) -> E.SqlExpr (Entity UserCompany) -> E.SqlQuery (Entity UserCompany) -- possible alternative
+usrSuperiorCompanies cmp usr = do
+ othr <- E.from $ E.table @UserCompany
+ E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority
+ E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser
+ E.&&. othr E.^. UserCompanyCompany E.!=. cmp E.^. CompanyId -- redundant due to > above, but likely performance improving
+ -- return othr
+
fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery ()
fromUserCompany mbFltr cmpy = do
usrCmpy <- E.from $ E.table @UserCompany
let basecond = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
E.where_ $ maybe basecond ((basecond E.&&.).($ usrCmpy)) mbFltr
-firmCountUsers :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
-firmCountUsers = E.subSelectCount . fromUserCompany Nothing
+firmCountUsers :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
+firmCountUsers = E.subSelectCount . fromUserCompany Nothing
-firmCountUsersPrimary :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
-firmCountUsersPrimary cmp = E.subSelectCount $ fromUserCompany (Just primFltr) cmp
+firmCountUsersPrimary :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
+firmCountUsersPrimary cmp = E.subSelectCount $ fromUserCompany (Just primFltr) cmp
where
- primFltr usr = E.notExists (do
- othr <- E.from $ E.table @UserCompany
- E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority
- E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser
- E.&&. othr E.^. UserCompanyCompany E.!=. cmp E.^. CompanyId -- redundant due to > above, but likely performance improving
- )
+ primFltr = E.notExists . usrSuperiorCompanies cmp
-firmCountUsersSecondary :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
+firmCountUsersSecondary :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountUsersSecondary cmp = E.subSelectCount $ fromUserCompany (Just primFltr) cmp
where
- primFltr usr = E.exists (do
- othr <- E.from $ E.table @UserCompany
- E.where_ $ othr E.^. UserCompanyPriority E.>. usr E.^. UserCompanyPriority
- E.&&. othr E.^. UserCompanyUser E.==. usr E.^. UserCompanyUser
- E.&&. othr E.^. UserCompanyCompany E.!=. cmp E.^. CompanyId -- redundant due to > above, but likely performance improving
- )
+ primFltr = E.exists . usrSuperiorCompanies cmp
firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor))
@@ -1375,14 +1374,14 @@ handleFirmCommR ultDest cs = do
csKeys = CompanyKey <$> cs
mbUser <- maybeAuthId
-- get employees of chosen companies
- empys <- mkCompanyUsrList <$> runDB (E.select $ do
+ empys <- mkCompanyUsrList <$> runDBRead (E.select $ do
(emp :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& cmp) -> emp E.^. UserId E.==. cmp E.^. UserCompanyUser)
E.where_ $ cmp E.^. UserCompanyCompany `E.in_` E.valList csKeys
E.orderBy [E.ascNullsFirst $ cmp E.^. UserCompanyCompany]
return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId)
)
-- get supervisors of employees
- sprs <- mkCompanyUsrList <$> runDB (E.select $ do
+ sprs <- mkCompanyUsrList <$> runDBRead (E.select $ do
(spr :& cmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(spr :& cmp) -> spr E.^. UserId E.=?. cmp E.?. UserCompanyUser)
E.where_ $ (E.isTrue (cmp E.?. UserCompanySupervisor) E.&&. cmp E.?. UserCompanyCompany `E.in_` E.justValList csKeys)
E.||. (spr E.^. UserId E.=?. E.val mbUser)
diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs
index db45e0f11..b86f41ba9 100644
--- a/src/Handler/LMS.hs
+++ b/src/Handler/LMS.hs
@@ -19,7 +19,7 @@ module Handler.LMS
, getLmsFakeR , postLmsFakeR
, getLmsUserR
, getLmsUserSchoolR
- , getLmsUserAllR
+ , getLmsUserAllR
)
where
@@ -81,11 +81,11 @@ postLmsAllR = do
mbBtnForm <- if not isAdmin then return Nothing else do
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonManualLms)
case btnResult of
- (FormSuccess BtnLmsEnqueue) ->
- queueJob' JobLmsQualificationsEnqueue
+ (FormSuccess BtnLmsEnqueue) ->
+ queueJob' JobLmsQualificationsEnqueue
>> addMessage Info "Einreihung ablaufender Qualifikationen zum LMS wird nun im Hintergund durchgeführt."
- (FormSuccess BtnLmsDequeue) ->
- queueJob' JobLmsQualificationsDequeue
+ (FormSuccess BtnLmsDequeue) ->
+ queueJob' JobLmsQualificationsDequeue
>> addMessage Info "Benachrichtigung abgelaufener Qualifikationen und Aufräumen beendeter LMS Nutzer wird im Hintergund ausgeführt."
FormMissing -> return ()
_other -> addMessage Warning "Kein korrekter LMS Knopf erkannt"
@@ -112,20 +112,20 @@ resultAllQualificationActive = _dbrOutput . _2 . _unValue
resultAllQualificationTotal :: Lens' AllQualificationTableData Word64
resultAllQualificationTotal = _dbrOutput . _3 . _unValue
-
+
mkLmsAllTable :: Bool -> Int -> DB (Any, Widget)
mkLmsAllTable isAdmin lmsDeletionDays = do
- svs <- getSupervisees
+ svs <- getSupervisees
let
resultDBTable = DBTable{..}
where
dbtSQLQuery quali = do
- let filterSvs luser = luser Ex.^. LmsUserQualification Ex.==. quali Ex.^. QualificationId
+ let filterSvs luser = luser Ex.^. LmsUserQualification Ex.==. quali Ex.^. QualificationId
Ex.&&. (E.val isAdmin E.||. luser Ex.^. LmsUserUser `Ex.in_` E.vals svs)
- cusers = Ex.subSelectCount $ do
+ cusers = Ex.subSelectCount $ do
luser <- Ex.from $ Ex.table @LmsUser
- Ex.where_ $ filterSvs luser
- cactive = Ex.subSelectCount $ do
+ Ex.where_ $ filterSvs luser
+ cactive = Ex.subSelectCount $ do
luser <- Ex.from $ Ex.table @LmsUser
Ex.where_ $ filterSvs luser Ex.&&. E.isNothing (luser E.^. LmsUserStatus)
-- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem
@@ -155,15 +155,15 @@ mkLmsAllTable isAdmin lmsDeletionDays = do
foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationAuditDuration)
, sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart)
$ tickmarkCell . view (resultAllQualification . _qualificationElearningStart)
- , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip)
+ , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip)
$ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char
- , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip)
+ , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip)
$ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) ->
let icn = IconOK -- change icon here, if desired
- in case mbSapId of
+ in case mbSapId of
Nothing -> mempty
Just sapId | isAdmin -> cellTooltipIcon (Just icn) (text2message sapId) mempty
- Just _ -> iconCell icn
+ Just _ -> iconCell icn
, adminable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip)
$ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n
, adminable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal
@@ -342,7 +342,7 @@ instance HasEntity LmsTableData QualificationUser where
hasEntity = resultQualUser
instance HasQualificationUser LmsTableData where
- hasQualificationUser = resultQualUser . _entityVal
+ hasQualificationUser = resultQualUser . _entityVal
data LmsTableAction = LmsActNotify
| LmsActRenewNotify
@@ -351,7 +351,7 @@ data LmsTableAction = LmsActNotify
| LmsActRestart
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
deriving anyclass (Universe, Finite)
-
+
nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''LmsTableAction id
@@ -360,12 +360,12 @@ data LmsTableActionData = LmsActNotifyData
| LmsActRenewPinData -- no longer used
| LmsActResetData
{ lmsActRestartExtend :: Maybe Integer
- , lmsActRestartUnblock :: Maybe Bool
+ , lmsActRestartUnblock :: Maybe Bool
, lmsActRestartNotify :: Maybe Bool
}
- | LmsActRestartData
+ | LmsActRestartData
{ lmsActRestartExtend :: Maybe Integer
- , lmsActRestartUnblock :: Maybe Bool
+ , lmsActRestartUnblock :: Maybe Bool
, lmsActRestartNotify :: Maybe Bool
}
deriving (Eq, Ord, Read, Show, Generic)
@@ -407,14 +407,14 @@ lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.Left
E.on $ user E.^. UserId E.==. lmsUser E.^. LmsUserUser
E.&&. E.val qid E.==. lmsUser E.^. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
- E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification
+ E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification
-- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken!
let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do
E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser))
let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on!
pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted type of subSelect does not seem to support this!
- E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
+ E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
return (qualUser, user, lmsUser, qualBlock, printAcknowledged, validQualification now qualUser)
@@ -423,17 +423,17 @@ mkLmsTable :: ( Functor h, ToSortable h
)
=> Bool
-> Entity Qualification
- -> Map LmsTableAction (AForm Handler LmsTableActionData)
+ -> Map LmsTableAction (AForm Handler LmsTableActionData)
-> (Map CompanyId Company -> cols)
-> PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData))
-> DB (FormResult (LmsTableActionData, Set UserId), Widget)
mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
now <- liftIO getCurrentTime
- -- lookup all companies
- cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do
+ -- lookup all companies
+ cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do
cmps <- selectList [] [] -- [Asc CompanyShorthand]
return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
- let
+ let
csvName = T.replace " " "-" $ ciOriginal (quali ^. _qualificationName)
dbtIdent :: Text
dbtIdent = "lms"
@@ -486,19 +486,19 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
-- )
, single ("notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified)))
, single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion ->
- E.from $ \usrAvs -> -- do
+ E.from $ \usrAvs -> -- do
E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId
E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
(E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ))
, single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
- E.from $ \(usrComp `E.InnerJoin` comp) -> do
+ E.from $ \(usrComp `E.InnerJoin` comp) -> do
let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
(E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
testcrit = maybe testname testnumber $ readMay $ ciOriginal criterion
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit
- )
+ )
, fltrAVSCardNos queryUser
, single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
| Set.null criteria -> E.true
@@ -506,7 +506,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
)
]
dbtFilterUI mPrev = mconcat
- [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
+ [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
, prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
, prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
, fltrAVSCardNosUI mPrev
@@ -516,7 +516,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
, prismAForm (singletonFilter "notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified)
, prismAForm (singletonFilter "status" . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus)
-- , if isNothing mbRenewal then mempty
- -- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
+ -- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtCsvEncode = Just DBTCsvEncode
@@ -548,14 +548,14 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
<*> view (resultLmsUser . _entityVal . _lmsUserReceived)
<*> view (resultLmsUser . _entityVal . _lmsUserNotified) -- TODO: only exports last email date / print job sending date, not print acknowledge
<*> view (resultLmsUser . _entityVal . _lmsUserEnded)
- getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of
+ getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of
[] -> pure Nothing
somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
-
+
dbtCsvDecode = Nothing
dbtExtraReps = []
- dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else
+ dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else
DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
@@ -603,18 +603,18 @@ postLmsR sid qsh = do
[ singletonMap LmsActNotify $ pure LmsActNotifyData
, singletonMap LmsActRenewNotify $ pure LmsActRenewNotifyData
-- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData
- , singletonMap LmsActReset $ LmsActResetData
- <$> aopt intField (fslI MsgLmsActRestartExtend) Nothing
+ , singletonMap LmsActReset $ LmsActResetData
+ <$> aopt intField (fslI MsgLmsActRestartExtend) Nothing
<*> aopt checkBoxField (fslI MsgLmsActRestartUnblock) Nothing
- <*> aopt checkBoxField (fslI MsgLmsActNotify) Nothing
+ <*> aopt checkBoxField (fslI MsgLmsActNotify) Nothing
<* aformMessage msgResetInfo
- , singletonMap LmsActRestart $ LmsActRestartData
- <$> aopt intField (fslI MsgLmsActRestartExtend) Nothing
+ , singletonMap LmsActRestart $ LmsActRestartData
+ <$> aopt intField (fslI MsgLmsActRestartExtend) Nothing
<*> aopt checkBoxField (fslI MsgLmsActRestartUnblock) Nothing
<*> aopt checkBoxField (fslI MsgLmsActNotify) Nothing
-- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing
- <* aformMessage msgRestartWarning
- ]
+ <* aformMessage msgRestartWarning
+ ]
colChoices cmpMap = mconcat
[ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
, colUserNameModalHdrAdmin MsgLmsUser AdminUserR
@@ -622,11 +622,11 @@ postLmsR sid qsh = do
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) ->
let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
| Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
- , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
+ , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
]
in intercalate spacerCell cs
, colUserMatriclenr isAdmin
- -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
+ -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d
@@ -653,8 +653,8 @@ postLmsR sid qsh = do
-- - Letter printed : LmsUserNotified == Just _ && PrintJobId == Just _
-- - Letter sent : LmsUserNotified == Just _ && PrintJobId == Just _ && PrintJobAcknowledged == Just _
let notifyDate = row ^. resultLmsUser . _entityVal . _lmsUserNotified
- lmsident = row ^. resultLmsUser . _entityVal . _lmsUserIdent
- recipient = row ^. hasUser
+ lmsident = row ^. resultLmsUser . _entityVal . _lmsUserIdent
+ recipient = row ^. hasUser
letterDates = row ^? resultPrintAck
lastLetterDate = headDef Nothing =<< letterDates
letterSent = isJust letterDates && (isNothing lastLetterDate || lastLetterDate >= notifyDate) -- was a letter attempted to send last (not 100% safe, if an email is sent after an unacknowledged letter)
@@ -675,7 +675,7 @@ postLmsR sid qsh = do
$maybe ackdate <- mbackdate
^{formatTimeW SelFormatDateTime ackdate}
$nothing
- _{MsgPrintJobUnacknowledged}
+ _{MsgPrintJobUnacknowledged}
_{MsgPrintJobs}
@@ -700,25 +700,25 @@ postLmsR sid qsh = do
_ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page
(action, selectedUsers) | isResetRestartAct action -> do
- let usersList = Set.toList selectedUsers
+ let usersList = Set.toList selectedUsers
numUsers = Set.size selectedUsers
isReset = isResetAct action
- actRestartExtend = action & lmsActRestartExtend
- actRestartUnblock = action & lmsActRestartUnblock
- actRestartNotify = action & lmsActRestartNotify
+ actRestartExtend = action & lmsActRestartExtend
+ actRestartUnblock = action & lmsActRestartUnblock
+ actRestartNotify = action & lmsActRestartNotify
- chgUsers <- runDB $ do
+ chgUsers <- runDB $ do
when (actRestartUnblock == Just True) $ do
oks <- qualificationUserBlocking qid usersList True Nothing (Left $ bool "Manueller LMS Neustart" "Manuelle LMS Zurücksetzung" isReset) (fromMaybe True actRestartNotify)
addMessageI Success $ MsgQualificationStatusUnblock qsh oks numUsers
whenIsJust actRestartExtend $ \extDays -> do
let cutoff = addDays extDays nowaday
- shortUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList
+ shortUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList
[ QualificationUserQualification ==. qid
- , QualificationUserUser <-. usersList
+ , QualificationUserUser <-. usersList
, QualificationUserValidUntil <. cutoff
- ] []
+ ] []
forM_ shortUsers $ upsertQualificationUser qid now cutoff Nothing "E-Learning Reset"
fromIntegral <$> (if isReset
@@ -727,25 +727,25 @@ postLmsR sid qsh = do
else deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList]
)
- unless isReset $
+ unless isReset $
forM_ selectedUsers $ \uid ->
queueJob' $ JobLmsEnqueueUser { jQualification = qid, jUser = uid }
- runDB $ forM_ selectedUsers $ \uid ->
- audit $ TransactionLmsReset
- { transactionQualification = qid
+ runDB $ forM_ selectedUsers $ \uid ->
+ audit $ TransactionLmsReset
+ { transactionQualification = qid
, transactionLmsUser = uid
, transactionLmsReset = isReset
- , transactionLmsResetExtend = actRestartExtend
+ , transactionLmsResetExtend = actRestartExtend
, transactionLmsResetUnblock = actRestartUnblock
- , transactionLmsResetNotify = actRestartNotify
+ , transactionLmsResetNotify = actRestartNotify
}
let mStatus = bool Success Warning $ chgUsers < numUsers
addMessageI mStatus $ bool MsgLmsActRestartFeedback MsgLmsActResetFeedback isReset chgUsers numUsers
reloadKeepGetParams $ LmsR sid qsh
- (action, selectedUsers) | isRenewPinAct action || isNotifyAct action -> do
+ (action, selectedUsers) | isRenewPinAct action || isNotifyAct action -> do
numExaminees <- runDB $ do
okUsers <- selectList [ LmsUserQualification ==. qid -- matching qualification
, LmsUserEnded ==. Nothing -- not yet deleted
@@ -761,7 +761,7 @@ postLmsR sid qsh = do
return $ length okUsers
let numSelected = length selectedUsers
diffSelected = numSelected - numExaminees
- mstat = bool Success Warning $ diffSelected /= 0
+ mstat = bool Success Warning $ diffSelected /= 0
when (isRenewPinAct action) $ addMessageI mstat $ MsgLmsPinRenewal numExaminees
when (isNotifyAct action) $ addMessageI mstat $ MsgLmsNotificationSend numExaminees
when (diffSelected /= 0) $ addMessageI Warning $ MsgLmsActionFailed diffSelected
@@ -791,22 +791,22 @@ getLmsUserR sid qsh = viewLmsUserR (Just sid) (Just qsh)
viewLmsUserR :: Maybe SchoolId -> Maybe QualificationShorthand -> CryptoUUIDUser -> Handler Html
viewLmsUserR msid mqsh uuid = do
uid <- decrypt uuid
- now <- liftIO getCurrentTime
- (user@User{userDisplayName}, quals, qblocks) <- runDB $ do
+ now <- liftIO getCurrentTime
+ (user@User{userDisplayName}, quals, qblocks) <- runDBRead $ do
usr <- get404 uid
- qs <- Ex.select $ do
- (qual :& qualUsr :& lmsUsr) <-
+ qs <- Ex.select $ do
+ (qual :& qualUsr :& lmsUsr) <-
Ex.from $ Ex.table @Qualification
`Ex.leftJoin` Ex.table @QualificationUser
`Ex.on` (\(qual :& qualUsr) -> qualUsr E.?. QualificationUserUser E.?=. Ex.val uid
E.&&. qualUsr E.?. QualificationUserQualification E.?=. qual Ex.^. QualificationId
- )
+ )
`Ex.leftJoin` Ex.table @LmsUser
`Ex.on` (\(qual :& _ :& lmsUsr) -> lmsUsr E.?. LmsUserUser E.?=. Ex.val uid
- E.&&. lmsUsr E.?. LmsUserQualification E.?=. qual Ex.^. QualificationId
+ E.&&. lmsUsr E.?. LmsUserQualification E.?=. qual Ex.^. QualificationId
)
Ex.where_ $ E.and $
- (E.isJust (qualUsr E.?. QualificationUserUser) E.||. E.isJust ( lmsUsr E.?. LmsUserUser)) : catMaybes
+ (E.isJust (qualUsr E.?. QualificationUserUser) E.||. E.isJust ( lmsUsr E.?. LmsUserUser)) : catMaybes
[ (qual E.^. QualificationSchool E.==.) . E.val <$> msid
, (qual E.^. QualificationShorthand E.==.) . E.val <$> mqsh
]
@@ -816,7 +816,7 @@ viewLmsUserR msid mqsh uuid = do
<- foldMapM (\(_, mbqu, _, _) -> case mbqu of
Nothing -> pure mempty
Just (Entity quid _) -> do
- blocks <- Ex.select $ do
+ blocks <- Ex.select $ do
(qBlock :& qbUsr) <- Ex.from $ Ex.table @QualificationUserBlock
`Ex.leftJoin` Ex.table @User
`Ex.on` (\(qBlock :& qbUsr) -> qBlock Ex.^. QualificationUserBlockBlocker Ex.==. qbUsr Ex.?. UserId)
@@ -826,7 +826,7 @@ viewLmsUserR msid mqsh uuid = do
return $ Map.singleton quid blocks
) qs
return (usr, qs, Map.filter notNull bs)
- let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|]
+ let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|]
siteLayout heading $ do
setTitle $ toHtml userDisplayName
- $(widgetFile "lms-user")
+ $(widgetFile "lms-user")
diff --git a/src/Handler/News.hs b/src/Handler/News.hs
index 0399d98c3..2ac689c39 100644
--- a/src/Handler/News.hs
+++ b/src/Handler/News.hs
@@ -13,7 +13,7 @@ import Handler.SystemMessage
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
-
+
import Database.Esqueleto.Utils.TH
import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E
@@ -315,16 +315,16 @@ newsUpcomingExams uid = do
| otherwise -> mempty
]
dbtSorting = Map.fromList
- [ ("demo-both", SortColumn $ queryCourse &&& queryExam >>> (\(_course,exam)-> exam E.^. ExamName))
- , ("term", SortColumn $ queryCourse >>> (E.^. CourseTerm ))
- , ("school", SortColumn $ queryCourse >>> (E.^. CourseSchool ))
- , ("course", SortColumn $ queryCourse >>> (E.^. CourseShorthand ))
- , ("name", SortColumn $ queryExam >>> (E.^. ExamName ))
- , ("time", SortColumn $ queryExam >>> (E.^. ExamStart ))
- , ("register-from", SortColumn $ queryExam >>> (E.^. ExamRegisterFrom ))
- , ("register-to", SortColumn $ queryExam >>> (E.^. ExamRegisterTo ))
- , ("visible", SortColumn $ queryExam >>> (E.^. ExamVisibleFrom ))
- , ("registered", SortColumn $ queryExam >>> (\exam ->
+ [ ("demo-both", SortColumns $ queryCourse &&& queryExam >>> (\(course,exam)-> [SomeExprValue $ course E.^. CourseShorthand, SomeExprValue $ exam E.^. ExamName]))
+ , ("term", SortColumn $ queryCourse >>> (E.^. CourseTerm ))
+ , ("school", SortColumn $ queryCourse >>> (E.^. CourseSchool ))
+ , ("course", SortColumn $ queryCourse >>> (E.^. CourseShorthand ))
+ , ("name", SortColumn $ queryExam >>> (E.^. ExamName ))
+ , ("time", SortColumn $ queryExam >>> (E.^. ExamStart ))
+ , ("register-from", SortColumn $ queryExam >>> (E.^. ExamRegisterFrom ))
+ , ("register-to", SortColumn $ queryExam >>> (E.^. ExamRegisterTo ))
+ , ("visible", SortColumn $ queryExam >>> (E.^. ExamVisibleFrom ))
+ , ("registered", SortColumn $ queryExam >>> (\exam ->
E.exists $ E.from $ \registration -> do
E.where_ $ registration E.^. ExamRegistrationUser E.==. E.val uid
E.where_ $ registration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs
index fdc81305b..76c9346e9 100644
--- a/src/Handler/Profile.hs
+++ b/src/Handler/Profile.hs
@@ -7,7 +7,7 @@
module Handler.Profile
( getProfileR, postProfileR
, getForProfileR, postForProfileR
- , getProfileDataR, makeProfileData
+ , getProfileDataR, makeProfileData
, getForProfileDataR
, getAuthPredsR, postAuthPredsR
, getUserNotificationR, postUserNotificationR
@@ -70,11 +70,11 @@ data SettingsForm = SettingsForm
, stgDownloadFiles :: Bool
, stgWarningDays :: NominalDiffTime
, stgShowSex :: Bool
-
+
, stgPinPassword :: Maybe Text
, stgPrefersPostal :: Bool
, stgPostAddress :: Maybe StoredMarkup
-
+
, stgTelephone :: Maybe Text
, stgMobile :: Maybe Text
@@ -142,9 +142,9 @@ makeSettingForm template html = do
<*> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) (stgPostAddress <$> template)
<*> aopt (textField & cfStrip) (fslI MsgUserTelephone) (stgTelephone <$> template)
- <*> aopt (textField & cfStrip) (fslI MsgUserMobile ) (stgMobile <$> template)
+ <*> aopt (textField & cfStrip) (fslI MsgUserMobile ) (stgMobile <$> template)
- <*> examOfficeForm (stgExamOfficeSettings <$> template)
+ <*> examOfficeForm (stgExamOfficeSettings <$> template)
<*> schoolsForm (stgSchools <$> template)
<*> notificationForm (stgNotificationSettings <$> template)
return (result, widget) -- no validation here, done later by validateSettings
@@ -156,7 +156,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar
where
schoolsForm' :: WForm Handler (FormResult (Set SchoolId))
schoolsForm' = do
- allSchools <- liftHandler . runDB $ selectList [] [Asc SchoolName]
+ allSchools <- liftHandler . runDBRead $ selectList [] [Asc SchoolName]
let
schoolForm (Entity ssh School{schoolName})
@@ -226,7 +226,7 @@ notificationForm template = wFormToAForm $ do
let
ntfs nt = fslI nt & case nt of
_other -> id
-
+
nsForm nt
| maybe False ntHidden $ ntSection nt
= pure $ notificationAllowed def nt
@@ -297,7 +297,7 @@ examOfficeForm template = wFormToAForm $ do
| otherwise
-> FormSuccess $ Map.singleton kStart (Left nLabel)
return (addRes', $(widgetFile "profile/exam-office-labels/add"))
-
+
miCell :: ListPosition
-> Either ExamOfficeLabelName ExamOfficeLabelId
-> Maybe EOLabelData
@@ -366,7 +366,7 @@ validateSettings User{..} = do
userDisplayName' <- use _stgDisplayName
guardValidation MsgUserDisplayNameInvalid $
userDisplayName == userDisplayName' || -- unchanged or valid (invalid displayNames delivered by LDAP are preserved)
- validDisplayName userTitle userFirstName userSurname userDisplayName'
+ validDisplayName userTitle userFirstName userSurname userDisplayName'
userDisplayEmail' <- use _stgDisplayEmail
guardValidation (MsgInvalidEmailAddressWith $ CI.original userDisplayEmail') $
@@ -412,7 +412,7 @@ nullaryPathPiece ''ProfileAnchor $ camelToPathPiece' 1
getForProfileR , postForProfileR :: CryptoUUIDUser -> Handler Html
getForProfileR = postForProfileR
-postForProfileR cID = do
+postForProfileR cID = do
uid <- decrypt cID
user <- runDB $ get404 uid
serveProfileR (uid, user)
@@ -449,7 +449,7 @@ serveProfileR (uid, user@User{..}) = do
, stgShowSex = userShowSex
, stgPinPassword = userPinPassword
, stgPostAddress = userPostAddress
- , stgPrefersPostal = userPrefersPostal
+ , stgPrefersPostal = userPrefersPostal
, stgTelephone = userTelephone
, stgMobile = userMobile
, stgExamOfficeSettings = ExamOfficeSettings
@@ -580,14 +580,49 @@ getProfileDataR = do
getForProfileDataR :: CryptoUUIDUser -> Handler Html
getForProfileDataR cID = do
uid <- decrypt cID
- (user,dataWidget) <- runDB $ bind2 (get404 uid) $ makeProfileData . Entity uid
+ (user,dataWidget) <- runDB $ bind2 (get404 uid) $ makeProfileData . Entity uid
defaultLayout $ do
setTitleI $ MsgHeadingForProfileData $ userDisplayName user
dataWidget
+-- data TableHasData = TableHasData{tableHasRows :: Bool, tableWidget :: Widget}
+-- a poor man's record subsitute
+
+{-
+type TableHasData = (Bool, Widget)
+tableHasRows :: TableHasData -> Bool
+tableHasRows = fst
+tableWidget :: TableHasData -> Widget
+tableWidget = snd
+-}
+
+maybeTable :: (RenderMessage UniWorX a)
+ => a -> (Bool, Widget) -> Widget
+maybeTable m = maybeTable' m Nothing Nothing
+
+maybeTable' :: (RenderMessage UniWorX a)
+ => a -> Maybe a -> Maybe Widget -> (Bool, Widget) -> Widget
+maybeTable' _ Nothing _ (False, _ ) = mempty
+maybeTable' _ (Just nodata) _ (False, _ ) =
+ [whamlet|
+
+ _{nodata}
+ |]
+maybeTable' hdr _ mbRemark (True ,tbl) =
+ [whamlet|
+
+ _{hdr}
+
+ ^{tbl}
+ $maybe remark <- mbRemark
+ _{MsgProfileRemark}
+ \ ^{remark}
+ |]
+
+
makeProfileData :: Entity User -> DB Widget
makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do
- now <- liftIO getCurrentTime
+ now <- liftIO getCurrentTime
avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid)
let usrAutomatic :: CU_UserAvs_User -> Widget
usrAutomatic = updateAutomatic . mayUpdate usrVal avsId . mkCheckUpdate
@@ -599,48 +634,57 @@ makeProfileData usrEnt@(Entity uid usrVal@User{..}) = do
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
- studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
+ studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
return (studyfeat, studydegree, studyterms)
companies <- wgtCompanies uid
- supervisors' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
- E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
- E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid
- E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
- return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
- let numSupervisors = length supervisors'
- supervisors = intersperse (text2widget ", ") $
- (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
- icnReroute = text2widget " " <> toWgt (icon IconLetter)
- supervisees' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
- E.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId
- E.where_ $ spvr E.^. UserSupervisorSupervisor E.==. E.val uid
- return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
- let numSupervisees = length supervisees'
- supervisees = intersperse (text2widget ", ") $
- (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisees'
- -- icnReroute = text2widget " " <> toWgt (icon IconLetter)
+ -- supervisors' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
+ -- E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
+ -- E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid
+ -- E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
+ -- return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
+ -- let numSupervisors = length supervisors'
+ -- supervisors = intersperse (text2widget ", ") $
+ -- (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
+ -- icnReroute = text2widget " " <> toWgt (icon IconReroute)
+ -- supervisees' <- E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
+ -- E.on $ spvr E.^. UserSupervisorUser E.==. usrSpvr E.^. UserId
+ -- E.where_ $ spvr E.^. UserSupervisorSupervisor E.==. E.val uid
+ -- return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
+ -- let numSupervisees = length supervisees'
+ -- supervisees = intersperse (text2widget ", ") $
+ -- (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisees'
+ -- -- icnReroute = text2widget " " <> toWgt (icon IconReroute)
--Tables
- (hasRowsOwnedCourses, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
+ ownedCoursesTable <- mkOwnedCoursesTable uid -- Tabelle mit eigenen Kursen
enrolledCoursesTable <- mkEnrolledCoursesTable uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
submissionTable <- mkSubmissionTable uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen
submissionGroupTable <- mkSubmissionGroupTable uid -- Tabelle mit allen Abgabegruppen
correctionsTable <- mkCorrectionsTable uid -- Tabelle mit allen Korrektor-Aufgaben
qualificationsTable <- mkQualificationsTable now uid -- Tabelle mit allen Qualifikationen
supervisorsTable <- mkSupervisorsTable uid -- Tabelle mit allen Supervisors
- superviseesTable <- mkSuperviseesTable uid -- Tabelle mit allen Supervisees
- let examTable, ownTutorialTable, tutorialTable :: Widget
- examTable = i18n MsgPersonalInfoExamAchievementsWip
- ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
- tutorialTable = i18n MsgPersonalInfoTutorialsWip
+ superviseesTable <- mkSuperviseesTable actualPrefersPostal uid -- Tabelle mit allen Supervisees
+ let supervisorsWgt :: Widget =
+ let ((getSum -> nrSupers, getSum -> nrReroute, getSum -> nrLetter), tWgt) = supervisorsTable
+ in maybeTable' (MsgProfileSupervisor nrSupers nrReroute) (Just MsgProfileNoSupervisor)
+ (toMaybe (nrReroute > 0) $ msg2widget $ MsgProfileSupervisorRemark nrSupers nrReroute nrLetter) (nrSupers > 0, tWgt)
+ superviseesWgt :: Widget =
+ let ((getSum -> nrSubs, getSum -> nrReroute), tWgt) = superviseesTable
+ in maybeTable' (MsgProfileSupervisee nrSubs nrReroute) (Just MsgProfileNoSupervisee)
+ (toMaybe (nrReroute > 0) $ msg2widget $ MsgProfileSuperviseeRemark nrSubs nrReroute) (nrSubs > 0, tWgt)
+ -- let examTable, ownTutorialTable, tutorialTable :: Widget
+ -- examTable = i18n MsgPersonalInfoExamAchievementsWip
+ -- ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
+ -- tutorialTable = i18n MsgPersonalInfoTutorialsWip
cID <- encrypt uid
mCRoute <- getCurrentRoute
- showAdminInfo <- pure (mCRoute == Just (AdminUserR cID)) `or2M` hasReadAccessTo (AdminUserR cID)
- tooltipAvsPersNo <- messageI Info MsgAvsPersonNoNotId
- tooltipInvalidEmail <- messageI Error MsgInvalidEmailAddress
+ showAdminInfo <- pure (mCRoute == Just (AdminUserR cID)) `or2M` hasReadAccessTo (AdminUserR cID)
+ tooltipAvsPersNo <- messageI Info MsgAvsPersonNoNotId
+ tooltipAvsPersNoDiffers <- messageI Error MsgAvsPersonNoDiffers
+ tooltipInvalidEmail <- messageI Error MsgInvalidEmailAddress
let profileRemarks = $(i18nWidgetFile "profile-remarks")
return $(widgetFile "profileData")
@@ -698,7 +742,7 @@ mkOwnedCoursesTable =
-- | Table listing all courses that the given user is enrolled in
-mkEnrolledCoursesTable :: UserId -> DB Widget
+mkEnrolledCoursesTable :: UserId -> DB (Bool, Widget)
mkEnrolledCoursesTable =
let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
@@ -706,7 +750,7 @@ mkEnrolledCoursesTable =
validator = def & defaultSorting [SortDescBy "time"]
- in \uid -> dbTableWidget' validator
+ in \uid -> (_1 %~ getAny) <$> dbTableWidget validator
DBTable
{ dbtIdent = "courseMembership" :: Text
, dbtSQLQuery = \(course `E.InnerJoin` participant) -> do
@@ -717,7 +761,7 @@ mkEnrolledCoursesTable =
, dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
, dbtProj = dbtProjId <&> _dbrOutput . _2 %~ E.unValue
, dbtColonnade = mconcat
- [ sortable (Just "term") (i18nCell MsgTableTerm) $
+ [ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell
termCell <$> view (_dbrOutput . _1 . _entityVal . _courseTerm)
, sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $
schoolCell <$> view _courseTerm
@@ -750,7 +794,7 @@ mkEnrolledCoursesTable =
-- | Table listing all submissions for the given user
-mkSubmissionTable :: UserId -> DB Widget
+mkSubmissionTable :: UserId -> DB (Bool, Widget)
mkSubmissionTable =
let dbtIdent = "submissions" :: Text
dbtStyle = def
@@ -784,7 +828,7 @@ mkSubmissionTable =
<&> _dbrOutput . _4 %~ E.unValue
dbtColonnade = mconcat
- [ sortable (Just "term") (i18nCell MsgTableTerm) $
+ [ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell
termCell <$> view (_dbrOutput . _1 . _1)
, sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 ) $
schoolCell <$> view _1
@@ -828,14 +872,10 @@ mkSubmissionTable =
dbtExtraReps = []
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
dbtSorting = dbtSorting' uid
- in dbTableWidget' validator DBTable{..}
--- in do dbtSQLQuery <- dbtSQLQuery'
--- dbtSorting <- dbtSorting'
--- return $ dbTableWidget' validator $ DBTable {..}
-
+ in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
-- | Table listing all submissions for the given user
-mkSubmissionGroupTable :: UserId -> DB Widget
+mkSubmissionGroupTable :: UserId -> DB (Bool, Widget)
mkSubmissionGroupTable =
let dbtIdent = "subGroups" :: Text
dbtStyle = def
@@ -858,7 +898,7 @@ mkSubmissionGroupTable =
<&> _dbrOutput . _1 %~ $(E.unValueN 3)
dbtColonnade = mconcat
- [ sortable (Just "term") (i18nCell MsgTableTerm) $
+ [ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell
termCell <$> view (_dbrOutput . _1 . _1)
, sortable (Just "school") (i18nCell MsgTableCourseSchool) . magnify (_dbrOutput . _1 ) $
schoolCell <$> view _1
@@ -887,10 +927,10 @@ mkSubmissionGroupTable =
dbtCsvDecode = Nothing
dbtExtraReps = []
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
- in dbTableWidget' validator DBTable{..}
+ in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
-mkCorrectionsTable :: UserId -> DB Widget
+mkCorrectionsTable :: UserId -> DB (Bool, Widget)
mkCorrectionsTable =
let dbtIdent = "corrections" :: Text
dbtStyle = def
@@ -923,7 +963,7 @@ mkCorrectionsTable =
<&> _dbrOutput . _2 %~ E.unValue
dbtColonnade = mconcat
- [ sortable (Just "term") (i18nCell MsgTableTerm) $
+ [ sortable (Just "term") (i18nCell MsgTableTerm) $ fmap addIndicatorCell
termCellCL <$> view (_dbrOutput . _1)
, sortable (Just "school") (i18nCell MsgTableCourseSchool) $
schoolCellCL <$> view (_dbrOutput . _1)
@@ -960,7 +1000,7 @@ mkCorrectionsTable =
dbtCsvDecode = Nothing
dbtExtraReps = []
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
- in dbTableWidget' validator DBTable{..}
+ in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
-- | Table listing all qualifications that the given user is enrolled in
@@ -977,26 +1017,26 @@ mkQualificationsTable =
E.on $ quser E.^. QualificationUserId E.=?. qblock E.?. QualificationUserBlockQualificationUser
E.&&. qblock `isLatestBlockBefore` E.val now
E.on $ quser E.^. QualificationUserQualification E.==. quali E.^. QualificationId
- E.where_ $ quser E.^. QualificationUserUser E.==. E.val uid
+ E.where_ $ quser E.^. QualificationUserUser E.==. E.val uid
return (quali, quser, qblock)
, dbtRowKey = \(_quali `E.InnerJoin` quser `E.LeftOuterJoin` _qblock) -> quser E.^. QualificationUserId
- , dbtProj = dbtProjId
+ , dbtProj = dbtProjId
, dbtColonnade = mconcat
[ colSchool (_dbrOutput . _1 . _entityVal . _qualificationSchool)
- , sortable (Just "quali") (i18nCell MsgQualificationName) $ qualificationDescrCell <$> view (_dbrOutput . _1 . _entityVal)
- , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserFirstHeld )
+ , sortable (Just "quali") (i18nCell MsgQualificationName) $ qualificationDescrCell <$> view (_dbrOutput . _1 . _entityVal)
+ , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserFirstHeld )
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserLastRefresh)
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserValidUntil )
, sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row ->
- qualificationValidReasonCell False (utctDay now) (row ^? _dbrOutput . _3 . _Just . _entityVal) (row ^. _dbrOutput . _2 . _entityVal)
+ qualificationValidReasonCell False (utctDay now) (row ^? _dbrOutput . _3 . _Just . _entityVal) (row ^. _dbrOutput . _2 . _entityVal)
]
, dbtSorting = mconcat
[ sortSchool $ to (\(quali `E.InnerJoin` _ `E.LeftOuterJoin` _) -> quali E.^. QualificationSchool)
- , singletonMap "quali" $ SortColumn $ withType $ \(quali `E.InnerJoin` _ `E.LeftOuterJoin` _) -> quali E.^. QualificationName
+ , singletonMap "quali" $ SortColumn $ withType $ \(quali `E.InnerJoin` _ `E.LeftOuterJoin` _) -> quali E.^. QualificationName
, singletonMap "blocked" $ SortColumn $ withType $ \(_ `E.InnerJoin` _ `E.LeftOuterJoin` qblock) -> qblock E.?. QualificationUserBlockFrom
, singletonMap "valid-until" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin` _) -> quser E.^. QualificationUserValidUntil
, singletonMap "last-refresh" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin` _) -> quser E.^. QualificationUserLastRefresh
- , singletonMap "first-held" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin` _) -> quser E.^. QualificationUserFirstHeld
+ , singletonMap "first-held" $ SortColumn $ withType $ \(_ `E.InnerJoin` quser `E.LeftOuterJoin` _) -> quser E.^. QualificationUserFirstHeld
]
, dbtFilter = mempty
, dbtFilterUI = mempty
@@ -1027,9 +1067,9 @@ instance HasUser TblSupervisorData where
hasUser = _dbrOutput . _1 . _entityVal
-- | Table listing all supervisor of the given user
-mkSupervisorsTable :: UserId -> DB Widget
-mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
- where
+mkSupervisorsTable :: UserId -> DB ((Sum Int, Sum Int, Sum Int), Widget)
+mkSupervisorsTable uid = dbTableWidget validator DBTable{..}
+ where
dbtIdent = "userSupervisedBy" :: Text
dbtStyle = def
@@ -1043,10 +1083,17 @@ mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
dbtColonnade = mconcat
[ colUserNameModalHdr MsgTableSupervisor ForProfileDataR
, colUserEmail
- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
- , sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> tickmarkCell b
+ -- , sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> indicatorCell <> ifIconCell b IconReroute
+ -- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
+ , sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row ->
+ let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications
+ isLetter = row ^. resultUser . _userPrefersPostal
+ in tellCell (Sum 1, Sum $ fromEnum isReroute, Sum $ fromEnum $ isReroute && isLetter) $
+ if isReroute
+ then iconCell IconReroute <> spacerCell <> iconFixedCell (iconLetterOrEmail isLetter)
+ else mempty
, sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
- , sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell
+ , sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell
]
validator = def & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ]
dbtSorting = mconcat
@@ -1054,8 +1101,13 @@ mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
, singletonMap & uncurry $ sortUserEmail queryUser
, singletonMap "postal-pref" $ SortColumn $ queryUser >>> (E.^. UserPrefersPostal)
, singletonMap "rerouted" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorRerouteNotifications)
+ -- , singletonMap "reroute" $ SortColumn $ queryUserSupervisor &&& queryUser >>> (\(spr,usr) -> mTuple (spr E.^. UserSupervisorRerouteNotifications) (usr E.^. UserPrefersPostal))
+ , singletonMap "reroute" $ SortColumns $ \row ->
+ [ SomeExprValue $ queryUserSupervisor row E.^. UserSupervisorRerouteNotifications
+ , SomeExprValue $ queryUser row E.^. UserPrefersPostal
+ ]
, singletonMap "cshort" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorCompany)
- , singletonMap "reason" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorReason)
+ , singletonMap "reason" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorReason)
]
dbtFilter = mconcat
[ singletonMap & uncurry $ fltrUserNameEmail queryUser
@@ -1068,9 +1120,9 @@ mkSupervisorsTable uid = dbTableWidget' validator DBTable{..}
-- | Table listing all persons supervised by the given user
-mkSuperviseesTable :: UserId -> DB Widget
-mkSuperviseesTable uid = dbTableWidget' validator DBTable{..}
- where
+mkSuperviseesTable ::Bool -> UserId -> DB ((Sum Int, Sum Int), Widget)
+mkSuperviseesTable userPrefersPostal uid = dbTableWidget validator DBTable{..}
+ where
dbtIdent = "userSupervisedBy" :: Text
dbtStyle = def
@@ -1081,22 +1133,30 @@ mkSuperviseesTable uid = dbTableWidget' validator DBTable{..}
dbtRowKey (_ `E.InnerJoin` spr) = spr E.^. UserSupervisorId
dbtProj = dbtProjId
+ iconCellLetterOrEmail = spacerCell <> iconFixedCell (iconLetterOrEmail userPrefersPostal) -- only notification type of supervisor matters here
dbtColonnade = mconcat
[ colUserNameModalHdr MsgTableSupervisee ForProfileDataR
- -- , colUserEmail
- -- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
- , sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> tickmarkCell b
+ , colUserEmail
+ -- , sortable (Just "rerouted") (i18nCell MsgTableRerouteActive) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorRerouteNotifications -> b) -> ifIconCell b IconReroute
+ -- , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b
+ , sortable (Just "reroute") (i18nCell MsgTableRerouteActive) $ \row ->
+ let isReroute = row ^. resultUserSupervisor . _entityVal ._userSupervisorRerouteNotifications
+ in tellCell (Sum 1, Sum $ fromEnum isReroute) $ boolCell isReroute $ iconCell IconReroute <> iconCellLetterOrEmail
, sortable (Just "cshort") (i18nCell MsgTableCompany) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorCompany -> mc) -> maybeCell mc (\(unCompanyKey -> c) -> anchorCell (FirmUsersR c) $ citext2widget c)
- , sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell
+ , sortable (Just "reason") (i18nCell MsgSupervisorReason) $ \(view $ resultUserSupervisor . _entityVal . _userSupervisorReason -> mr) -> maybeCell mr textCell
]
validator = def & defaultSorting [ SortAscBy "cshort", SortAscBy "user-name" ]
dbtSorting = mconcat
[ singletonMap & uncurry $ sortUserNameLink queryUser
, singletonMap & uncurry $ sortUserEmail queryUser
- , singletonMap "postal-pref" $ SortColumn $ queryUser >>> (E.^. UserPrefersPostal)
- , singletonMap "rerouted" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorRerouteNotifications)
+ -- , singletonMap "postal-pref" $ SortColumn $ queryUser >>> (E.^. UserPrefersPostal)
+ -- , singletonMap "rerouted" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorRerouteNotifications)
+ , singletonMap "reroute" $ SortColumns $ \row ->
+ [ SomeExprValue $ queryUserSupervisor row E.^. UserSupervisorRerouteNotifications
+ , SomeExprValue $ queryUser row E.^. UserPrefersPostal
+ ]
, singletonMap "cshort" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorCompany)
- , singletonMap "reason" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorReason)
+ , singletonMap "reason" $ SortColumn $ queryUserSupervisor >>> (E.^. UserSupervisorReason)
]
dbtFilter = mconcat
[ singletonMap & uncurry $ fltrUserNameEmail queryUser
diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs
index 3414b618b..37ecb64fe 100644
--- a/src/Handler/SAP.hs
+++ b/src/Handler/SAP.hs
@@ -27,10 +27,10 @@ import qualified Database.Esqueleto.Utils as E
data SapUserTableCsv = SapUserTableCsv -- for csv export only
- { csvSUTpersonalNummer :: Text
+ { csvSUTpersonalNummer :: Text
, csvSUTqualifikation :: Text
, csvSUTgültigVon :: Day
- , csvSUTgültigBis :: Day
+ , csvSUTgültigBis :: Day
-- , csvSUTsupendiertBis :: Maybe Day
, csvSUTausprägung :: Text
}
@@ -38,7 +38,7 @@ data SapUserTableCsv = SapUserTableCsv -- for csv export only
makeLenses_ ''SapUserTableCsv
sapUserTableCsvHeader :: Csv.Header
-sapUserTableCsvHeader = Csv.header
+sapUserTableCsvHeader = Csv.header
[ "PersonalNummer"
, "Qualifikation"
, "GültigVon"
@@ -51,40 +51,40 @@ instance ToNamedRecord SapUserTableCsv where
toNamedRecord SapUserTableCsv{..} = Csv.namedRecord
[ "PersonalNummer" Csv..= csvSUTpersonalNummer
, "Qualifikation" Csv..= csvSUTqualifikation
- , "GültigVon" Csv..= csvSUTgültigVon
- , "GültigBis" Csv..= csvSUTgültigBis
+ , "GültigVon" Csv..= csvSUTgültigVon
+ , "GültigBis" Csv..= csvSUTgültigBis
-- , "SupendiertBis" Csv..= csvSUTsupendiertBis
- , "Ausprägung" Csv..= csvSUTausprägung
+ , "Ausprägung" Csv..= csvSUTausprägung
]
-- | Removes all personalNummer which are not numbers between 10000 and 99999 (also excludes E-Accounts), which should not be returned by the query anyway (only qualfications with sap id and users with internal personnel number must be transmitted)
-- temporary suspensions are transmitted to SAP in multiple rows: firstheld->suspension1, reinstate1->suspension2, reinstate2->validTo
sapRes2csv :: [(E.Value (Maybe Text), E.Value (Maybe Text), E.Value Day, E.Value Day, E.Value (Maybe [Maybe Day]), E.Value (Maybe [Maybe Bool]))] -> [SapUserTableCsv]
sapRes2csv = concatMap procRes
- where
+ where
procRes (E.Value pn@(Just persNo), E.Value (Just sapId), E.Value firstHeld, E.Value validUntil, E.Value (fromMaybe [] -> qubFroms), E.Value (fromMaybe [] -> qubUnblocks))
| validFraportPersonalNumber pn -- between 10000 and 99999 also see Handler.Utils.Profile.validFraportPersonalNumber
= let mkSap (dfrom,duntil) = SapUserTableCsv
{ csvSUTpersonalNummer = persNo
, csvSUTqualifikation = sapId
, csvSUTgültigVon = dfrom
- , csvSUTgültigBis = duntil
+ , csvSUTgültigBis = duntil
, csvSUTausprägung = "J"
}
in fmap mkSap $ compileBlocks firstHeld validUntil $ zipMaybes qubFroms qubUnblocks
procRes _ = []
-- | compute a series of valid periods, assume that lists is already sorted by Day
--- the lists encodes qualification_user_blocks with block=False/unblock=True
+-- the lists encodes qualification_user_blocks with block=False/unblock=True
compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)]
-compileBlocks dStart dEnd = go (dStart, True)
- where
+compileBlocks dStart dEnd = go (dStart, True)
+ where
go :: (Day,Bool) -> [(Day,Bool)] -> [(Day, Day)]
go (d,s) (p1@(d1,s1):r1@((d2,s2):r2))
- | s1 == s2 && d <= d1 = go (d,s) (p1:r2) -- ignore unnecessary 2nd change
- | d1 == d2 || succ d1 == d2 || s == s1 || d > d1 = go (d,s) r1 -- ignore unnecessary 1st change
+ | s1 == s2 && d <= d1 = go (d,s) (p1:r2) -- ignore unnecessary 2nd change
+ | d1 == d2 || succ d1 == d2 || s == s1 || d > d1 = go (d,s) r1 -- ignore unnecessary 1st change
go (d,s) ((d1,s1):r1)
- | dEnd <= d1 = go (d ,s ) [] -- remaining dates extend validity
+ | dEnd <= d1 = go (d ,s ) [] -- remaining dates extend validity
| s, not s1, d < d1 = (d,d1) : go (d1,s1) r1 -- valid interval found
| s == s1 = go (d ,s ) r1 -- no change
| otherwise = go (d1,s1) r1 -- ignore invalid interval
@@ -95,18 +95,18 @@ compileBlocks dStart dEnd = go (dStart, True)
-- | Deliver all employess with a successful LDAP synch within the last 3 months
getQualificationSAPDirectR :: Handler TypedContent
getQualificationSAPDirectR = do
- now <- liftIO getCurrentTime
- fdate <- formatTime' "%Y%m%d_%H-%M" now
+ now <- liftIO getCurrentTime
+ fdate <- formatTime' "%Y%m%d_%H-%M" now
let ldap_cutoff = addDiffDaysRollOver (fromMonths $ -3) now
- qualUsers <- runDB $ E.select $ do
- (qual :& qualUser :& user :& qualBlock) <-
- E.from $ E.table @Qualification
+ qualUsers <- runDBRead $ E.select $ do
+ (qual :& qualUser :& user :& qualBlock) <-
+ E.from $ E.table @Qualification
`E.innerJoin` E.table @QualificationUser
`E.on` (\(qual :& qualUser) -> qual E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification)
`E.innerJoin` E.table @User
`E.on` (\(_ :& qualUser :& user) -> qualUser E.^. QualificationUserUser E.==. user E.^. UserId)
`E.leftJoin` E.table @QualificationUserBlock
- `E.on` (\(_ :& qualUser :& _ :& qualBlock) ->
+ `E.on` (\(_ :& qualUser :& _ :& qualBlock) ->
qualUser E.^. QualificationUserId E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
E.&&. E.val now E.>~. qualBlock E.?. QualificationUserBlockFrom
)
@@ -116,19 +116,19 @@ getQualificationSAPDirectR = do
E.&&. (E.justVal ldap_cutoff E.<=. user E.^. UserLastLdapSynchronisation)
E.groupBy ( user E.^. UserCompanyPersonalNumber
, qualUser E.^. QualificationUserFirstHeld
- , qualUser E.^. QualificationUserValidUntil
+ , qualUser E.^. QualificationUserValidUntil
, qual E.^. QualificationSapId
)
let blockOrder = [E.asc $ qualBlock E.?. QualificationUserBlockFrom, E.asc $ qualBlock E.?. QualificationUserBlockId]
-- blockAgg f = E.arrayAggWith E.AggModeAll (qualBlock E.^. f) blockOrder
- return
+ return
( user E.^. UserCompanyPersonalNumber
, qual E.^. QualificationSapId
, qualUser E.^. QualificationUserFirstHeld
, qualUser E.^. QualificationUserValidUntil
, E.arrayAggWith E.AggModeAll (E.dayMaybe $ qualBlock E.?. QualificationUserBlockFrom ) blockOrder
, E.arrayAggWith E.AggModeAll ( qualBlock E.?. QualificationUserBlockUnblock) blockOrder
- )
+ )
let csvRendered = toCsvRendered sapUserTableCsvHeader $ sapRes2csv qualUsers
fmtOpts = (review csvPreset CsvPresetRFC)
{ csvIncludeHeader = True
@@ -144,7 +144,7 @@ getQualificationSAPDirectR = do
let logInt = runDB $ logInterface "SAP" quals True (Just nr) ""
addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered <* logInt
-
+
-- direct Download see:
-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod
diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs
index a335c6923..991006030 100644
--- a/src/Handler/Users.hs
+++ b/src/Handler/Users.hs
@@ -70,15 +70,15 @@ nullaryPathPiece ''UserAction $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''UserAction id
data UserActionData = UserAvsSyncData
- | UserLdapSyncData
+ | UserLdapSyncData
| UserHijack
- | UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text }
+ | UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text }
| UserSetSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool, getActionSupervisorReason :: Maybe Text }
| UserRemoveSupervisorData
| UserRemoveSubordinatesData
-
+
deriving (Eq, Ord, Read, Show, Generic)
-
+
isNotSetSupervisor :: UserActionData -> Bool
isNotSetSupervisor UserSetSupervisorData{} = False
isNotSetSupervisor _ = True
@@ -121,21 +121,21 @@ postUsersR = do
-- (AdminUserR <$> encrypt uid)
-- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName)
, sortable (Just "user-supervisor") (i18nCell MsgTableSupervisor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
- supervisors' <- liftHandler . runDB . E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
+ supervisors' <- liftHandler . runDBRead . E.select $ E.from $ \(spvr `E.InnerJoin` usrSpvr) -> do
E.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid
E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)]
return (usrSpvr, spvr E.^. UserSupervisorRerouteNotifications)
let supervisors = intersperse (text2widget ", ") $
(\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
- icnReroute = text2widget " " <> toWgt (icon IconLetter)
+ icnReroute = text2widget " " <> toWgt (icon IconReroute)
pure $ mconcat supervisors
, sortable (Just "last-login") (i18nCell MsgLastLogin) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastAuthentication
- , sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication
+ , sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication
, sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation
, flip foldMap universeF $ \function ->
sortable (Just $ SortingKey $ CI.mk $ toPathPiece function) (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
- schools <- liftHandler . runDB . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
+ schools <- liftHandler . runDBRead . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
E.on $ school E.^. SchoolId E.==. userFunction E.^. UserFunctionSchool
E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
E.&&. userFunction E.^. UserFunctionFunction E.==. E.val function
@@ -148,7 +148,7 @@ postUsersR = do
#{sh}
|]
, sortable (Just "system-function") (i18nCell MsgUserSystemFunctions) $ \DBRow{ dbrOutput = Entity uid _ } ->
- let getFunctions = fmap (map $ userSystemFunctionFunction . entityVal) . liftHandler . runDB $ selectList [ UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False ] [ Asc UserSystemFunctionFunction ]
+ let getFunctions = fmap (map $ userSystemFunctionFunction . entityVal) . liftHandler . runDBRead $ selectList [ UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False ] [ Asc UserSystemFunctionFunction ]
in listCell' getFunctions i18nCell
, sortable Nothing (mempty & cellAttrs <>~ pure ("hide-columns--hider-label", mr MsgTableActionsHead)) $ \inp@DBRow{ dbrOutput = Entity uid _ } -> FormCell
{ formCellAttrs = []
@@ -187,14 +187,14 @@ postUsersR = do
return (act, usrSet)
acts :: Map UserAction (AForm Handler UserActionData)
- acts = mconcat
+ acts = mconcat
[ singletonMap UserLdapSync $ pure UserLdapSyncData
, singletonMap UserAvsSync $ pure UserAvsSyncData
- , singletonMap UserAddSupervisor $ UserAddSupervisorData
+ , singletonMap UserAddSupervisor $ UserAddSupervisorData
<$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
<*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
<*> aopt textField (fslI MsgSupervisorReason) Nothing
- , singletonMap UserSetSupervisor $ UserSetSupervisorData
+ , singletonMap UserSetSupervisor $ UserSetSupervisorData
<$> apopt (textField & cfAnySeparatedSet) (fslI MsgTableSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
<*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True)
<*> aopt textField (fslI MsgSupervisorReason) Nothing
@@ -209,7 +209,7 @@ postUsersR = do
, dbtProj = dbtProjId
, dbtSorting = Map.fromList $
[ ( SortingKey $ CI.mk $ toPathPiece function
- , SortColumn $ \user -> E.subSelect $ E.from $ \uf -> do
+ , SortColumn $ \user -> E.subSelect $ E.from $ \uf -> do
E.where_ $ uf E.^. UserFunctionUser E.==. user E.^. UserId
E.&&. uf E.^. UserFunctionFunction E.==. E.val function
return (uf E.^. UserFunctionSchool)
@@ -254,9 +254,9 @@ postUsersR = do
return (usrSpvr E.^. UserDisplayName)
)
, ( "system-function"
- , SortColumn $ \user -> E.subSelect $ E.from $ \usf -> do
+ , SortColumn $ \user -> E.subSelect $ E.from $ \usf -> do
E.where_ $ usf E.^. UserSystemFunctionUser E.==. user E.^. UserId
- return $ usf E.^. UserSystemFunctionFunction
+ return $ usf E.^. UserSystemFunctionFunction
)
]
, dbtFilter = Map.fromList -- OverloadedLists does not work with the templates
@@ -265,7 +265,7 @@ postUsersR = do
-- if Set.null criteria then E.true else -- TODO: why is this condition not needed?
-- -- Set.foldr (\needle acc -> acc E.||. (user E.^. UserDisplayName) `E.hasInfix` needle) eFalse (criterion :: Set.Set Text)
-- E.any (\c -> user E.^. UserDisplayName `E.hasInfix` E.val c) criteria
- -- )
+ -- )
-- , ( "user-ident", FilterColumn $ \user criterion -> case getLast (criterion :: Last Text) of
-- Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
-- Just needle -> E.castString (user E.^. UserIdent) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)
@@ -299,8 +299,14 @@ postUsersR = do
in E.maybe E.true (E.<=. E.val minTime) $ user E.^. UserLastLdapSynchronisation
| otherwise -> E.val True :: E.SqlExpr (E.Value Bool)
)
+ , ( "avs-sync", FilterColumn . E.mkExistsFilter $ \user criterion ->
+ E.from $ \usrAvs -> do
+ let minTime = (E.val criterion :: E.SqlExpr (E.Value UTCTime))
+ E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId
+ E.&&. usrAvs E.^. UserAvsLastSynch E.<=. minTime
+ )
, ( "user-company", FilterColumn . E.mkExistsFilter $ \user criterion ->
- E.from $ \(usrComp `E.InnerJoin` comp) -> do
+ E.from $ \(usrComp `E.InnerJoin` comp) -> do
let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
(E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
@@ -317,12 +323,12 @@ postUsersR = do
E.&&. E.any (E.hasInfix (usrSpvr E.^. UserDisplayName)) (E.val <$> Set.toList criteria)
)
-- , ( "avs-number", FilterColumn $ E.mkExistsFilterWithComma CI.mk $ \user criterion -> -- note that this is an exact filter
- -- E.from $ \usrAvs -> -- do
+ -- E.from $ \usrAvs -> -- do
-- E.where_ $ user E.^. UserId E.==. usrAvs E.^. UserAvsUser
-- E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
-- (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )
-- )
- , ( "is-supervisor", FilterColumn $ \user criterion -> case criterion of
+ , ( "is-supervisor", FilterColumn $ \user criterion -> case criterion of
Last (Just True) -> E.exists . E.from $ \usrSpr -> E.where_ $ user E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor
Last (Just False) -> E.notExists . E.from $ \usrSpr -> E.where_ $ user E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor
_ -> E.val True :: E.SqlExpr (E.Value Bool)
@@ -341,8 +347,9 @@ postUsersR = do
, prismAForm (singletonFilter "user-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)
, prismAForm (singletonFilter "school") mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool)
, prismAForm (singletonFilter "is-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgUserIsSupervisor)
- , prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode)
+ , prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode)
, prismAForm (singletonFilter "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore)
+ , prismAForm (singletonFilter "avs-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLastAvsSyncedBefore)
]
, dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
, dbtParams = DBParamsForm
@@ -368,10 +375,10 @@ postUsersR = do
formResult usersRes $ \case
(act, usersSet)
| Set.null usersSet && isNotSetSupervisor act ->
- addMessageI Info MsgActionNoUsersSelected
+ addMessageI Info MsgActionNoUsersSelected
(UserLdapSyncData, userSet) -> do
forM_ userSet $ \uid -> queueJob' $ JobSynchroniseLdapUser uid
- addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet
+ addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet
redirectKeepGetParams UsersR
(UserAvsSyncData, userSet) -> do
n <- runDB $ queueAvsUpdateByUID userSet Nothing
@@ -379,7 +386,7 @@ postUsersR = do
redirectKeepGetParams UsersR
(UserHijack, Set.lookupMin -> Just uid) ->
hijackUser uid >>= sendResponse
- (UserRemoveSupervisorData, userSet) -> do
+ (UserRemoveSupervisorData, userSet) -> do
runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet]
addMessageI Success $ MsgUsersRemoveSupervisors $ Set.size userSet
redirectKeepGetParams UsersR
@@ -388,11 +395,11 @@ postUsersR = do
addMessageI Success $ MsgUsersRemoveSubordinates $ Set.size userSet
redirectKeepGetParams UsersR
(act, usersSet)
- | isActionSupervisor act -> do
+ | isActionSupervisor act -> do
avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser $ getActionSupervisors act
let (supersFound, supersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers
users = Set.toList usersSet
- nrSuperNotFound = length supersNotFound
+ nrSuperNotFound = length supersNotFound
runDB $ do
unless (isNotSetSupervisor act) $ deleteWhere [UserSupervisorUser <-. users]
putMany [UserSupervisor s u r Nothing (getActionSupervisorReason act)
@@ -413,7 +420,7 @@ postUsersR = do
runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey)
addMessageI Success MsgSynchroniseLdapAllUsersQueued
redirect UsersR
- AllUsersAvsSync -> do
+ AllUsersAvsSync -> do
now <- liftIO getCurrentTime
let nowaday = utctDay now
n <- runDB $ E.insertSelectWithConflictCount UniqueAvsSyncUser
@@ -425,7 +432,7 @@ postUsersR = do
-- Ex.<&> Ex.just (E.day E.now_) -- don't use DB time here, since job handler compares with FRADrive clock
Ex.<&> E.justVal nowaday
)
- ) (\current excluded ->
+ ) (\current excluded ->
[ AvsSyncCreationTime E.=. E.least (current E.^. AvsSyncCreationTime) (excluded E.^. AvsSyncCreationTime)
, AvsSyncPause E.=. E.greatest (current E.^. AvsSyncPause) (excluded E.^. AvsSyncPause)
]
@@ -450,7 +457,7 @@ hijackUser uid = do
setCredsRedirect $ Creds apDummy (CI.original userIdent) []
getAdminHijackUserR :: CryptoUUIDUser -> Handler Html
-getAdminHijackUserR cID = do
+getAdminHijackUserR cID = do
(hijackWgt, hijackEnctype) <- generateFormPost hijackUserForm
let hjForm = wrapForm hijackWgt def{ formSubmit = FormNoSubmit, formEncoding = hijackEnctype, formAction = Just . SomeRoute $ AdminHijackUserR cID }
uid :: UserId <- decrypt cID
@@ -463,7 +470,7 @@ getAdminHijackUserR cID = do
|]
postAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent
-postAdminHijackUserR cID = do
+postAdminHijackUserR cID = do
((hijackRes, _), _) <- runFormPost hijackUserForm
$logWarnS "HIJACK" $ "Form Result is: " <> tshow hijackRes
uid <- decrypt cID
@@ -517,13 +524,13 @@ postAdminUserR uuid = do
queueJob' $ JobSynchroniseLdapUser uid
addMessageI Success $ MsgSynchroniseLdapUserQueued 1
redirectKeepGetParams $ AdminUserR uuid
- ThisUserAvsSync -> do
+ ThisUserAvsSync -> do
n <- runDB $ queueAvsUpdateByUID (Set.singleton uid) Nothing
addMessageI Success $ MsgSynchroniseAvsUserQueued $ fromIntegral n
redirectKeepGetParams $ AdminUserR uuid
-- ThisUserHijack -> do
-- redirect $ AdminHijackUserR uuid
- let thisUserActWgt = wrapForm thisUserActWgt' def
+ let thisUserActWgt = wrapForm thisUserActWgt' def
{ formSubmit = FormNoSubmit
, formAction = Just $ SomeRoute $ AdminUserR uuid
, formEncoding = thisUserActEnctype
diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs
index 7a47218b4..2f09d0804 100644
--- a/src/Handler/Utils/Avs.hs
+++ b/src/Handler/Utils/Avs.hs
@@ -171,11 +171,11 @@ lookupAvsUsers apis = do
updateReceivers :: UserId -> Handler (Entity User, [Entity User], Bool)
updateReceivers uid = do
-- First perform AVS update for receiver
- runDB (getBy (UniqueUserAvsUser uid)) >>= \case
+ runDBRead (getBy (UniqueUserAvsUser uid)) >>= \case
Just Entity{entityVal=UserAvs{userAvsPersonId = apid}} -> catchAll2log $ upsertAvsUserById apid
Nothing -> return ()
-- Retrieve updated user and supervisors now
- (underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDB $ (,)
+ (underling :: Entity User, avsSupers :: [(E.Value UserId, E.Value (Maybe AvsPersonId))]) <- runDBRead $ (,)
<$> getJustEntity uid
<*> (E.select $ do
(usrSuper :& usrAvs) <-
@@ -194,7 +194,7 @@ updateReceivers uid = do
if null receiverIDs
then directResult
else do
- receivers <- runDB $ selectList [UserId <-. receiverIDs] [] -- due to possible address updates, we must runDB once more and cannot join above
+ receivers <- runDBRead $ selectList [UserId <-. receiverIDs] [] -- due to possible address updates, we must runDB once more and cannot join above
if null receivers
then directResult
else return (underling, receivers, uid `elem` (entityKey <$> receivers))
@@ -450,7 +450,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
linktoAvsUserByUIDs :: Set UserId -> Handler ()
linktoAvsUserByUIDs uids = do
- ips <- runDB $ E.select $ do
+ ips <- runDBRead $ E.select $ do
usr <- E.from $ E.table @User
let uid = usr E.^. UserId
ipn = usr E.^. UserCompanyPersonalNumber
@@ -484,18 +484,18 @@ createAvsUserById muid api = do
case Set.toList contactRes of
[] -> throwM $ AvsUserUnknownByAvs api
(_:_:_) -> throwM $ AvsUserAmbiguous api
- [AvsDataContact{avsContactPersonInfo=cpi, avsContactFirmInfo=firmInfo, avsContactPersonID}]
+ [adc@AvsDataContact{avsContactPersonInfo=cpi, avsContactFirmInfo=firmInfo, avsContactPersonID}]
| avsContactPersonID /= api -> throwM $ AvsIdMismatch api avsContactPersonID
| otherwise -> do
-- check for matching existing user
let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
- persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
- oldUsr <- runDB $ do
+ -- persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
+ oldUsr <- runDBRead $ do
mbUid <- if isJust muid
then return muid
else firstJustM $ catMaybes
[ internalPersNo <&> (\ipn -> getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn]) -- must ensure filter isnt ==. Nothing
- , persMail <&> guessUserByEmail
+ -- , persMail <&> guessUserByEmail -- this did not work, as unfortunately, superiors are sometimes listed under _avsInfoPersonEMail!
]
mbUAvs <- (getBy . UniqueUserAvsUser) `traverseJoin` mbUid
return (mbUid, mbUAvs)
@@ -533,11 +533,11 @@ createAvsUserById muid api = do
, audFirstName = cpi ^. _avsInfoFirstName & Text.strip
, audSurname = cpi ^. _avsInfoLastName & Text.strip
, audDisplayName = cpi ^. _avsInfoDisplayName
- , audDisplayEmail = persMail & fromMaybe mempty
- , audEmail = persMail & fromMaybe ("AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI)
- , audIdent = persMail & fromMaybe ("AVSID:" <> ciShow api )
+ , audDisplayEmail = adc ^. _avsContactPrimaryEmail . to (fromMaybe mempty) . from _CI
+ , audEmail = "AVSNO:" <> cpi ^. _avsInfoPersonNo . from _CI
+ , audIdent = "AVSID:" <> ciShow api
, audAuth = maybe AuthKindNoLogin (const AuthKindLDAP) internalPersNo
- , audMatriculation = cpi ^. _avsInfoPersonNo & Just . tshow
+ , audMatriculation = cpi ^. _avsInfoPersonNo & Just
, audSex = Nothing
, audBirthday = cpi ^. _avsInfoDateOfBirth
, audMobile = cpi ^. _avsInfoPersonMobilePhoneNo
@@ -676,9 +676,14 @@ upsertCompanySuperior (mbCid, newAfi) mbOldAfi = runMaybeT $ do
oldSup = snd <$> oldChanges
unless (supChange == Just False) $ do
-- upsert new superior company supervisor
+ mbMaxPrio <- E.selectOne $ do
+ usrCmp <- E.from $ E.table @UserCompany
+ E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val supid
+ return . E.max_ $ usrCmp E.^. UserCompanyPriority
+ let maxPrio = maybe 1 (fromMaybe 1 . E.unValue) mbMaxPrio
suprEnt <- upsertBy (UniqueUserCompany supid cid)
- (UserCompany supid cid True False 1 True)
- [UserCompanySupervisor =. True]
+ (UserCompany supid cid True False maxPrio True)
+ [UserCompanySupervisor =. True, UserCompanyPriority =. maxPrio]
E.insertSelectWithConflict UniqueUserSupervisor
(do
usr <- E.from $ E.table @UserCompany
@@ -736,15 +741,15 @@ guessAvsUser :: Text -> Handler (Maybe UserId)
guessAvsUser (Text.splitAt 6 -> (Text.toUpper -> prefix, readMay -> Just nr))
| prefix=="AVSID:" =
let avsid = AvsPersonId nr in
- runDB (getBy $ UniqueUserAvsId avsid) >>= \case
+ runDBRead (getBy $ UniqueUserAvsId avsid) >>= \case
(Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> return $ Just uid
Nothing -> catchAVS2message $ Just <$> upsertAvsUserById avsid
| prefix=="AVSNO:" =
- runDB (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr])
+ runDBRead (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr])
guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) =
catchAVS2message $ upsertAvsUserByCard someavsid >>= \case
Nothing | Left{} <- someavsid -> -- attempt to find PersonalNumber in DB
- runDB (getKeyByFilter [UserCompanyPersonalNumber ==. Just someid])
+ runDBRead (getKeyByFilter [UserCompanyPersonalNumber ==. Just someid])
other -> return other
guessAvsUser someid = do
try (runDB $ ldapLookupAndUpsert someid) >>= \case
diff --git a/src/Handler/Utils/AvsUpdate.hs b/src/Handler/Utils/AvsUpdate.hs
index 8a88cb6b0..5ff7c55fa 100644
--- a/src/Handler/Utils/AvsUpdate.hs
+++ b/src/Handler/Utils/AvsUpdate.hs
@@ -109,7 +109,7 @@ data CU_UserAvs_User
| CU_UA_UserMatrikelnummer
| CU_UA_UserCompanyPersonalNumber
| CU_UA_UserLdapPrimaryKey
- -- CU_UA_UserDisplayEmail -- use _avsContactPrimaryEmailAddress instead
+ -- CU_UA_UserDisplayEmail -- use _avsContactPrimaryEmail instead
deriving (Show, Eq)
instance MkCheckUpdate CU_UserAvs_User where
diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs
index 84bcf76e3..d82adf69f 100644
--- a/src/Handler/Utils/Company.hs
+++ b/src/Handler/Utils/Company.hs
@@ -40,16 +40,16 @@ wgtCompanies = \uid -> do
^{c}
$forall c <- otherCmp
- #{c}
+ ^{c}
|]
return $ toMaybe (notNull topCmp) resWgt
where
- procCmp _ [] = (0, [],[])
+ procCmp _ [] = (0, [], [])
procCmp maxPri ((E.Value cmpSh, E.Value cmpName, E.Value cmpSpr, E.Value cmpPrio) : cs) =
- let cmpWgt = companyWidget (cmpSh, cmpName, cmpSpr)
- isTop = cmpPrio >= maxPri
+ let isTop = cmpPrio >= maxPri
+ cmpWgt = companyWidget isTop (cmpSh, cmpName, cmpSpr)
(accPri,accTop,accRem) = procCmp maxPri cs
- in (max cmpPrio accPri, bool accTop (cmpWgt : accTop) isTop, bool (cmpName : accRem) accRem isTop) -- lazy evaluation after repmin example
+ 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
diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs
index e3feec877..269747570 100644
--- a/src/Handler/Utils/Qualification.hs
+++ b/src/Handler/Utils/Qualification.hs
@@ -112,12 +112,14 @@ validQualification' cutoff qualUser =
E.&&. quserBlock' False cutoff qualUser
-- selectValidQualifications :: QualificationId -> [UserId] -> UTCTime -> DB [Entity QualificationUser]
-selectValidQualifications ::
- ( MonadIO m
- , BackendCompatible SqlBackend backend
- , PersistQueryRead backend
- , PersistUniqueRead backend
- ) => QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser]
+-- selectValidQualifications ::
+-- ( MonadIO m
+-- , BackendCompatible SqlBackend backend
+-- , PersistQueryRead backend
+-- , PersistUniqueRead backend
+-- ) => QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser]
+selectValidQualifications :: (MonadIO m, E.SqlBackendCanRead backend)
+ => QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser]
selectValidQualifications qid uids cutoff =
-- cutoff <- utctDay <$> liftIO getCurrentTime
E.select $ do
diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs
index 18b2186fb..1c62f37a8 100644
--- a/src/Handler/Utils/Table/Cells.hs
+++ b/src/Handler/Utils/Table/Cells.hs
@@ -14,7 +14,7 @@ import Handler.Utils.DateTime
import Handler.Utils.Widgets
import Handler.Utils.Occurrences
import Handler.Utils.LMS (lmsUserStatusWidget)
-import Handler.Utils.Qualification (isValidQualification)
+import Handler.Utils.Qualification (isValidQualification)
type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles !
@@ -41,16 +41,23 @@ cellTell = flip tellCell
indicatorCell :: IsDBTable m Any => DBCell m Any -- For dbTables that return a Bool to indicate content
indicatorCell = writerCell . tell $ Any True
+addIndicatorCell :: IsDBTable m Any => DBCell m Any -> DBCell m Any
+addIndicatorCell = tellCell $ Any True
+
writerCell :: IsDBTable m w => WriterT w m () -> DBCell m w
writerCell act = mempty & cellContents %~ (<* act)
--- for documentation purposes
+-- for documentation purposes
cellMaybe :: IsDBTable m b => (a -> DBCell m b) -> Maybe a -> DBCell m b
cellMaybe = foldMap
maybeCell :: IsDBTable m b => Maybe a -> (a -> DBCell m b) -> DBCell m b
maybeCell = flip foldMap
+boolCell :: IsDBTable m b => Bool -> DBCell m b -> DBCell m b
+boolCell True c = c
+boolCell False _ = mempty
+
htmlCell :: (IsDBTable m a, ToMarkup c) => c -> DBCell m a
htmlCell = cell . toWidget . toMarkup
@@ -62,7 +69,7 @@ sqlCell :: (IsDBTable (YesodDB UniWorX) a) => YesodDB UniWorX Widget -> DBCell (
sqlCell act = mempty & cellContents .~ lift act
-- TODO: Formulate variant of sqlCell that types for tables having actions, i.e. MForm istead of YesodDB?
--- sqlCell' :: (IsDBTable (MForm Handler) a) => _ -> DBCell (MForm Handler) a
+-- sqlCell' :: (IsDBTable (MForm Handler) a) => _ -> DBCell (MForm Handler) a
-- sqlCell' = flip (set' cellContents) mempty
-- | Highlight table cells with warning: Is not yet implemented in frontend.
@@ -158,14 +165,14 @@ modalCell content = cell $ modal (toWidget $ hasComment True) (Right $ toWidget
-- | Show Text if it is small, create modal otherwise
modalCellLarge :: (IsDBTable m a, ToWidget UniWorX t, MonoFoldable t, Element t ~ Char) => t -> DBCell m a
-modalCellLarge content
+modalCellLarge content
| length content > 32 = modalCell content
| otherwise = stringCell content
markupCellLargeModal :: IsDBTable m a => StoredMarkup -> DBCell m a
markupCellLargeModal mup
| markupIsSmallish mup = cell $ toWidget mup
- | otherwise = modalCell mup
+ | otherwise = modalCell mup
-----------------
-- Datatype cells
@@ -221,44 +228,44 @@ cellHasUserLink toLink user =
-- | like `cellHasUserLink` but opens the user in a modal instead; link is only displayed if the user has sufficient rights
cellHasUserModal :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c
-cellHasUserModal toLink user =
+cellHasUserModal toLink user =
let userEntity = user ^. hasEntityUser
uid = userEntity ^. _entityKey
nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname)
- lWdgt = do
+ lWdgt = do
uuid <- liftHandler $ encrypt uid
- modalAccess nWdgt nWdgt False $ toLink uuid
+ modalAccess nWdgt nWdgt False $ toLink uuid
in cell lWdgt
-- | like `cellHasUserModal` but but always display link without prior access rights checks
cellHasUserModalAdmin :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c
-cellHasUserModalAdmin toLink user =
+cellHasUserModalAdmin toLink user =
let userEntity = user ^. hasEntityUser
uid = userEntity ^. _entityKey
nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname)
- lWdgt = do
+ lWdgt = do
uuid <- liftHandler $ encrypt uid
- modal nWdgt $ Left $ SomeRoute $ toLink uuid
+ modal nWdgt $ Left $ SomeRoute $ toLink uuid
in cell lWdgt
-- | like `cellHasUserModal` but with fixed route and showing an edit icon instead; link is only displayed if the user has sufficient rights
cellEditUserModal :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c
-cellEditUserModal user =
+cellEditUserModal user =
let userEntity = user ^. hasEntityUser
uid = userEntity ^. _entityKey
- nWdgt = toWidget $ icon IconUserEdit
- lWdgt = do
+ nWdgt = toWidget $ icon IconUserEdit
+ lWdgt = do
uuid <- liftHandler $ encrypt uid
modalAccess mempty nWdgt True $ ForProfileR uuid
in cell lWdgt
-- | like `cellEditUserModal` but always displays the link without prior access rights checks
cellEditUserModalAdmin :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c
-cellEditUserModalAdmin user =
+cellEditUserModalAdmin user =
let userEntity = user ^. hasEntityUser
uid = userEntity ^. _entityKey
- nWdgt = toWidget $ icon IconUserEdit
- lWdgt = do
+ nWdgt = toWidget $ icon IconUserEdit
+ lWdgt = do
uuid <- liftHandler $ encrypt uid
modal nWdgt (Left $ SomeRoute $ ForProfileR uuid)
in cell lWdgt
@@ -267,23 +274,23 @@ cellHasMatrikelnummer :: (IsDBTable m a, HasUser u) => u -> DBCell m a
cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer
cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => Bool -> u -> DBCell m a
-cellHasMatrikelnummerLinked isAdmin usr
- | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do
+cellHasMatrikelnummerLinked isAdmin usr
+ | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do
uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey
if isAdmin
then modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid)
else modalAccess mempty (text2widget matNr) False (AdminAvsUserR uuid)
| otherwise = mempty
- where
+ where
usrEntity = usr ^. hasEntityUser
cellHasMatrikelnummerLinkedAdmin :: (IsDBTable m a, HasEntity u User) => u -> DBCell m a
-cellHasMatrikelnummerLinkedAdmin usr
- | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do
+cellHasMatrikelnummerLinkedAdmin usr
+ | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do
uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey
- modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid)
+ modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid)
| otherwise = mempty
- where
+ where
usrEntity = usr ^. hasEntityUser
@@ -393,7 +400,7 @@ qualificationDescrCell (view hasQualification -> q@Qualification{..}) = qualific
qualificationValidIconCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Day -> Maybe b -> a -> DBCell m c
qualificationValidIconCell d qb qu = do
blockIcon $ isValidQualification d qu qb
- where
+ where
blockIcon = cell . toWidget . iconQualificationBlock
qualificationValidUntilCell :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Day -> Maybe b -> a -> DBCell m c
@@ -402,11 +409,11 @@ qualificationValidUntilCell = qualificationValidUntilCell' (Just LmsUserAllR)
qualificationValidUntilCell' :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Maybe (CryptoUUIDUser -> Route UniWorX) -> Day -> Maybe b -> a -> DBCell m c
qualificationValidUntilCell' mbToLink d qb qu = cell $ case mbToLink of
Nothing -> headWgt <> dateWgt
- Just toLink -> do
+ Just toLink -> do
uuid <- liftHandler $ encrypt $ qu ^. hasQualificationUser . _qualificationUserUser
let modalWgt = modalAccess dateWgt dateWgt False $ toLink uuid
headWgt <> modalWgt
- where
+ where
dateWgt = formatTimeW SelFormatDate (qu ^. hasQualificationUser . _qualificationUserValidUntil)
iconWgt = toWidget $ iconQualificationBlock $ isValidQualification d qu qb
headWgt = iconWgt <> [whamlet| |]
@@ -416,18 +423,18 @@ qualificationValidReasonCell = qualificationValidReasonCell' (Just LmsUserAllR)
qualificationValidReasonCell' :: (IsDBTable m c, HasQualificationUser a, HasQualificationUserBlock b) => Maybe (CryptoUUIDUser -> Route UniWorX) -> Bool -> Day -> Maybe b -> a -> DBCell m c
qualificationValidReasonCell' mbToLink showReason d qb qu = ic <> foldMap blc qb
- where
+ where
ic = cell . toWidget . iconQualificationBlock $ isValidQualification d qu qb
blc (view hasQualificationUserBlock -> QualificationUserBlock{..})
- | showReason = spacerCell <> dc qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason
+ | showReason = spacerCell <> dc qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason
| qualificationUserBlockUnblock = mempty
| otherwise = spacerCell <> dateCell qualificationUserBlockFrom
- dc tstamp
+ dc tstamp
| Just toLink <- mbToLink = cell $ do
uuid <- liftHandler $ encrypt uid
let dWgt = formatTimeW SelFormatDate tstamp
modalAccess dWgt dWgt False $ toLink uuid
- -- anchorCellM (toLink <$> encrypt uid)
+ -- anchorCellM (toLink <$> encrypt uid)
| otherwise = dateCell tstamp
uid = qu ^. hasQualificationUser . _qualificationUserUser
@@ -438,15 +445,15 @@ qualificationValidReasonCell'' mbToLink showReason d qb qu extValid = ic <> icEr
icErr = cell . toWidget . isBad $ quValid /= extValid
ic = cell . toWidget $ iconQualificationBlock quValid
blc (view hasQualificationUserBlock -> QualificationUserBlock{..})
- | showReason = spacerCell <> dc qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason
+ | showReason = spacerCell <> dc qualificationUserBlockFrom <> spacerCell <> modalCellLarge qualificationUserBlockReason
| qualificationUserBlockUnblock = mempty
| otherwise = spacerCell <> dateCell qualificationUserBlockFrom
- dc tstamp
+ dc tstamp
| Just toLink <- mbToLink = cell $ do
uuid <- liftHandler $ encrypt uid
let dWgt = formatTimeW SelFormatDate tstamp
modalAccess dWgt dWgt False $ toLink uuid
- -- anchorCellM (toLink <$> encrypt uid)
+ -- anchorCellM (toLink <$> encrypt uid)
| otherwise = dateCell tstamp
uid = qu ^. hasQualificationUser . _qualificationUserUser
@@ -496,7 +503,7 @@ lmsStatusCell extendedInfo mkLink = wgtCell . lmsUserStatusWidget extendedInfo m
lmsStateCell :: IsDBTable m a => LmsState -> DBCell m a
lmsStateCell LmsFailed = iconBoolCell False
-lmsStateCell LmsOpen = iconSpacerCell
+lmsStateCell LmsOpen = iconSpacerCell
lmsStateCell LmsPassed = iconBoolCell True
avsPersonNoCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c
@@ -515,7 +522,7 @@ avsPersonNoLinkedCellAdmin a = cell $ do
modal nWgt (Left $ SomeRoute $ AdminAvsUserR uuid)
avsPersonCardCell :: (IsDBTable m c) => Set AvsDataPersonCard -> DBCell m c
-avsPersonCardCell cards = wgtCell
+avsPersonCardCell cards = wgtCell
[whamlet|
$newline never
@@ -523,6 +530,6 @@ avsPersonCardCell cards = wgtCell
-
_{c}
|]
- where
+ where
validCards = Set.filter avsDataValid cards
validColors = Set.toDescList $ Set.map avsDataCardColor validCards
\ No newline at end of file
diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs
index 91f731f75..10fb0d544 100644
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/src/Handler/Utils/Table/Pagination.hs
@@ -84,7 +84,7 @@ import Data.Ratio ((%))
import qualified Data.Foldable as Foldable
import qualified Yesod.Form.Functions as Yesod
-
+
import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.Internal.Internal as E (SqlSelect,unsafeSqlValue)
@@ -170,7 +170,7 @@ dbFilterKey ident = toPathPiece . WithIdent ident
data SomeExprValue = forall a. PersistField a => SomeExprValue { getSomeExprValue :: E.SqlExpr (E.Value a) }
-
+
data SortColumn t r' = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
| forall a. PersistField a => SortColumnNullsInv { getSortColumn :: t -> E.SqlExpr (E.Value a) }
| forall a. PersistField a => SortColumnNeverNull { getSortColumn :: t -> E.SqlExpr (E.Value a) }
@@ -264,7 +264,7 @@ instance Monoid (DBTProjFilterPost r') where
data FilterColumn t fs = forall a. IsFilterColumn t a => FilterColumn a
| forall a. IsFilterColumnHandler t a => FilterColumnHandler a
| forall a. IsFilterProjected fs a => FilterProjected a
-
+
filterColumn :: FilterColumn t fs -> Maybe ([Text] -> t -> E.SqlExpr (E.Value Bool))
filterColumn (FilterColumn f) = Just $ filterColumn' f
@@ -292,9 +292,9 @@ instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where
instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where
filterColumn' cont is' = filterColumn' (cont $ is' ^. mono' _PathPiece) is'
-
-class IsFilterColumnHandler t a where
- filterColumnHandler' :: a -> [Text] -> Handler (t -> E.SqlExpr (E.Value Bool))
+
+class IsFilterColumnHandler t a where
+ filterColumnHandler' :: a -> [Text] -> Handler (t -> E.SqlExpr (E.Value Bool))
instance IsFilterColumnHandler t ([Text] -> Handler (t -> E.SqlExpr (E.Value Bool))) where
filterColumnHandler' fin args = fin args
@@ -482,7 +482,7 @@ data DBCsvMode
| DBCsvAbort
makePrisms ''DBCsvMode
-
+
data DBCsvDiff r' csv k'
= DBCsvDiffNew
{ dbCsvNewKey :: Maybe k'
@@ -519,7 +519,7 @@ makeLenses_ ''DBCsvException
instance (Typeable k', Show k') => Exception (DBCsvException k')
-
+
data DBTProjCtx fs r = DBTProjCtx
{ dbtProjFilter :: fs
, dbtProjRow :: DBRow r
@@ -613,7 +613,7 @@ data DBStyle r = DBStyle
}
data DBSTemplateMode r = DBSTDefault { dbstmNumber :: Int64 -> Bool, dbstmShowNumber :: Int64 -> Bool }
- | DBSTCourse
+ | DBSTCourse
(Lens' r (Entity Course)) -- course
(Traversal' r (Entity User)) -- lecturers
(Lens' r Bool) -- isRegistered
@@ -666,7 +666,7 @@ multiFilter key = prism' fromInner fromOuter
-- prism' :: (Maybe [v] -> (Map k [v])) -> ((Map k [v]) -> Maybe (Maybe [v])) -> Prism' (Map k [v]) (Maybe [v])
fromInner = maybe Map.empty (Map.singleton key)
fromOuter = Just . Map.lookup key
-
+
data DBTCsvEncode r' k' csv = forall exportData filename sheetName.
( ToNamedRecord csv, CsvColumnsExplained csv
, DBTableKey k'
@@ -750,7 +750,7 @@ dbtProjId :: forall fs r r'.
( fs ~ (), DBRow r ~ r' )
=> ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
dbtProjId = dbtProjId'
-
+
dbtProjSimple' :: forall fs r r' r''.
DBRow r'' ~ r'
=> (r -> DB r'')
@@ -1059,7 +1059,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
doSorting <- or2M
(getsYesod . views _appBotMitigations $ Set.notMember SettingBotMitigationOnlyLoggedInTableSorting)
(is _Just <$> maybeAuthId)
-
+
let
sortingOptions = mkOptionList
[ Option t' (SortingSetting t d) t'
@@ -1112,7 +1112,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
<|> piInput
psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit
-
+
let
-- adjustPI = over _piSorting $ guardOnM doSorting -- probably not neccessary; not displaying the links should be enough for now
((errs, PaginationSettings{..}), paginationInput@PaginationInput{..})
@@ -1217,8 +1217,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
-- && all (is _Just) filterSql
-- psLimit' = bool PagesizeAll psLimit selectPagesize
-
- filterHandler <- case csvMode of
+
+ filterHandler <- case csvMode of
FormSuccess DBCsvImport{} -> return mempty -- don't execute Handler actions for unneeded filters upon csv _import_
_other -> liftHandler $ forM psFilter' $ \(fc,args) -> mapM ($ args) $ filterColumnHandler fc
@@ -1240,7 +1240,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps -- Note that multiple where_ are indeed concatenated
_other -> return ()
let filterAppT = Map.foldr (\fc expr -> maybe expr ((: expr) . ($ t)) fc) []
- sqlFilters = filterAppT filterHandler <> filterAppT filterSql -- Note that <> on the maps won't work as intended, since keys are present in both
+ sqlFilters = filterAppT filterHandler <> filterAppT filterSql -- Note that <> on the maps won't work as intended, since keys are present in both
unless (null sqlFilters) $ E.where_ $ E.and sqlFilters
return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res)
@@ -1279,7 +1279,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
exData <- hoistMaybe dbtCsvExampleData
hdr <- lift $ dbtCsvHeader Nothing
exportUrl <- toTextUrl (currentRoute, [(toPathPiece GetCsvExampleData, "")])
- return $(widgetFile "table/csv-example")
+ return $(widgetFile "table/csv-example")
formResult csvMode $ \case
DBCsvAbort{} -> do
@@ -1470,7 +1470,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
guardM doAltRep
cts <- reqAccept <$> getRequest
-
+
altRep <- hoistMaybe <=< asum $ do
mRep <- hoistMaybe . selectRep' extraReps' =<< cts
return . return $ mRep <&> \case
@@ -1520,7 +1520,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
-> State.modify $ (:) (n, beforeSize, cellSize)
| otherwise -> return ()
let rowspanAcc'' = rowspanAcc'
- & traverse . _1 %~ pred
+ & traverse . _1 %~ pred
whenIsJust (flattenAnnotated v) $ go rowspanAcc''
compCellSize :: forall h' c. [(Int, Int, Int)] -> [Sized (Maybe Int) h' c] -> Sized (Maybe Int) h' c -> (Int, Maybe Int)
@@ -1634,7 +1634,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
addMessageI Success . MsgCsvImportSuccessful $ length acts'
E.transactionSave
redirect finalDest
-
+
_other -> return ((FormMissing, mempty), mempty)
formResult csvImportConfirmRes $ \case
(_, BtnCsvImportAbort) -> do
@@ -1661,7 +1661,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
setParam :: Text -> Maybe Text -> QueryText -> QueryText
setParam key = setParams key . maybeToList
-
+
dbTableWidget :: Monoid x
=> PSValidator (HandlerFor UniWorX) x
@@ -1784,7 +1784,7 @@ anchorCellCM cache routeM widget = anchorCellCM' cache routeM id (const widget)
anchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a
anchorCellM' xM x2route x2widget = linkEitherCellM' xM x2route (x2widget, x2widget)
-
+
anchorCellCM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, Binary cache) => cache -> WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a
anchorCellCM' cache xM x2route x2widget = linkEitherCellCM' cache xM x2route (x2widget, x2widget)
@@ -1855,7 +1855,7 @@ maybeLinkEitherCellCM' mCache xM x2route (x2widgetAuth,x2widgetUnauth) = cell $
listCell :: (IsDBTable m a, MonoFoldable mono) => mono -> (Element mono -> DBCell m a) -> DBCell m a
listCell = listCell' . return
-
+
listCell' :: (IsDBTable m a, MonoFoldable mono) => WriterT a m mono -> (Element mono -> DBCell m a) -> DBCell m a
listCell' mkXS mkCell = ilistCell' (otoList <$> mkXS) $ const mkCell
@@ -1926,7 +1926,7 @@ dbSelect :: forall x h r i a. (Headedness h, Monoid' x)
-> Colonnade h (DBRow r) (DBCell (MForm (HandlerFor UniWorX)) x)
-- dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ formCell resLens genIndex genForm
dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ mempty & cellAttrs <>~ pure ("uw-hide-columns--no-hide","")) $ formCell resLens genIndex genForm
- where
+ where
genForm _ mkUnique = do
(selResult, selWidget) <- mreq checkBoxField (fsUniq mkUnique "select") (Just False)
return (set selLens <$> selResult, [whamlet|^{fvWidget selWidget}|])
@@ -1936,7 +1936,7 @@ dbSelectIf :: forall x h r i a. (Headedness h, Monoid' x)
=> Lens' x (FormResult (DBFormResult i a (DBRow r)))
-> Setter' a Bool
-> (DBRow r -> MForm (HandlerFor UniWorX) i)
- -> (DBRow r -> Bool)
+ -> (DBRow r -> Bool)
-> Colonnade h (DBRow r) (DBCell (MForm (HandlerFor UniWorX)) x)
dbSelectIf resLens selLens genIndex condition = Colonnade.singleton (headednessPure $ mempty & cellAttrs <>~ [("uw-hide-columns--no-hide", mempty)] ) fCell
where
@@ -1945,9 +1945,9 @@ dbSelectIf resLens selLens genIndex condition = Colonnade.singleton (headednessP
(selResult, selWidget) <- mreq checkBoxField ((bool inputDisabled id $ condition row) $ fsUniq mkUnique "select") (Just False) -- produces disabled field, but still checked by master checkbox from header
--(selResult, selWidget) <- mreq (bool noField checkBoxField $ condition row) (fsUniq mkUnique "select") (Just False) -- omits field entirely, but also removes master checkbox from header
{- Similar to previous: omits field entirely, but also removes master checkbox from header
- (selResult, selWidget) <- if condition row
+ (selResult, selWidget) <- if condition row
then mreq checkBoxField (fsUniq mkUnique "select") (Just False)
- else return (FormMissing, FieldView "" Nothing "" mempty Nothing False)
+ else return (FormMissing, FieldView "" Nothing "" mempty Nothing False)
-}
return (set selLens <$> selResult, [whamlet|^{fvWidget selWidget}|])
diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs
index 6861e6e32..1845862c3 100644
--- a/src/Handler/Utils/Widgets.hs
+++ b/src/Handler/Utils/Widgets.hs
@@ -62,7 +62,7 @@ userWidget :: HasUser c => c -> Widget
userWidget x = nameWidget (x ^. _userDisplayName) (x ^._userSurname)
userIdWidget :: UserId -> Widget
-userIdWidget uid = maybeM (msg2widget MsgUserUnknown) userWidget (liftHandler $ runDB $ get uid)
+userIdWidget uid = maybeM (msg2widget MsgUserUnknown) userWidget (liftHandler $ runDBRead $ get uid)
linkUserWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> Entity User -> Widget
linkUserWidget lnk (Entity uid usr) = do
@@ -71,7 +71,7 @@ linkUserWidget lnk (Entity uid usr) = do
-- | like linkUserWidget, but on Id only. Requires DB access, use with caution
linkUserIdWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> UserId -> Widget
-linkUserIdWidget lnk uid = maybeM (msg2widget MsgUserUnknown) (linkUserWidget lnk . Entity uid) (liftHandler $ runDB $ get uid)
+linkUserIdWidget lnk uid = maybeM (msg2widget MsgUserUnknown) (linkUserWidget lnk . Entity uid) (liftHandler $ runDBRead $ get uid)
userEmailWidget :: HasUser c => c -> Widget
userEmailWidget x = nameEmailWidget (x ^. _userDisplayEmail) (x ^. _userDisplayName) (x ^. _userSurname)
@@ -141,15 +141,20 @@ modalAccess wdgtNo wdgtYes writeAccess route = do
else wdgtNo
-- also see Handler.Utils.Table.Cells.companyCell
-companyWidget :: (CompanyShorthand, CompanyName, Bool) -> Widget
-companyWidget (csh, cname, isSupervisor) = simpleLink (toWgt name) curl
+companyWidget :: Bool -> (CompanyShorthand, CompanyName, Bool) -> Widget
+companyWidget isPrimary (csh, cname, isSupervisor)
+ | isPrimary, isSupervisor = simpleLink (toWgt $ name <> iconSupervisor) curl
+ | isPrimary = simpleLink (toWgt name ) curl
+ | isSupervisor = toWgt name <> simpleLink (toWgt iconSupervisor) curl
+ | otherwise = toWgt name
where
curl = FirmUsersR csh
corg = ciOriginal cname
name
- | isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor
+ | isSupervisor = text2markup (corg <> " ")
| otherwise = text2markup corg
+
----------
-- HEAT --
----------
diff --git a/src/Jobs/Handler/SynchroniseAvs.hs b/src/Jobs/Handler/SynchroniseAvs.hs
index 47b9d0c21..2de92b595 100644
--- a/src/Jobs/Handler/SynchroniseAvs.hs
+++ b/src/Jobs/Handler/SynchroniseAvs.hs
@@ -3,9 +3,9 @@
-- SPDX-License-Identifier: AGPL-3.0-or-later
module Jobs.Handler.SynchroniseAvs
- ( dispatchJobSynchroniseAvs
+ ( dispatchJobSynchroniseAvs
-- , dispatchJobSynchroniseAvsId
- -- , dispatchJobSynchroniseAvsUser
+ -- , dispatchJobSynchroniseAvsUser
, dispatchJobSynchroniseAvsQueue
) where
@@ -26,7 +26,7 @@ import Handler.Utils.Avs
-- pause is a date in the past; don't synch again if the last synch was after pause
dispatchJobSynchroniseAvs :: Natural -> Natural -> Natural -> Maybe Day -> JobHandler UniWorX
-dispatchJobSynchroniseAvs numIterations epoch iteration pause
+dispatchJobSynchroniseAvs numIterations epoch iteration pause
= JobHandlerException . runDB $ do
now <- liftIO getCurrentTime
todos <- runConduit $ readUsers .| filterIteration now .| sinkList
@@ -44,13 +44,13 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause
userIteration = toInteger (hash epoch `hashWithSalt` userId) `mod` toInteger numIterations
currentIteration = toInteger iteration `mod` toInteger numIterations
$logDebugS "SynchronisAvs" [st|User ##{tshow (fromSqlKey userId)}: AVS sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|]
- guard $ userIteration == currentIteration
- return $ AvsSync userId now pause
+ guard $ userIteration == currentIteration
+ return $ AvsSync userId now pause
-- dispatchJobSynchroniseAvsId :: AvsPersonId -> Maybe Day -> JobHandler UniWorX
--- dispatchJobSynchroniseAvsId apid pause = JobHandlerException $
--- maybeM insertUnknown processKnown $ runDB $ getBy (UniqueUserAvsId apid)
--- where
+-- dispatchJobSynchroniseAvsId apid pause = JobHandlerException $
+-- maybeM insertUnknown processKnown $ runDB $ getBy (UniqueUserAvsId apid)
+-- where
-- processKnown Entity{entityVal=UserAvs{userAvsUser=uid}} = workJobSychronizeAvs uid pause
-- insertUnknown = void $ maybeCatchAll $ Just <$> upsertAvsUserById apid
@@ -66,7 +66,7 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause
-- -- , avsSyncPause = pause
-- -- }
-- -- [ \oldSync -> (AvsSyncPause E.=. E.greatest (E.val pause) (oldSync E.^. AvsSyncPause)) oldSync ] -- causes Esqueleto to call undefined at Database.Esqueleto.Internal.Internal.renderUpdates:1308
--- runDB $ maybeM
+-- runDB $ maybeM
-- (insert_ AvsSync{avsSyncUser=uid, avsSyncCreationTime=now, avsSyncPause=pause})
-- (\Entity{entityKey=asid, entityVal=AvsSync{avsSyncPause=oldPause}} ->
-- update asid [AvsSyncPause =. max pause oldPause, AvsSyncCreationTime =. now])
@@ -78,10 +78,10 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause
-- dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
-- (unlinked,linked) <- runDB $ do
-- jobs <- E.select (do
--- (avsSync :& usrAvs) <- E.from $ E.table @AvsSync
+-- (avsSync :& usrAvs) <- E.from $ E.table @AvsSync
-- `E.leftJoin` E.table @UserAvs
-- `E.on` (\(avsSync :& usrAvs) -> avsSync E.^. AvsSyncUser E.=?. usrAvs E.?. UserAvsUser)
--- let pause = avsSync E.^. AvsSyncPause
+-- let pause = avsSync E.^. AvsSyncPause
-- lastSync = usrAvs E.?. UserAvsLastSynch
-- E.where_ $ E.isNothing pause
-- E.||. E.isNothing lastSync
@@ -91,22 +91,22 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause
-- let (syncIds, unlinked, linked) = foldl' discernJob mempty jobs
-- E.deleteWhere [AvsSyncId <-. syncIds]
-- return (unlinked, linked)
-
+
-- void $ updateAvsUserByIds linked
-- void $ linktoAvsUserByUIDs unlinked
-- -- we do not reschedule failed synchs here in order to avoid a loop
--- where
+-- where
-- discernJob (accSync, accUid, accApi) (E.Value k, _, E.Value (Just api)) = (k:accSync, accUid, Set.insert api accApi)
-- discernJob (accSync, accUid, accApi) (E.Value k, E.Value uid, E.Value Nothing ) = (k:accSync, Set.insert uid accUid, accApi)
-
+
dispatchJobSynchroniseAvsQueue :: JobHandler UniWorX
-dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
- jobs <- runDB $ do
+dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
+ jobs <- runDBRead $ do
E.select (do
- (avsSync :& usrAvs) <- E.from $ E.table @AvsSync
+ (avsSync :& usrAvs) <- E.from $ E.table @AvsSync
`E.leftJoin` E.table @UserAvs
`E.on` (\(avsSync :& usrAvs) -> avsSync E.^. AvsSyncUser E.=?. usrAvs E.?. UserAvsUser)
- let pause = avsSync E.^. AvsSyncPause
+ let pause = avsSync E.^. AvsSyncPause
lastSync = usrAvs E.?. UserAvsLastSynch
proceed = E.isNothing pause
E.||. E.isNothing lastSync
@@ -124,7 +124,7 @@ dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
runDB $ deleteWhere [AvsSyncUser <-. (E.unValue . fst3 <$> jobs)]
$logInfoS "SynchronisAvs" [st|AVS synch performed for #{length linked} AVS linked users and #{length unlinked} unlinked users|]
-- we do not reschedule failed synchs here in order to avoid a loop
- where
+ where
discernJob accs ( _ , E.Value (Just api), E.Value True ) = accs & over _2 (Set.insert api)
discernJob accs (E.Value uid, E.Value Nothing , E.Value True ) = accs & over _1 (Set.insert uid)
discernJob accs ( _ , _ , E.Value False ) = accs
diff --git a/src/Utils.hs b/src/Utils.hs
index ef274611a..aa3bb03a0 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -412,6 +412,10 @@ citext2widget t = [whamlet|#{CI.original t}|]
str2widget :: String -> WidgetFor site ()
str2widget s = [whamlet|#{s}|]
+-- | hamlet does not like quotes
+spaceWidget :: WidgetFor site ()
+spaceWidget = str2widget " "
+
int2widget :: Int64 -> WidgetFor site ()
int2widget i = [whamlet|#{tshow i}|]
diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs
index a45611062..6ba582a00 100644
--- a/src/Utils/Icon.hs
+++ b/src/Utils/Icon.hs
@@ -106,19 +106,21 @@ data Icon
| IconBlocked
| IconCertificate
| IconPrintCenter
- | IconLetter
+ | IconLetter -- only to be used for postal matters
| IconAt
| IconSupervisor
| IconSupervisorForeign
+ | IconSuperior -- supervisor and head of department
-- IconWaitingForUser
| IconExpired
| IconLocked
| IconUnlocked
- | IconResetTries -- also see IconReset
+ | IconResetTries -- also see IconReset
| IconCompany
| IconEdit
| IconUserEdit
- -- IconMagic -- indicates automatic updates
+ -- IconMagic -- indicates automatic updates
+ | IconReroute -- for notification rerouting
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
deriving anyclass (Universe, Finite, NFData)
@@ -158,7 +160,7 @@ iconText = \case
IconSFTHint -> "life-ring" -- for SheetFileType only
IconSFTSolution -> "exclamation-circle" -- for SheetFileType only
IconSFTMarking -> "check-circle" -- for SheetFileType only
- IconEmail -> "envelope" -- envelope is no longer unamibuous, use IconAt or IconLetter if email and postal need to be distinguished
+ IconEmail -> "envelope" -- envelope is no longer unambiguous, use IconAt or IconLetter if email and postal need to be distinguished
IconRegisterTemplate -> "file-alt"
IconNoCorrectors -> "user-slash"
IconRemoveUser -> "user-slash"
@@ -207,6 +209,7 @@ iconText = \case
IconAt -> "at" -- alternative for IconEmail to distinguish from IconLetter
IconSupervisor -> "head-side" -- must be notably different to user
IconSupervisorForeign -> "alien"
+ IconSuperior -> "user-tie" -- user-crown
-- IconWaitingForUser -> "user-cog" -- Waiting on a user to do something
IconExpired -> "hourglass-end"
IconLocked -> "lock"
@@ -216,7 +219,7 @@ iconText = \case
IconEdit -> "edit"
IconUserEdit -> "user-edit"
-- IconMagic -> "wand-magic"
-
+ IconReroute -> "directions"
nullaryPathPiece ''Icon $ camelToPathPiece' 1
deriveLift ''Icon
@@ -316,6 +319,8 @@ iconExamRegister :: Bool -> Markup
iconExamRegister True = icon IconExamRegisterTrue
iconExamRegister False = icon IconExamRegisterFalse
+-- | indicator whether notifications are sent by letter or email
+-- use iconReroute if type of rerouting is unclear
iconLetterOrEmail :: Bool -> Markup
iconLetterOrEmail True = icon IconLetter
iconLetterOrEmail False = icon IconAt
diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet
index b12eab167..bbd5f6202 100644
--- a/templates/profileData.hamlet
+++ b/templates/profileData.hamlet
@@ -11,15 +11,22 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
-
#{userIdent}
-
- _{MsgAuthModeSet}
-
-
+ _{MsgAuthModeSet}
+
-
_{userAuthentication}
$maybe avs <- avsId
-
-
- _{MsgAvsPersonNo}
- ^{messageTooltip tooltipAvsPersNo}
-
-
- #{view _userAvsNoPerson avs}
+ $with avsNoPers <- tshow (view _userAvsNoPerson avs)
+
-
+ _{MsgAvsPersonNo}
+ ^{messageTooltip tooltipAvsPersNo}
+ $maybe matnr <- userMatrikelnummer
+ $if matnr /= avsNoPers
+ ^{messageTooltip tooltipAvsPersNoDiffers}
+
-
+ ^{modalAccess (text2widget avsNoPers) (text2widget avsNoPers) False (AdminAvsUserR cID)}
+ $maybe matnr <- userMatrikelnummer
+ $if matnr /= avsNoPers
+ / #{matnr}
$maybe avsError <- view _userAvsLastSynchError avs
-
_{MsgLastAvsSynchError}
@@ -29,15 +36,18 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
_{MsgLastAvsSynchronisation}
-
^{formatTimeW SelFormatDateTime (view _userAvsLastSynch avs)}
+ $nothing
+ $maybe matnr <- userMatrikelnummer
+
-
+ _{MsgTableMatrikelNr}
+ ^{messageTooltip tooltipAvsPersNo}
+ ^{usrAutomatic CU_UA_UserMatrikelnummer}
+
-
+ ^{modalAccess (text2widget matnr) (text2widget matnr) False (AdminAvsUserR cID)}
-
_{MsgNameSet} ^{usrAutomatic CU_UA_UserDisplayName}
-
^{nameWidget userDisplayName userSurname}
- $maybe matnr <- userMatrikelnummer
-
-
- _{MsgTableMatrikelNr} ^{usrAutomatic CU_UA_UserMatrikelnummer}
-
-
- ^{modalAccess (text2widget matnr) (text2widget matnr) False (AdminAvsUserR cID)}
$maybe sex <- userSex
-
_{MsgTableSex}
@@ -58,7 +68,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
-
_{MsgAdminUserPostAddress} #
^{updateAutomatic postalAutomatic}
-
-
+
-
#{addr}
$if (not postalAutomatic)
$maybe postUpdate <- userPostLastUpdate
@@ -84,6 +94,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
#{userEmail}
-
_{MsgAdminUserPinPassword}
+ ^{usrAutomatic CU_UA_UserPinPassword}
-
$maybe pass <- userPinPassword
#{pass}
@@ -108,24 +119,12 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
-
_{MsgCompanyPersonalNumber} ^{usrAutomatic CU_UA_UserCompanyPersonalNumber}
-
- #{companyPersonalNumber}
+ #{companyPersonalNumber}
$maybe compWgt <- companies
-
_{MsgCompany}
-
^{compWgt}
- $if numSupervisors > 0
-
- _{MsgProfileSupervisor}
- $if numSupervisors > 3
- \ #{numSupervisors}
-
-
- ^{mconcat supervisors}
- $if numSupervisees > 0
-
- _{MsgProfileSupervisee}
- $if length supervisees > 3
- \ #{numSupervisees}
-
-
- ^{mconcat supervisees}
$if showAdminInfo
-
_{MsgUserCreated}
@@ -147,7 +146,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
_{MsgNeverSet}
$maybe pKey <- userLdapPrimaryKey
-
- _{MsgProfileLdapPrimaryKey}
+ _{MsgProfileLdapPrimaryKey}
-
#{pKey}
-
@@ -197,67 +196,25 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
$nothing
^{formatTimeW SelFormatDateTime studyFeaturesLastObserved}
-
- $if hasRowsOwnedCourses
- |