chore(db): use runDBRead more often
This commit is contained in:
parent
7ca3237ad0
commit
99f03078a1
@ -159,7 +159,7 @@ postAdminAvsR = do
|
||||
$nothing
|
||||
AVS nicht konfiguriert!
|
||||
|]
|
||||
|
||||
|
||||
((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing
|
||||
|
||||
let procFormPerson :: AvsQueryPerson -> Handler (Maybe (Maybe Widget, Maybe AvsPersonId))
|
||||
@ -168,7 +168,7 @@ postAdminAvsR = do
|
||||
try (avsQuery fr) >>= \case
|
||||
Left err -> return $ Just (Just $ exceptionWgt err, Nothing)
|
||||
Right (AvsResponsePerson pns) -> do
|
||||
let mapid = case Set.toList pns of
|
||||
let mapid = case Set.toList pns of
|
||||
[AvsDataPerson{avsPersonPersonID=apid}] -> Just apid
|
||||
_ -> Nothing
|
||||
wgt = [whamlet|
|
||||
@ -178,12 +178,12 @@ postAdminAvsR = do
|
||||
|] -- <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
|
||||
return $ Just (toMaybe (notNull pns) wgt, mapid)
|
||||
(mbPerson,mapid) <- fromMaybe (Nothing,Nothing) <$> formResultMaybe presult procFormPerson
|
||||
|
||||
|
||||
((sresult', swidget), senctype) <- runFormPost $ makeAvsStatusForm mapid
|
||||
let sresult = sresult' <|> maybe FormMissing (FormSuccess . AvsQueryStatus . Set.singleton) mapid -- use unique AvsId from PersonSearch for convenience, if form was empty
|
||||
procFormStatus fr = do
|
||||
addMessage Info $ text2Html $ "Status Query: " <> tshow (toJSON fr)
|
||||
tryShow $ do
|
||||
tryShow $ do
|
||||
AvsResponseStatus pns <- avsQuery fr
|
||||
return [whamlet|
|
||||
<ul>
|
||||
@ -203,9 +203,9 @@ postAdminAvsR = do
|
||||
$forall AvsDataContact{..} <- pns
|
||||
<li>
|
||||
<ul>
|
||||
<li>AvsId: #{tshow avsContactPersonID}
|
||||
<li>AvsId: #{tshow avsContactPersonID}
|
||||
<li>^{jsonWidget avsContactPersonInfo}
|
||||
<li>^{jsonWidget avsContactFirmInfo}
|
||||
<li>^{jsonWidget avsContactFirmInfo}
|
||||
|] -- <li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactPersonInfo))}
|
||||
mbContact <- formResultMaybe cresult (Just <<$>> procFormContact)
|
||||
|
||||
@ -560,15 +560,15 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
|
||||
, sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCellAdmin a
|
||||
-- , colUserCompany
|
||||
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
|
||||
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
||||
companies' <- liftHandler . runDBRead . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
||||
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
||||
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
|
||||
E.orderBy [E.asc (comp E.^. CompanyName)]
|
||||
return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
|
||||
let icnSuper = toWidget $ text2markup " " <> icon IconSupervisor
|
||||
companies =
|
||||
companies =
|
||||
(\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies'
|
||||
|
||||
|
||||
pure $ intercalate (text2widget "; ") companies
|
||||
, sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q
|
||||
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d
|
||||
@ -639,8 +639,8 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
|
||||
mkOption :: E.Value Text -> Option Text
|
||||
mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
|
||||
suggestionsBlock :: HandlerFor UniWorX (OptionList Text)
|
||||
suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons E.not_)
|
||||
suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id)
|
||||
suggestionsBlock = mkOptionList . fmap mkOption <$> runDBRead (getBlockReasons E.not_)
|
||||
suggestionsUnblock = mkOptionList . fmap mkOption <$> runDBRead (getBlockReasons id)
|
||||
|
||||
acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData)
|
||||
acts = mconcat
|
||||
@ -697,22 +697,22 @@ instance Button UniWorX UserAvsAction where
|
||||
|
||||
|
||||
getAdminAvsUserR, postAdminAvsUserR :: CryptoUUIDUser -> Handler Html
|
||||
getAdminAvsUserR = postAdminAvsUserR
|
||||
postAdminAvsUserR uuid = do
|
||||
getAdminAvsUserR = postAdminAvsUserR
|
||||
postAdminAvsUserR uuid = do
|
||||
isModal <- hasCustomHeader HeaderIsModal
|
||||
|
||||
|
||||
uid <- decrypt uuid
|
||||
Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
|
||||
Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
|
||||
-- let fltrById prj = over _Wrapped (Set.filter ((== userAvsPersonId) . prj)) -- not sufficiently polymorphic
|
||||
let fltrIdContact = over _Wrapped (Set.filter ((== userAvsPersonId) . avsContactPersonID))
|
||||
-- fltrIdStatus = over _Wrapped (Set.filter ((== userAvsPersonId) . avsStatusPersonID))
|
||||
-- fltrIdStatus = over _Wrapped (Set.filter ((== userAvsPersonId) . avsStatusPersonID))
|
||||
mbContact <- try $ fmap fltrIdContact $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
|
||||
-- mbStatus <- try $ fmap fltrIdStatus $ avsQuery $ AvsQueryStatus $ Set.singleton userAvsPersonId
|
||||
mbStatus <- try $ queryAvsFullStatus userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed -- NOTE: currently needed to provide card firms that are missing in AVS status query responses
|
||||
let compsUsed :: [CompanyName] = stripCI <$> mbStatus ^.. _Right . _Wrapped . folded . _avsStatusPersonCardStatus . folded . _avsDataFirm . _Just
|
||||
compDict <- if 1 >= length compsUsed
|
||||
compDict <- if 1 >= length compsUsed
|
||||
then return mempty -- switch company only sensible if there is more than one company to choose
|
||||
else do
|
||||
else do
|
||||
let switchCompFormHandler :: [(CompanyName,CompanyId)] -> Maybe CompanyId -> Handler Widget
|
||||
switchCompFormHandler availComps _ | 1 >= length availComps = return mempty -- don't offer a form if there is only one company
|
||||
switchCompFormHandler availComps mbPrime = do
|
||||
@ -722,20 +722,20 @@ postAdminAvsUserR uuid = do
|
||||
<*> areq (selectFieldList [(ciOriginal cn, cid) | (cn, cid) <- availComps]) (fslI MsgUserAvsSwitchCompanyField) mbPrime
|
||||
<* aopt (buttonField UserAvsSwitchCompany) "" Nothing
|
||||
switchCompValidate :: FormValidator (CryptoUUIDUser,CompanyId) Handler ()
|
||||
switchCompValidate = do
|
||||
switchCompValidate = do
|
||||
(uuid_rcvd,_) <- State.get
|
||||
guardValidation MsgWrongButtonValue $ uuid_rcvd == uuid
|
||||
guardValidation MsgWrongButtonValue $ uuid_rcvd == uuid
|
||||
((spRes, spWgt), spEnc) <- runFormPost . validateForm switchCompValidate . identifyForm ("switch-primary-company"::Text) $ renderAForm FormStandard switchCompForm
|
||||
formResultModal spRes (AdminAvsUserR uuid) (\(_,cid) -> do
|
||||
lift $ $logInfoS "AVS" ("Switch company option result " <> tshow spRes)
|
||||
problems <- liftHandler . runDB $ do
|
||||
problems <- liftHandler . runDB $ do
|
||||
(usrUp, problems) <- switchAvsUserCompany True False uid cid
|
||||
update uid usrUp
|
||||
forM problems $ \p -> reportAdminProblem p >> msgAdminProblem p
|
||||
forM_ problems (\p -> do
|
||||
forM_ problems (\p -> do
|
||||
-- lift $ $logErrorS "AVS" $ "Switch company problem: " <> tshow p -- no instance Show for SomeMessages
|
||||
tell . pure =<< messageI Warning p
|
||||
)
|
||||
)
|
||||
let ok = if null problems then Success else Error
|
||||
tell . pure =<< messageI ok (MsgUserAvsCompanySwitched $ unCompanyKey cid)
|
||||
)
|
||||
@ -758,10 +758,10 @@ postAdminAvsUserR uuid = do
|
||||
setTitle $ toHtml $ show userAvsNoPerson
|
||||
let contactWgt = case mbContact of
|
||||
Left err -> exceptionWgt err
|
||||
Right (AvsResponseContact adcs) ->
|
||||
Right (AvsResponseContact adcs) ->
|
||||
if null adcs
|
||||
then [whamlet|_{MsgAvsPersonSearchEmpty}|]
|
||||
else
|
||||
else
|
||||
let cs = mkContactWgt warnBolt userAvsNoPerson <$> toList adcs
|
||||
in mconcat cs
|
||||
cardsWgt = case mbStatus of
|
||||
@ -779,14 +779,14 @@ postAdminAvsUserR uuid = do
|
||||
^{cardsWgt}
|
||||
<p>
|
||||
_{MsgAvsCurrentData}
|
||||
|]
|
||||
where
|
||||
|]
|
||||
where
|
||||
mkContactWgt :: Widget -> Int -> AvsDataContact -> Widget
|
||||
mkContactWgt warnBolt reqAvsNo AvsDataContact
|
||||
{ -- avsContactPersonID = _api
|
||||
avsContactPersonInfo = AvsPersonInfo{..}
|
||||
, avsContactFirmInfo = AvsFirmInfo{ avsFirmFirm = firmName }
|
||||
} =
|
||||
} =
|
||||
let avsNoOk = readMay avsInfoPersonNo /= Just reqAvsNo in
|
||||
[whamlet|
|
||||
<section .profile>
|
||||
@ -794,8 +794,8 @@ postAdminAvsUserR uuid = do
|
||||
$if avsNoOk
|
||||
<dt .deflist__dt>
|
||||
_{MsgAvsPersonNo}
|
||||
<dd .deflist__dd>
|
||||
#{avsInfoPersonNo}
|
||||
<dd .deflist__dd>
|
||||
#{avsInfoPersonNo}
|
||||
^{warnBolt}
|
||||
_{MsgAvsPersonNoMismatch}
|
||||
<dt .deflist__dt>
|
||||
@ -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
|
||||
<th .table__th>_{MsgTableAvsCardIssueDate}
|
||||
$if hasValidToDate
|
||||
<th .table__th>_{MsgTableAvsCardValidTo}
|
||||
<th .table__th>_{MsgTableAvsCardValidTo}
|
||||
$if hasCompany
|
||||
<th .table__th>_{MsgTableCompany}
|
||||
<th .table__th>_{MsgAvsPrimaryCompany}
|
||||
@ -865,7 +865,7 @@ postAdminAvsUserR uuid = do
|
||||
<td .table__td>
|
||||
$maybe d <- avsDataIssueDate
|
||||
^{formatTimeW SelFormatDate d}
|
||||
$if hasValidToDate
|
||||
$if hasValidToDate
|
||||
<td .table__td>
|
||||
$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}|]
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
@ -1374,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)
|
||||
|
||||
@ -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}
|
||||
<p>
|
||||
<a href=@{lprLink}>
|
||||
_{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")
|
||||
|
||||
@ -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})
|
||||
|
||||
@ -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
|
||||
|
||||
@ -121,7 +121,7 @@ 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)]
|
||||
@ -135,7 +135,7 @@ postUsersR = do
|
||||
, 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
|
||||
<li>#{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 = []
|
||||
|
||||
@ -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
|
||||
@ -490,7 +490,7 @@ createAvsUserById muid api = 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
|
||||
oldUsr <- runDBRead $ do
|
||||
mbUid <- if isJust muid
|
||||
then return muid
|
||||
else firstJustM $ catMaybes
|
||||
@ -736,15 +736,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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user