fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(db): use runDBRead more often

Browse Source
This commit is contained in:
Steffen Jost 2024-07-02 17:37:34 +02:00
parent 7ca3237ad0
commit 99f03078a1
11 changed files with 177 additions and 176 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
src/Handler/Admin/Avs.hs
View File

@ -159,7 +159,7 @@ postAdminAvsR = do
$nothing $nothing
AVS nicht konfiguriert! AVS nicht konfiguriert!
|] |]
((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing ((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing
let procFormPerson :: AvsQueryPerson -> Handler (Maybe (Maybe Widget, Maybe AvsPersonId)) let procFormPerson :: AvsQueryPerson -> Handler (Maybe (Maybe Widget, Maybe AvsPersonId))
@ -168,7 +168,7 @@ postAdminAvsR = do
try (avsQuery fr) >>= \case try (avsQuery fr) >>= \case
Left err -> return $ Just (Just $ exceptionWgt err, Nothing) Left err -> return $ Just (Just $ exceptionWgt err, Nothing)
Right (AvsResponsePerson pns) -> do Right (AvsResponsePerson pns) -> do
let mapid = case Set.toList pns of let mapid = case Set.toList pns of
[AvsDataPerson{avsPersonPersonID=apid}] -> Just apid [AvsDataPerson{avsPersonPersonID=apid}] -> Just apid
_ -> Nothing _ -> Nothing
wgt = [whamlet| wgt = [whamlet|
@ -178,12 +178,12 @@ postAdminAvsR = do
|] -- <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))} |] -- <li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
return $ Just (toMaybe (notNull pns) wgt, mapid) return $ Just (toMaybe (notNull pns) wgt, mapid)
(mbPerson,mapid) <- fromMaybe (Nothing,Nothing) <$> formResultMaybe presult procFormPerson (mbPerson,mapid) <- fromMaybe (Nothing,Nothing) <$> formResultMaybe presult procFormPerson
((sresult', swidget), senctype) <- runFormPost $ makeAvsStatusForm mapid ((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 let sresult = sresult' <|> maybe FormMissing (FormSuccess . AvsQueryStatus . Set.singleton) mapid -- use unique AvsId from PersonSearch for convenience, if form was empty
procFormStatus fr = do procFormStatus fr = do
addMessage Info $ text2Html $ "Status Query: " <> tshow (toJSON fr) addMessage Info $ text2Html $ "Status Query: " <> tshow (toJSON fr)
tryShow $ do tryShow $ do
AvsResponseStatus pns <- avsQuery fr AvsResponseStatus pns <- avsQuery fr
return [whamlet| return [whamlet|
<ul> <ul>
@ -203,9 +203,9 @@ postAdminAvsR = do
$forall AvsDataContact{..} <- pns $forall AvsDataContact{..} <- pns
<li> <li>
<ul> <ul>
<li>AvsId: #{tshow avsContactPersonID} <li>AvsId: #{tshow avsContactPersonID}
<li>^{jsonWidget avsContactPersonInfo} <li>^{jsonWidget avsContactPersonInfo}
<li>^{jsonWidget avsContactFirmInfo} <li>^{jsonWidget avsContactFirmInfo}
|] -- <li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactPersonInfo))} |] -- <li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactPersonInfo))}
mbContact <- formResultMaybe cresult (Just <<$>> procFormContact) 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 , sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCellAdmin a
-- , colUserCompany -- , 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" , 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.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
E.orderBy [E.asc (comp E.^. CompanyName)] E.orderBy [E.asc (comp E.^. CompanyName)]
return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
let icnSuper = toWidget $ text2markup " " <> icon IconSupervisor 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' (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies'
pure $ intercalate (text2widget "; ") companies pure $ intercalate (text2widget "; ") companies
, sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q , 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 , 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.Value Text -> Option Text
mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t } mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
suggestionsBlock :: HandlerFor UniWorX (OptionList Text) suggestionsBlock :: HandlerFor UniWorX (OptionList Text)
suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons E.not_) suggestionsBlock = mkOptionList . fmap mkOption <$> runDBRead (getBlockReasons E.not_)
suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id) suggestionsUnblock = mkOptionList . fmap mkOption <$> runDBRead (getBlockReasons id)
acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData) acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData)
acts = mconcat acts = mconcat
@ -697,22 +697,22 @@ instance Button UniWorX UserAvsAction where
getAdminAvsUserR, postAdminAvsUserR :: CryptoUUIDUser -> Handler Html getAdminAvsUserR, postAdminAvsUserR :: CryptoUUIDUser -> Handler Html
getAdminAvsUserR = postAdminAvsUserR getAdminAvsUserR = postAdminAvsUserR
postAdminAvsUserR uuid = do postAdminAvsUserR uuid = do
isModal <- hasCustomHeader HeaderIsModal isModal <- hasCustomHeader HeaderIsModal
uid <- decrypt uuid 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 fltrById prj = over _Wrapped (Set.filter ((== userAvsPersonId) . prj)) -- not sufficiently polymorphic
let fltrIdContact = over _Wrapped (Set.filter ((== userAvsPersonId) . avsContactPersonID)) 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 mbContact <- try $ fmap fltrIdContact $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
-- mbStatus <- try $ fmap fltrIdStatus $ avsQuery $ AvsQueryStatus $ Set.singleton 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 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 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 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 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 _ | 1 >= length availComps = return mempty -- don't offer a form if there is only one company
switchCompFormHandler availComps mbPrime = do switchCompFormHandler availComps mbPrime = do
@ -722,20 +722,20 @@ postAdminAvsUserR uuid = do
<*> areq (selectFieldList [(ciOriginal cn, cid) | (cn, cid) <- availComps]) (fslI MsgUserAvsSwitchCompanyField) mbPrime <*> areq (selectFieldList [(ciOriginal cn, cid) | (cn, cid) <- availComps]) (fslI MsgUserAvsSwitchCompanyField) mbPrime
<* aopt (buttonField UserAvsSwitchCompany) "" Nothing <* aopt (buttonField UserAvsSwitchCompany) "" Nothing
switchCompValidate :: FormValidator (CryptoUUIDUser,CompanyId) Handler () switchCompValidate :: FormValidator (CryptoUUIDUser,CompanyId) Handler ()
switchCompValidate = do switchCompValidate = do
(uuid_rcvd,_) <- State.get (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 ((spRes, spWgt), spEnc) <- runFormPost . validateForm switchCompValidate . identifyForm ("switch-primary-company"::Text) $ renderAForm FormStandard switchCompForm
formResultModal spRes (AdminAvsUserR uuid) (\(_,cid) -> do formResultModal spRes (AdminAvsUserR uuid) (\(_,cid) -> do
lift $ $logInfoS "AVS" ("Switch company option result " <> tshow spRes) lift $ $logInfoS "AVS" ("Switch company option result " <> tshow spRes)
problems <- liftHandler . runDB $ do problems <- liftHandler . runDB $ do
(usrUp, problems) <- switchAvsUserCompany True False uid cid (usrUp, problems) <- switchAvsUserCompany True False uid cid
update uid usrUp update uid usrUp
forM problems $ \p -> reportAdminProblem p >> msgAdminProblem p 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 -- lift $ $logErrorS "AVS" $ "Switch company problem: " <> tshow p -- no instance Show for SomeMessages
tell . pure =<< messageI Warning p tell . pure =<< messageI Warning p
) )
let ok = if null problems then Success else Error let ok = if null problems then Success else Error
tell . pure =<< messageI ok (MsgUserAvsCompanySwitched $ unCompanyKey cid) tell . pure =<< messageI ok (MsgUserAvsCompanySwitched $ unCompanyKey cid)
) )
@ -758,10 +758,10 @@ postAdminAvsUserR uuid = do
setTitle $ toHtml $ show userAvsNoPerson setTitle $ toHtml $ show userAvsNoPerson
let contactWgt = case mbContact of let contactWgt = case mbContact of
Left err -> exceptionWgt err Left err -> exceptionWgt err
Right (AvsResponseContact adcs) -> Right (AvsResponseContact adcs) ->
if null adcs if null adcs
then [whamlet|_{MsgAvsPersonSearchEmpty}|] then [whamlet|_{MsgAvsPersonSearchEmpty}|]
else else
let cs = mkContactWgt warnBolt userAvsNoPerson <$> toList adcs let cs = mkContactWgt warnBolt userAvsNoPerson <$> toList adcs
in mconcat cs in mconcat cs
cardsWgt = case mbStatus of cardsWgt = case mbStatus of
@ -779,14 +779,14 @@ postAdminAvsUserR uuid = do
^{cardsWgt} ^{cardsWgt}
<p> <p>
_{MsgAvsCurrentData} _{MsgAvsCurrentData}
|] |]
where where
mkContactWgt :: Widget -> Int -> AvsDataContact -> Widget mkContactWgt :: Widget -> Int -> AvsDataContact -> Widget
mkContactWgt warnBolt reqAvsNo AvsDataContact mkContactWgt warnBolt reqAvsNo AvsDataContact
{ -- avsContactPersonID = _api { -- avsContactPersonID = _api
avsContactPersonInfo = AvsPersonInfo{..} avsContactPersonInfo = AvsPersonInfo{..}
, avsContactFirmInfo = AvsFirmInfo{ avsFirmFirm = firmName } , avsContactFirmInfo = AvsFirmInfo{ avsFirmFirm = firmName }
} = } =
let avsNoOk = readMay avsInfoPersonNo /= Just reqAvsNo in let avsNoOk = readMay avsInfoPersonNo /= Just reqAvsNo in
[whamlet| [whamlet|
<section .profile> <section .profile>
@ -794,8 +794,8 @@ postAdminAvsUserR uuid = do
$if avsNoOk $if avsNoOk
<dt .deflist__dt> <dt .deflist__dt>
_{MsgAvsPersonNo} _{MsgAvsPersonNo}
<dd .deflist__dd> <dd .deflist__dd>
#{avsInfoPersonNo} #{avsInfoPersonNo}
^{warnBolt} ^{warnBolt}
_{MsgAvsPersonNoMismatch} _{MsgAvsPersonNoMismatch}
<dt .deflist__dt> <dt .deflist__dt>
@ -826,7 +826,7 @@ postAdminAvsUserR uuid = do
-- mkCardsWgt :: (Maybe CompanyName, Map CompanyName Widget, Widget) -> Set AvsDataPersonCard -> Widget -- mkCardsWgt :: (Maybe CompanyName, Map CompanyName Widget, Widget) -> Set AvsDataPersonCard -> Widget
mkCardsWgt :: (Maybe CompanyName, Widget) -> Set AvsDataPersonCard -> Widget mkCardsWgt :: (Maybe CompanyName, Widget) -> Set AvsDataPersonCard -> Widget
mkCardsWgt (mbPrimName, swForm) crds mkCardsWgt (mbPrimName, swForm) crds
| null crds = [whamlet|_{MsgAvsCardsEmpty}|] | null crds = [whamlet|_{MsgAvsCardsEmpty}|]
| otherwise = do | 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 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 $if hasIssueDate
<th .table__th>_{MsgTableAvsCardIssueDate} <th .table__th>_{MsgTableAvsCardIssueDate}
$if hasValidToDate $if hasValidToDate
<th .table__th>_{MsgTableAvsCardValidTo} <th .table__th>_{MsgTableAvsCardValidTo}
$if hasCompany $if hasCompany
<th .table__th>_{MsgTableCompany} <th .table__th>_{MsgTableCompany}
<th .table__th>_{MsgAvsPrimaryCompany} <th .table__th>_{MsgAvsPrimaryCompany}
@ -865,7 +865,7 @@ postAdminAvsUserR uuid = do
<td .table__td> <td .table__td>
$maybe d <- avsDataIssueDate $maybe d <- avsDataIssueDate
^{formatTimeW SelFormatDate d} ^{formatTimeW SelFormatDate d}
$if hasValidToDate $if hasValidToDate
<td .table__td> <td .table__td>
$maybe d <- avsDataValidTo $maybe d <- avsDataValidTo
^{formatTimeW SelFormatDate d} ^{formatTimeW SelFormatDate d}
@ -903,13 +903,13 @@ getProblemAvsErrorR = do
E.where_ $ E.isJust $ usravs E.^. UserAvsLastSynchError 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 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.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.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User)
qerryUser = $(E.sqlIJproj 2 2) qerryUser = $(E.sqlIJproj 2 2)
reserrUsrAvs :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity UserAvs) reserrUsrAvs :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity UserAvs)
reserrUsrAvs = _dbrOutput . _1 reserrUsrAvs = _dbrOutput . _1
-- reserrUser :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity User) -- reserrUser :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity User)
-- reserrUser = _dbrOutput . _2 -- reserrUser = _dbrOutput . _2
dbtRowKey = qerryUsrAvs >>> (E.^. UserAvsId) dbtRowKey = qerryUsrAvs >>> (E.^. UserAvsId)
dbtProj = dbtProjId dbtProj = dbtProjId
dbtColonnade = dbColonnade $ mconcat dbtColonnade = dbColonnade $ mconcat
@ -949,4 +949,3 @@ getProblemAvsErrorR = do
siteLayoutMsg MsgMenuAvsSynchError $ do siteLayoutMsg MsgMenuAvsSynchError $ do
setTitleI MsgMenuAvsSynchError setTitleI MsgMenuAvsSynchError
[whamlet|^{avsSyncErrTbl}|] [whamlet|^{avsSyncErrTbl}|]

4
src/Handler/Course/Register.hs
View File

@ -68,7 +68,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
| otherwise | otherwise
-> return $ FormSuccess () -> 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.where_ $ course E.^. CourseId E.==. E.val cid
E.&&. ( isSchoolAdminLike muid ata (course E.^. CourseSchool) E.&&. ( isSchoolAdminLike muid ata (course E.^. CourseSchool)
E.||. mayEditCourse muid ata course E.||. mayEditCourse muid ata course
@ -92,7 +92,7 @@ courseMayReRegister :: Entity Course -> DB Bool
courseMayReRegister (Entity cid Course{..}) = do courseMayReRegister (Entity cid Course{..}) = do
registrations <- count [ CourseParticipantState ==. CourseParticipantActive, CourseParticipantCourse ==. cid ] registrations <- count [ CourseParticipantState ==. CourseParticipantActive, CourseParticipantCourse ==. cid ]
let capacity = maybe True (>= registrations) courseCapacity let capacity = maybe True (>= registrations) courseCapacity
wouldHaveWriteAccessTo [(AuthCapacity, capacity), (AuthCourseRegistered, False)] $ CourseR courseTerm courseSchool courseShorthand CRegisterR wouldHaveWriteAccessTo [(AuthCapacity, capacity), (AuthCourseRegistered, False)] $ CourseR courseTerm courseSchool courseShorthand CRegisterR

6
src/Handler/Firm.hs
View File

@ -119,7 +119,7 @@ firmActionHandler route isAdmin = flip formResult faHandler
faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected
faHandler (FirmActNotifyData, Set.toList -> fids) = do 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) (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 E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList fids
return $ usr E.^. UserId return $ usr E.^. UserId
@ -1374,14 +1374,14 @@ handleFirmCommR ultDest cs = do
csKeys = CompanyKey <$> cs csKeys = CompanyKey <$> cs
mbUser <- maybeAuthId mbUser <- maybeAuthId
-- get employees of chosen companies -- 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) (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.where_ $ cmp E.^. UserCompanyCompany `E.in_` E.valList csKeys
E.orderBy [E.ascNullsFirst $ cmp E.^. UserCompanyCompany] E.orderBy [E.ascNullsFirst $ cmp E.^. UserCompanyCompany]
return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId) return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId)
) )
-- get supervisors of employees -- 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) (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.where_ $ (E.isTrue (cmp E.?. UserCompanySupervisor) E.&&. cmp E.?. UserCompanyCompany `E.in_` E.justValList csKeys)
E.||. (spr E.^. UserId E.=?. E.val mbUser) E.||. (spr E.^. UserId E.=?. E.val mbUser)

144
src/Handler/LMS.hs
View File

@ -19,7 +19,7 @@ module Handler.LMS
, getLmsFakeR , postLmsFakeR , getLmsFakeR , postLmsFakeR
, getLmsUserR , getLmsUserR
, getLmsUserSchoolR , getLmsUserSchoolR
, getLmsUserAllR , getLmsUserAllR
) )
where where
@ -81,11 +81,11 @@ postLmsAllR = do
mbBtnForm <- if not isAdmin then return Nothing else do mbBtnForm <- if not isAdmin then return Nothing else do
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonManualLms) ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonManualLms)
case btnResult of case btnResult of
(FormSuccess BtnLmsEnqueue) -> (FormSuccess BtnLmsEnqueue) ->
queueJob' JobLmsQualificationsEnqueue queueJob' JobLmsQualificationsEnqueue
>> addMessage Info "Einreihung ablaufender Qualifikationen zum LMS wird nun im Hintergund durchgeführt." >> addMessage Info "Einreihung ablaufender Qualifikationen zum LMS wird nun im Hintergund durchgeführt."
(FormSuccess BtnLmsDequeue) -> (FormSuccess BtnLmsDequeue) ->
queueJob' JobLmsQualificationsDequeue queueJob' JobLmsQualificationsDequeue
>> addMessage Info "Benachrichtigung abgelaufener Qualifikationen und Aufräumen beendeter LMS Nutzer wird im Hintergund ausgeführt." >> addMessage Info "Benachrichtigung abgelaufener Qualifikationen und Aufräumen beendeter LMS Nutzer wird im Hintergund ausgeführt."
FormMissing -> return () FormMissing -> return ()
_other -> addMessage Warning "Kein korrekter LMS Knopf erkannt" _other -> addMessage Warning "Kein korrekter LMS Knopf erkannt"
@ -112,20 +112,20 @@ resultAllQualificationActive = _dbrOutput . _2 . _unValue
resultAllQualificationTotal :: Lens' AllQualificationTableData Word64 resultAllQualificationTotal :: Lens' AllQualificationTableData Word64
resultAllQualificationTotal = _dbrOutput . _3 . _unValue resultAllQualificationTotal = _dbrOutput . _3 . _unValue
mkLmsAllTable :: Bool -> Int -> DB (Any, Widget) mkLmsAllTable :: Bool -> Int -> DB (Any, Widget)
mkLmsAllTable isAdmin lmsDeletionDays = do mkLmsAllTable isAdmin lmsDeletionDays = do
svs <- getSupervisees svs <- getSupervisees
let let
resultDBTable = DBTable{..} resultDBTable = DBTable{..}
where where
dbtSQLQuery quali = do 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) 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 luser <- Ex.from $ Ex.table @LmsUser
Ex.where_ $ filterSvs luser Ex.where_ $ filterSvs luser
cactive = Ex.subSelectCount $ do cactive = Ex.subSelectCount $ do
luser <- Ex.from $ Ex.table @LmsUser luser <- Ex.from $ Ex.table @LmsUser
Ex.where_ $ filterSvs luser Ex.&&. E.isNothing (luser E.^. LmsUserStatus) 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 -- 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) foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationAuditDuration)
, sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart)
$ tickmarkCell . view (resultAllQualification . _qualificationElearningStart) $ 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 $ \(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) -> $ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) ->
let icn = IconOK -- change icon here, if desired let icn = IconOK -- change icon here, if desired
in case mbSapId of in case mbSapId of
Nothing -> mempty Nothing -> mempty
Just sapId | isAdmin -> cellTooltipIcon (Just icn) (text2message sapId) mempty Just sapId | isAdmin -> cellTooltipIcon (Just icn) (text2message sapId) mempty
Just _ -> iconCell icn Just _ -> iconCell icn
, adminable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip) , adminable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip)
$ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n
, adminable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal , adminable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal
@ -342,7 +342,7 @@ instance HasEntity LmsTableData QualificationUser where
hasEntity = resultQualUser hasEntity = resultQualUser
instance HasQualificationUser LmsTableData where instance HasQualificationUser LmsTableData where
hasQualificationUser = resultQualUser . _entityVal hasQualificationUser = resultQualUser . _entityVal
data LmsTableAction = LmsActNotify data LmsTableAction = LmsActNotify
| LmsActRenewNotify | LmsActRenewNotify
@ -351,7 +351,7 @@ data LmsTableAction = LmsActNotify
| LmsActRestart | LmsActRestart
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
deriving anyclass (Universe, Finite) deriving anyclass (Universe, Finite)
nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2 nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''LmsTableAction id embedRenderMessage ''UniWorX ''LmsTableAction id
@ -360,12 +360,12 @@ data LmsTableActionData = LmsActNotifyData
| LmsActRenewPinData -- no longer used | LmsActRenewPinData -- no longer used
| LmsActResetData | LmsActResetData
{ lmsActRestartExtend :: Maybe Integer { lmsActRestartExtend :: Maybe Integer
, lmsActRestartUnblock :: Maybe Bool , lmsActRestartUnblock :: Maybe Bool
, lmsActRestartNotify :: Maybe Bool , lmsActRestartNotify :: Maybe Bool
} }
| LmsActRestartData | LmsActRestartData
{ lmsActRestartExtend :: Maybe Integer { lmsActRestartExtend :: Maybe Integer
, lmsActRestartUnblock :: Maybe Bool , lmsActRestartUnblock :: Maybe Bool
, lmsActRestartNotify :: Maybe Bool , lmsActRestartNotify :: Maybe Bool
} }
deriving (Eq, Ord, Read, Show, Generic) 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.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.&&. 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.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! -- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken!
let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do
E.where_ $ E.isJust (pj E.^. PrintJobLmsUser) E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (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! 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! 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) return (qualUser, user, lmsUser, qualBlock, printAcknowledged, validQualification now qualUser)
@ -423,17 +423,17 @@ mkLmsTable :: ( Functor h, ToSortable h
) )
=> Bool => Bool
-> Entity Qualification -> Entity Qualification
-> Map LmsTableAction (AForm Handler LmsTableActionData) -> Map LmsTableAction (AForm Handler LmsTableActionData)
-> (Map CompanyId Company -> cols) -> (Map CompanyId Company -> cols)
-> PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData)) -> PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData))
-> DB (FormResult (LmsTableActionData, Set UserId), Widget) -> DB (FormResult (LmsTableActionData, Set UserId), Widget)
mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
-- lookup all companies -- lookup all companies
cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do
cmps <- selectList [] [] -- [Asc CompanyShorthand] cmps <- selectList [] [] -- [Asc CompanyShorthand]
return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
let let
csvName = T.replace " " "-" $ ciOriginal (quali ^. _qualificationName) csvName = T.replace " " "-" $ ciOriginal (quali ^. _qualificationName)
dbtIdent :: Text dbtIdent :: Text
dbtIdent = "lms" 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 ("notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified)))
, single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> , 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.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId
E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
(E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )) (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ))
, single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> , 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` 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))) (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
testcrit = maybe testname testnumber $ readMay $ ciOriginal criterion testcrit = maybe testname testnumber $ readMay $ ciOriginal criterion
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit
) )
, fltrAVSCardNos queryUser , fltrAVSCardNos queryUser
, single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
| Set.null criteria -> E.true | Set.null criteria -> E.true
@ -506,7 +506,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
) )
] ]
dbtFilterUI mPrev = mconcat dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
, prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
, prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
, fltrAVSCardNosUI mPrev , 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 "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) , prismAForm (singletonFilter "status" . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus)
-- , if isNothing mbRenewal then mempty -- , 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 } dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtCsvEncode = Just DBTCsvEncode dbtCsvEncode = Just DBTCsvEncode
@ -548,14 +548,14 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
<*> view (resultLmsUser . _entityVal . _lmsUserReceived) <*> view (resultLmsUser . _entityVal . _lmsUserReceived)
<*> view (resultLmsUser . _entityVal . _lmsUserNotified) -- TODO: only exports last email date / print job sending date, not print acknowledge <*> view (resultLmsUser . _entityVal . _lmsUserNotified) -- TODO: only exports last email date / print job sending date, not print acknowledge
<*> view (resultLmsUser . _entityVal . _lmsUserEnded) <*> 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 [] -> pure Nothing
somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
dbtCsvDecode = Nothing dbtCsvDecode = Nothing
dbtExtraReps = [] dbtExtraReps = []
dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else
DBParamsForm DBParamsForm
{ dbParamsFormMethod = POST { dbParamsFormMethod = POST
, dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
@ -603,18 +603,18 @@ postLmsR sid qsh = do
[ singletonMap LmsActNotify $ pure LmsActNotifyData [ singletonMap LmsActNotify $ pure LmsActNotifyData
, singletonMap LmsActRenewNotify $ pure LmsActRenewNotifyData , singletonMap LmsActRenewNotify $ pure LmsActRenewNotifyData
-- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData -- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData
, singletonMap LmsActReset $ LmsActResetData , singletonMap LmsActReset $ LmsActResetData
<$> aopt intField (fslI MsgLmsActRestartExtend) Nothing <$> aopt intField (fslI MsgLmsActRestartExtend) Nothing
<*> aopt checkBoxField (fslI MsgLmsActRestartUnblock) Nothing <*> aopt checkBoxField (fslI MsgLmsActRestartUnblock) Nothing
<*> aopt checkBoxField (fslI MsgLmsActNotify) Nothing <*> aopt checkBoxField (fslI MsgLmsActNotify) Nothing
<* aformMessage msgResetInfo <* aformMessage msgResetInfo
, singletonMap LmsActRestart $ LmsActRestartData , singletonMap LmsActRestart $ LmsActRestartData
<$> aopt intField (fslI MsgLmsActRestartExtend) Nothing <$> aopt intField (fslI MsgLmsActRestartExtend) Nothing
<*> aopt checkBoxField (fslI MsgLmsActRestartUnblock) Nothing <*> aopt checkBoxField (fslI MsgLmsActRestartUnblock) Nothing
<*> aopt checkBoxField (fslI MsgLmsActNotify) Nothing <*> aopt checkBoxField (fslI MsgLmsActNotify) Nothing
-- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing -- <*> aopt (commentField MsgQualificationActBlockSupervisor) (fslI MsgMessageWarning) Nothing
<* aformMessage msgRestartWarning <* aformMessage msgRestartWarning
] ]
colChoices cmpMap = mconcat colChoices cmpMap = mconcat
[ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
, colUserNameModalHdrAdmin MsgLmsUser AdminUserR , colUserNameModalHdrAdmin MsgLmsUser AdminUserR
@ -622,11 +622,11 @@ postLmsR sid qsh = do
, sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) -> , sortable (Just "user-company") (i18nCell MsgTableCompany) $ \( view resultCompanyUser -> cmps) ->
let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
| Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps | 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 in intercalate spacerCell cs
, colUserMatriclenr isAdmin , 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 "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 "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> 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 printed : LmsUserNotified == Just _ && PrintJobId == Just _
-- - Letter sent : LmsUserNotified == Just _ && PrintJobId == Just _ && PrintJobAcknowledged == Just _ -- - Letter sent : LmsUserNotified == Just _ && PrintJobId == Just _ && PrintJobAcknowledged == Just _
let notifyDate = row ^. resultLmsUser . _entityVal . _lmsUserNotified let notifyDate = row ^. resultLmsUser . _entityVal . _lmsUserNotified
lmsident = row ^. resultLmsUser . _entityVal . _lmsUserIdent lmsident = row ^. resultLmsUser . _entityVal . _lmsUserIdent
recipient = row ^. hasUser recipient = row ^. hasUser
letterDates = row ^? resultPrintAck letterDates = row ^? resultPrintAck
lastLetterDate = headDef Nothing =<< letterDates 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) 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 $maybe ackdate <- mbackdate
^{formatTimeW SelFormatDateTime ackdate} ^{formatTimeW SelFormatDateTime ackdate}
$nothing $nothing
_{MsgPrintJobUnacknowledged} _{MsgPrintJobUnacknowledged}
<p> <p>
<a href=@{lprLink}> <a href=@{lprLink}>
_{MsgPrintJobs} _{MsgPrintJobs}
@ -700,25 +700,25 @@ postLmsR sid qsh = do
_ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page _ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page
(action, selectedUsers) | isResetRestartAct action -> do (action, selectedUsers) | isResetRestartAct action -> do
let usersList = Set.toList selectedUsers let usersList = Set.toList selectedUsers
numUsers = Set.size selectedUsers numUsers = Set.size selectedUsers
isReset = isResetAct action isReset = isResetAct action
actRestartExtend = action & lmsActRestartExtend actRestartExtend = action & lmsActRestartExtend
actRestartUnblock = action & lmsActRestartUnblock actRestartUnblock = action & lmsActRestartUnblock
actRestartNotify = action & lmsActRestartNotify actRestartNotify = action & lmsActRestartNotify
chgUsers <- runDB $ do chgUsers <- runDB $ do
when (actRestartUnblock == Just True) $ 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) 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 addMessageI Success $ MsgQualificationStatusUnblock qsh oks numUsers
whenIsJust actRestartExtend $ \extDays -> do whenIsJust actRestartExtend $ \extDays -> do
let cutoff = addDays extDays nowaday let cutoff = addDays extDays nowaday
shortUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList shortUsers <- view (_entityVal . _qualificationUserUser) <<$>> selectList
[ QualificationUserQualification ==. qid [ QualificationUserQualification ==. qid
, QualificationUserUser <-. usersList , QualificationUserUser <-. usersList
, QualificationUserValidUntil <. cutoff , QualificationUserValidUntil <. cutoff
] [] ] []
forM_ shortUsers $ upsertQualificationUser qid now cutoff Nothing "E-Learning Reset" forM_ shortUsers $ upsertQualificationUser qid now cutoff Nothing "E-Learning Reset"
fromIntegral <$> (if isReset fromIntegral <$> (if isReset
@ -727,25 +727,25 @@ postLmsR sid qsh = do
else deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList] else deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList]
) )
unless isReset $ unless isReset $
forM_ selectedUsers $ \uid -> forM_ selectedUsers $ \uid ->
queueJob' $ JobLmsEnqueueUser { jQualification = qid, jUser = uid } queueJob' $ JobLmsEnqueueUser { jQualification = qid, jUser = uid }
runDB $ forM_ selectedUsers $ \uid -> runDB $ forM_ selectedUsers $ \uid ->
audit $ TransactionLmsReset audit $ TransactionLmsReset
{ transactionQualification = qid { transactionQualification = qid
, transactionLmsUser = uid , transactionLmsUser = uid
, transactionLmsReset = isReset , transactionLmsReset = isReset
, transactionLmsResetExtend = actRestartExtend , transactionLmsResetExtend = actRestartExtend
, transactionLmsResetUnblock = actRestartUnblock , transactionLmsResetUnblock = actRestartUnblock
, transactionLmsResetNotify = actRestartNotify , transactionLmsResetNotify = actRestartNotify
} }
let mStatus = bool Success Warning $ chgUsers < numUsers let mStatus = bool Success Warning $ chgUsers < numUsers
addMessageI mStatus $ bool MsgLmsActRestartFeedback MsgLmsActResetFeedback isReset chgUsers numUsers addMessageI mStatus $ bool MsgLmsActRestartFeedback MsgLmsActResetFeedback isReset chgUsers numUsers
reloadKeepGetParams $ LmsR sid qsh reloadKeepGetParams $ LmsR sid qsh
(action, selectedUsers) | isRenewPinAct action || isNotifyAct action -> do (action, selectedUsers) | isRenewPinAct action || isNotifyAct action -> do
numExaminees <- runDB $ do numExaminees <- runDB $ do
okUsers <- selectList [ LmsUserQualification ==. qid -- matching qualification okUsers <- selectList [ LmsUserQualification ==. qid -- matching qualification
, LmsUserEnded ==. Nothing -- not yet deleted , LmsUserEnded ==. Nothing -- not yet deleted
@ -761,7 +761,7 @@ postLmsR sid qsh = do
return $ length okUsers return $ length okUsers
let numSelected = length selectedUsers let numSelected = length selectedUsers
diffSelected = numSelected - numExaminees diffSelected = numSelected - numExaminees
mstat = bool Success Warning $ diffSelected /= 0 mstat = bool Success Warning $ diffSelected /= 0
when (isRenewPinAct action) $ addMessageI mstat $ MsgLmsPinRenewal numExaminees when (isRenewPinAct action) $ addMessageI mstat $ MsgLmsPinRenewal numExaminees
when (isNotifyAct action) $ addMessageI mstat $ MsgLmsNotificationSend numExaminees when (isNotifyAct action) $ addMessageI mstat $ MsgLmsNotificationSend numExaminees
when (diffSelected /= 0) $ addMessageI Warning $ MsgLmsActionFailed diffSelected 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 :: Maybe SchoolId -> Maybe QualificationShorthand -> CryptoUUIDUser -> Handler Html
viewLmsUserR msid mqsh uuid = do viewLmsUserR msid mqsh uuid = do
uid <- decrypt uuid uid <- decrypt uuid
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
(user@User{userDisplayName}, quals, qblocks) <- runDB $ do (user@User{userDisplayName}, quals, qblocks) <- runDBRead $ do
usr <- get404 uid usr <- get404 uid
qs <- Ex.select $ do qs <- Ex.select $ do
(qual :& qualUsr :& lmsUsr) <- (qual :& qualUsr :& lmsUsr) <-
Ex.from $ Ex.table @Qualification Ex.from $ Ex.table @Qualification
`Ex.leftJoin` Ex.table @QualificationUser `Ex.leftJoin` Ex.table @QualificationUser
`Ex.on` (\(qual :& qualUsr) -> qualUsr E.?. QualificationUserUser E.?=. Ex.val uid `Ex.on` (\(qual :& qualUsr) -> qualUsr E.?. QualificationUserUser E.?=. Ex.val uid
E.&&. qualUsr E.?. QualificationUserQualification E.?=. qual Ex.^. QualificationId E.&&. qualUsr E.?. QualificationUserQualification E.?=. qual Ex.^. QualificationId
) )
`Ex.leftJoin` Ex.table @LmsUser `Ex.leftJoin` Ex.table @LmsUser
`Ex.on` (\(qual :& _ :& lmsUsr) -> lmsUsr E.?. LmsUserUser E.?=. Ex.val uid `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 $ 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.^. QualificationSchool E.==.) . E.val <$> msid
, (qual E.^. QualificationShorthand E.==.) . E.val <$> mqsh , (qual E.^. QualificationShorthand E.==.) . E.val <$> mqsh
] ]
@ -816,7 +816,7 @@ viewLmsUserR msid mqsh uuid = do
<- foldMapM (\(_, mbqu, _, _) -> case mbqu of <- foldMapM (\(_, mbqu, _, _) -> case mbqu of
Nothing -> pure mempty Nothing -> pure mempty
Just (Entity quid _) -> do Just (Entity quid _) -> do
blocks <- Ex.select $ do blocks <- Ex.select $ do
(qBlock :& qbUsr) <- Ex.from $ Ex.table @QualificationUserBlock (qBlock :& qbUsr) <- Ex.from $ Ex.table @QualificationUserBlock
`Ex.leftJoin` Ex.table @User `Ex.leftJoin` Ex.table @User
`Ex.on` (\(qBlock :& qbUsr) -> qBlock Ex.^. QualificationUserBlockBlocker Ex.==. qbUsr Ex.?. UserId) `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 return $ Map.singleton quid blocks
) qs ) qs
return (usr, qs, Map.filter notNull bs) return (usr, qs, Map.filter notNull bs)
let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|] let heading = [whamlet|_{MsgMenuLmsUser} ^{userWidget user}|]
siteLayout heading $ do siteLayout heading $ do
setTitle $ toHtml userDisplayName setTitle $ toHtml userDisplayName
$(widgetFile "lms-user") $(widgetFile "lms-user")

2
src/Handler/Profile.hs
View File

@ -156,7 +156,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar
where where
schoolsForm' :: WForm Handler (FormResult (Set SchoolId)) schoolsForm' :: WForm Handler (FormResult (Set SchoolId))
schoolsForm' = do schoolsForm' = do
allSchools <- liftHandler . runDB $ selectList [] [Asc SchoolName] allSchools <- liftHandler . runDBRead $ selectList [] [Asc SchoolName]
let let
schoolForm (Entity ssh School{schoolName}) schoolForm (Entity ssh School{schoolName})

48
src/Handler/SAP.hs
View File

@ -27,10 +27,10 @@ import qualified Database.Esqueleto.Utils as E
data SapUserTableCsv = SapUserTableCsv -- for csv export only data SapUserTableCsv = SapUserTableCsv -- for csv export only
{ csvSUTpersonalNummer :: Text { csvSUTpersonalNummer :: Text
, csvSUTqualifikation :: Text , csvSUTqualifikation :: Text
, csvSUTgültigVon :: Day , csvSUTgültigVon :: Day
, csvSUTgültigBis :: Day , csvSUTgültigBis :: Day
-- , csvSUTsupendiertBis :: Maybe Day -- , csvSUTsupendiertBis :: Maybe Day
, csvSUTausprägung :: Text , csvSUTausprägung :: Text
} }
@ -38,7 +38,7 @@ data SapUserTableCsv = SapUserTableCsv -- for csv export only
makeLenses_ ''SapUserTableCsv makeLenses_ ''SapUserTableCsv
sapUserTableCsvHeader :: Csv.Header sapUserTableCsvHeader :: Csv.Header
sapUserTableCsvHeader = Csv.header sapUserTableCsvHeader = Csv.header
[ "PersonalNummer" [ "PersonalNummer"
, "Qualifikation" , "Qualifikation"
, "GültigVon" , "GültigVon"
@ -51,40 +51,40 @@ instance ToNamedRecord SapUserTableCsv where
toNamedRecord SapUserTableCsv{..} = Csv.namedRecord toNamedRecord SapUserTableCsv{..} = Csv.namedRecord
[ "PersonalNummer" Csv..= csvSUTpersonalNummer [ "PersonalNummer" Csv..= csvSUTpersonalNummer
, "Qualifikation" Csv..= csvSUTqualifikation , "Qualifikation" Csv..= csvSUTqualifikation
, "GültigVon" Csv..= csvSUTgültigVon , "GültigVon" Csv..= csvSUTgültigVon
, "GültigBis" Csv..= csvSUTgültigBis , "GültigBis" Csv..= csvSUTgültigBis
-- , "SupendiertBis" Csv..= csvSUTsupendiertBis -- , "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) -- | 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 -- 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 :: [(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 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)) 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 | validFraportPersonalNumber pn -- between 10000 and 99999 also see Handler.Utils.Profile.validFraportPersonalNumber
= let mkSap (dfrom,duntil) = SapUserTableCsv = let mkSap (dfrom,duntil) = SapUserTableCsv
{ csvSUTpersonalNummer = persNo { csvSUTpersonalNummer = persNo
, csvSUTqualifikation = sapId , csvSUTqualifikation = sapId
, csvSUTgültigVon = dfrom , csvSUTgültigVon = dfrom
, csvSUTgültigBis = duntil , csvSUTgültigBis = duntil
, csvSUTausprägung = "J" , csvSUTausprägung = "J"
} }
in fmap mkSap $ compileBlocks firstHeld validUntil $ zipMaybes qubFroms qubUnblocks in fmap mkSap $ compileBlocks firstHeld validUntil $ zipMaybes qubFroms qubUnblocks
procRes _ = [] procRes _ = []
-- | compute a series of valid periods, assume that lists is already sorted by Day -- | 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 :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)]
compileBlocks dStart dEnd = go (dStart, True) compileBlocks dStart dEnd = go (dStart, True)
where where
go :: (Day,Bool) -> [(Day,Bool)] -> [(Day, Day)] go :: (Day,Bool) -> [(Day,Bool)] -> [(Day, Day)]
go (d,s) (p1@(d1,s1):r1@((d2,s2):r2)) go (d,s) (p1@(d1,s1):r1@((d2,s2):r2))
| s1 == s2 && d <= d1 = go (d,s) (p1:r2) -- ignore unnecessary 2nd 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 | d1 == d2 || succ d1 == d2 || s == s1 || d > d1 = go (d,s) r1 -- ignore unnecessary 1st change
go (d,s) ((d1,s1):r1) 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, not s1, d < d1 = (d,d1) : go (d1,s1) r1 -- valid interval found
| s == s1 = go (d ,s ) r1 -- no change | s == s1 = go (d ,s ) r1 -- no change
| otherwise = go (d1,s1) r1 -- ignore invalid interval | 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 -- | Deliver all employess with a successful LDAP synch within the last 3 months
getQualificationSAPDirectR :: Handler TypedContent getQualificationSAPDirectR :: Handler TypedContent
getQualificationSAPDirectR = do getQualificationSAPDirectR = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
fdate <- formatTime' "%Y%m%d_%H-%M" now fdate <- formatTime' "%Y%m%d_%H-%M" now
let ldap_cutoff = addDiffDaysRollOver (fromMonths $ -3) now let ldap_cutoff = addDiffDaysRollOver (fromMonths $ -3) now
qualUsers <- runDB $ E.select $ do qualUsers <- runDBRead $ E.select $ do
(qual :& qualUser :& user :& qualBlock) <- (qual :& qualUser :& user :& qualBlock) <-
E.from $ E.table @Qualification E.from $ E.table @Qualification
`E.innerJoin` E.table @QualificationUser `E.innerJoin` E.table @QualificationUser
`E.on` (\(qual :& qualUser) -> qual E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification) `E.on` (\(qual :& qualUser) -> qual E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification)
`E.innerJoin` E.table @User `E.innerJoin` E.table @User
`E.on` (\(_ :& qualUser :& user) -> qualUser E.^. QualificationUserUser E.==. user E.^. UserId) `E.on` (\(_ :& qualUser :& user) -> qualUser E.^. QualificationUserUser E.==. user E.^. UserId)
`E.leftJoin` E.table @QualificationUserBlock `E.leftJoin` E.table @QualificationUserBlock
`E.on` (\(_ :& qualUser :& _ :& qualBlock) -> `E.on` (\(_ :& qualUser :& _ :& qualBlock) ->
qualUser E.^. QualificationUserId E.=?. qualBlock E.?. QualificationUserBlockQualificationUser qualUser E.^. QualificationUserId E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
E.&&. E.val now E.>~. qualBlock E.?. QualificationUserBlockFrom E.&&. E.val now E.>~. qualBlock E.?. QualificationUserBlockFrom
) )
@ -116,19 +116,19 @@ getQualificationSAPDirectR = do
E.&&. (E.justVal ldap_cutoff E.<=. user E.^. UserLastLdapSynchronisation) E.&&. (E.justVal ldap_cutoff E.<=. user E.^. UserLastLdapSynchronisation)
E.groupBy ( user E.^. UserCompanyPersonalNumber E.groupBy ( user E.^. UserCompanyPersonalNumber
, qualUser E.^. QualificationUserFirstHeld , qualUser E.^. QualificationUserFirstHeld
, qualUser E.^. QualificationUserValidUntil , qualUser E.^. QualificationUserValidUntil
, qual E.^. QualificationSapId , qual E.^. QualificationSapId
) )
let blockOrder = [E.asc $ qualBlock E.?. QualificationUserBlockFrom, E.asc $ qualBlock E.?. QualificationUserBlockId] let blockOrder = [E.asc $ qualBlock E.?. QualificationUserBlockFrom, E.asc $ qualBlock E.?. QualificationUserBlockId]
-- blockAgg f = E.arrayAggWith E.AggModeAll (qualBlock E.^. f) blockOrder -- blockAgg f = E.arrayAggWith E.AggModeAll (qualBlock E.^. f) blockOrder
return return
( user E.^. UserCompanyPersonalNumber ( user E.^. UserCompanyPersonalNumber
, qual E.^. QualificationSapId , qual E.^. QualificationSapId
, qualUser E.^. QualificationUserFirstHeld , qualUser E.^. QualificationUserFirstHeld
, qualUser E.^. QualificationUserValidUntil , qualUser E.^. QualificationUserValidUntil
, E.arrayAggWith E.AggModeAll (E.dayMaybe $ qualBlock E.?. QualificationUserBlockFrom ) blockOrder , E.arrayAggWith E.AggModeAll (E.dayMaybe $ qualBlock E.?. QualificationUserBlockFrom ) blockOrder
, E.arrayAggWith E.AggModeAll ( qualBlock E.?. QualificationUserBlockUnblock) blockOrder , E.arrayAggWith E.AggModeAll ( qualBlock E.?. QualificationUserBlockUnblock) blockOrder
) )
let csvRendered = toCsvRendered sapUserTableCsvHeader $ sapRes2csv qualUsers let csvRendered = toCsvRendered sapUserTableCsvHeader $ sapRes2csv qualUsers
fmtOpts = (review csvPreset CsvPresetRFC) fmtOpts = (review csvPreset CsvPresetRFC)
{ csvIncludeHeader = True { csvIncludeHeader = True
@ -144,7 +144,7 @@ getQualificationSAPDirectR = do
let logInt = runDB $ logInterface "SAP" quals True (Just nr) "" let logInt = runDB $ logInterface "SAP" quals True (Just nr) ""
addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered <* logInt csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered <* logInt
-- direct Download see: -- direct Download see:
-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod -- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod

6
src/Handler/Users.hs
View File

@ -121,7 +121,7 @@ postUsersR = do
-- (AdminUserR <$> encrypt uid) -- (AdminUserR <$> encrypt uid)
-- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName) -- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName)
, sortable (Just "user-supervisor") (i18nCell MsgTableSupervisor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do , 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.on $ spvr E.^. UserSupervisorSupervisor E.==. usrSpvr E.^. UserId
E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid E.where_ $ spvr E.^. UserSupervisorUser E.==. E.val uid
E.orderBy [E.asc (usrSpvr E.^. UserDisplayName)] 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 , sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation
, flip foldMap universeF $ \function -> , flip foldMap universeF $ \function ->
sortable (Just $ SortingKey $ CI.mk $ toPathPiece function) (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do 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.on $ school E.^. SchoolId E.==. userFunction E.^. UserFunctionSchool
E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
E.&&. userFunction E.^. UserFunctionFunction E.==. E.val function E.&&. userFunction E.^. UserFunctionFunction E.==. E.val function
@ -148,7 +148,7 @@ postUsersR = do
<li>#{sh} <li>#{sh}
|] |]
, sortable (Just "system-function") (i18nCell MsgUserSystemFunctions) $ \DBRow{ dbrOutput = Entity uid _ } -> , 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 in listCell' getFunctions i18nCell
, sortable Nothing (mempty & cellAttrs <>~ pure ("hide-columns--hider-label", mr MsgTableActionsHead)) $ \inp@DBRow{ dbrOutput = Entity uid _ } -> FormCell , sortable Nothing (mempty & cellAttrs <>~ pure ("hide-columns--hider-label", mr MsgTableActionsHead)) $ \inp@DBRow{ dbrOutput = Entity uid _ } -> FormCell
{ formCellAttrs = [] { formCellAttrs = []

16
src/Handler/Utils/Avs.hs
View File

@ -171,11 +171,11 @@ lookupAvsUsers apis = do
updateReceivers :: UserId -> Handler (Entity User, [Entity User], Bool) updateReceivers :: UserId -> Handler (Entity User, [Entity User], Bool)
updateReceivers uid = do updateReceivers uid = do
-- First perform AVS update for receiver -- 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 Just Entity{entityVal=UserAvs{userAvsPersonId = apid}} -> catchAll2log $ upsertAvsUserById apid
Nothing -> return () Nothing -> return ()
-- Retrieve updated user and supervisors now -- 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 <$> getJustEntity uid
<*> (E.select $ do <*> (E.select $ do
(usrSuper :& usrAvs) <- (usrSuper :& usrAvs) <-
@ -194,7 +194,7 @@ updateReceivers uid = do
if null receiverIDs if null receiverIDs
then directResult then directResult
else do 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 if null receivers
then directResult then directResult
else return (underling, receivers, uid `elem` (entityKey <$> receivers)) else return (underling, receivers, uid `elem` (entityKey <$> receivers))
@ -450,7 +450,7 @@ updateAvsUserByADC newAvsDataContact@(AvsDataContact apid newAvsPersonInfo newAv
linktoAvsUserByUIDs :: Set UserId -> Handler () linktoAvsUserByUIDs :: Set UserId -> Handler ()
linktoAvsUserByUIDs uids = do linktoAvsUserByUIDs uids = do
ips <- runDB $ E.select $ do ips <- runDBRead $ E.select $ do
usr <- E.from $ E.table @User usr <- E.from $ E.table @User
let uid = usr E.^. UserId let uid = usr E.^. UserId
ipn = usr E.^. UserCompanyPersonalNumber ipn = usr E.^. UserCompanyPersonalNumber
@ -490,7 +490,7 @@ createAvsUserById muid api = do
-- check for matching existing user -- check for matching existing user
let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo let internalPersNo :: Maybe Text = cpi ^? _avsInfoInternalPersonalNo . _Just . _avsInternalPersonalNo
-- persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI -- persMail :: Maybe UserEmail = cpi ^? _avsInfoPersonEMail . _Just . from _CI
oldUsr <- runDB $ do oldUsr <- runDBRead $ do
mbUid <- if isJust muid mbUid <- if isJust muid
then return muid then return muid
else firstJustM $ catMaybes else firstJustM $ catMaybes
@ -736,15 +736,15 @@ guessAvsUser :: Text -> Handler (Maybe UserId)
guessAvsUser (Text.splitAt 6 -> (Text.toUpper -> prefix, readMay -> Just nr)) guessAvsUser (Text.splitAt 6 -> (Text.toUpper -> prefix, readMay -> Just nr))
| prefix=="AVSID:" = | prefix=="AVSID:" =
let avsid = AvsPersonId nr in let avsid = AvsPersonId nr in
runDB (getBy $ UniqueUserAvsId avsid) >>= \case runDBRead (getBy $ UniqueUserAvsId avsid) >>= \case
(Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> return $ Just uid (Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> return $ Just uid
Nothing -> catchAVS2message $ Just <$> upsertAvsUserById avsid Nothing -> catchAVS2message $ Just <$> upsertAvsUserById avsid
| prefix=="AVSNO:" = | prefix=="AVSNO:" =
runDB (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr]) runDBRead (view (_entityVal . _userAvsUser) <<$>> getByFilter [UserAvsNoPerson ==. nr])
guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) = guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) =
catchAVS2message $ upsertAvsUserByCard someavsid >>= \case catchAVS2message $ upsertAvsUserByCard someavsid >>= \case
Nothing | Left{} <- someavsid -> -- attempt to find PersonalNumber in DB Nothing | Left{} <- someavsid -> -- attempt to find PersonalNumber in DB
runDB (getKeyByFilter [UserCompanyPersonalNumber ==. Just someid]) runDBRead (getKeyByFilter [UserCompanyPersonalNumber ==. Just someid])
other -> return other other -> return other
guessAvsUser someid = do guessAvsUser someid = do
try (runDB $ ldapLookupAndUpsert someid) >>= \case try (runDB $ ldapLookupAndUpsert someid) >>= \case

14
src/Handler/Utils/Qualification.hs
View File

@ -112,12 +112,14 @@ validQualification' cutoff qualUser =
E.&&. quserBlock' False cutoff qualUser E.&&. quserBlock' False cutoff qualUser
-- selectValidQualifications :: QualificationId -> [UserId] -> UTCTime -> DB [Entity QualificationUser] -- selectValidQualifications :: QualificationId -> [UserId] -> UTCTime -> DB [Entity QualificationUser]
selectValidQualifications :: -- selectValidQualifications ::
( MonadIO m -- ( MonadIO m
, BackendCompatible SqlBackend backend -- , BackendCompatible SqlBackend backend
, PersistQueryRead backend -- , PersistQueryRead backend
, PersistUniqueRead backend -- , PersistUniqueRead backend
) => QualificationId -> [UserId] -> UTCTime -> ReaderT backend m [Entity QualificationUser] -- ) => 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 = selectValidQualifications qid uids cutoff =
-- cutoff <- utctDay <$> liftIO getCurrentTime -- cutoff <- utctDay <$> liftIO getCurrentTime
E.select $ do E.select $ do

4
src/Handler/Utils/Widgets.hs
View File

@ -62,7 +62,7 @@ userWidget :: HasUser c => c -> Widget
userWidget x = nameWidget (x ^. _userDisplayName) (x ^._userSurname) userWidget x = nameWidget (x ^. _userDisplayName) (x ^._userSurname)
userIdWidget :: UserId -> Widget 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 :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> Entity User -> Widget
linkUserWidget lnk (Entity uid usr) = do 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 -- | like linkUserWidget, but on Id only. Requires DB access, use with caution
linkUserIdWidget :: HasRoute UniWorX url => (CryptoUUIDUser -> url) -> UserId -> Widget 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 :: HasUser c => c -> Widget
userEmailWidget x = nameEmailWidget (x ^. _userDisplayEmail) (x ^. _userDisplayName) (x ^. _userSurname) userEmailWidget x = nameEmailWidget (x ^. _userDisplayEmail) (x ^. _userDisplayName) (x ^. _userSurname)

38
src/Jobs/Handler/SynchroniseAvs.hs
View File

@ -3,9 +3,9 @@
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
module Jobs.Handler.SynchroniseAvs module Jobs.Handler.SynchroniseAvs
( dispatchJobSynchroniseAvs ( dispatchJobSynchroniseAvs
-- , dispatchJobSynchroniseAvsId -- , dispatchJobSynchroniseAvsId
-- , dispatchJobSynchroniseAvsUser -- , dispatchJobSynchroniseAvsUser
, dispatchJobSynchroniseAvsQueue , dispatchJobSynchroniseAvsQueue
) where ) 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 -- 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 :: Natural -> Natural -> Natural -> Maybe Day -> JobHandler UniWorX
dispatchJobSynchroniseAvs numIterations epoch iteration pause dispatchJobSynchroniseAvs numIterations epoch iteration pause
= JobHandlerException . runDB $ do = JobHandlerException . runDB $ do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
todos <- runConduit $ readUsers .| filterIteration now .| sinkList todos <- runConduit $ readUsers .| filterIteration now .| sinkList
@ -44,13 +44,13 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause
userIteration = toInteger (hash epoch `hashWithSalt` userId) `mod` toInteger numIterations userIteration = toInteger (hash epoch `hashWithSalt` userId) `mod` toInteger numIterations
currentIteration = toInteger iteration `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}|] $logDebugS "SynchronisAvs" [st|User ##{tshow (fromSqlKey userId)}: AVS sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|]
guard $ userIteration == currentIteration guard $ userIteration == currentIteration
return $ AvsSync userId now pause return $ AvsSync userId now pause
-- dispatchJobSynchroniseAvsId :: AvsPersonId -> Maybe Day -> JobHandler UniWorX -- dispatchJobSynchroniseAvsId :: AvsPersonId -> Maybe Day -> JobHandler UniWorX
-- dispatchJobSynchroniseAvsId apid pause = JobHandlerException $ -- dispatchJobSynchroniseAvsId apid pause = JobHandlerException $
-- maybeM insertUnknown processKnown $ runDB $ getBy (UniqueUserAvsId apid) -- maybeM insertUnknown processKnown $ runDB $ getBy (UniqueUserAvsId apid)
-- where -- where
-- processKnown Entity{entityVal=UserAvs{userAvsUser=uid}} = workJobSychronizeAvs uid pause -- processKnown Entity{entityVal=UserAvs{userAvsUser=uid}} = workJobSychronizeAvs uid pause
-- insertUnknown = void $ maybeCatchAll $ Just <$> upsertAvsUserById apid -- insertUnknown = void $ maybeCatchAll $ Just <$> upsertAvsUserById apid
@ -66,7 +66,7 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause
-- -- , avsSyncPause = 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 -- -- [ \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}) -- (insert_ AvsSync{avsSyncUser=uid, avsSyncCreationTime=now, avsSyncPause=pause})
-- (\Entity{entityKey=asid, entityVal=AvsSync{avsSyncPause=oldPause}} -> -- (\Entity{entityKey=asid, entityVal=AvsSync{avsSyncPause=oldPause}} ->
-- update asid [AvsSyncPause =. max pause oldPause, AvsSyncCreationTime =. now]) -- update asid [AvsSyncPause =. max pause oldPause, AvsSyncCreationTime =. now])
@ -78,10 +78,10 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause
-- dispatchJobSynchroniseAvsQueue = JobHandlerException $ do -- dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
-- (unlinked,linked) <- runDB $ do -- (unlinked,linked) <- runDB $ do
-- jobs <- E.select (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.leftJoin` E.table @UserAvs
-- `E.on` (\(avsSync :& usrAvs) -> avsSync E.^. AvsSyncUser E.=?. usrAvs E.?. UserAvsUser) -- `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 -- lastSync = usrAvs E.?. UserAvsLastSynch
-- E.where_ $ E.isNothing pause -- E.where_ $ E.isNothing pause
-- E.||. E.isNothing lastSync -- E.||. E.isNothing lastSync
@ -91,22 +91,22 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause
-- let (syncIds, unlinked, linked) = foldl' discernJob mempty jobs -- let (syncIds, unlinked, linked) = foldl' discernJob mempty jobs
-- E.deleteWhere [AvsSyncId <-. syncIds] -- E.deleteWhere [AvsSyncId <-. syncIds]
-- return (unlinked, linked) -- return (unlinked, linked)
-- void $ updateAvsUserByIds linked -- void $ updateAvsUserByIds linked
-- void $ linktoAvsUserByUIDs unlinked -- void $ linktoAvsUserByUIDs unlinked
-- -- we do not reschedule failed synchs here in order to avoid a loop -- -- 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 (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) -- discernJob (accSync, accUid, accApi) (E.Value k, E.Value uid, E.Value Nothing ) = (k:accSync, Set.insert uid accUid, accApi)
dispatchJobSynchroniseAvsQueue :: JobHandler UniWorX dispatchJobSynchroniseAvsQueue :: JobHandler UniWorX
dispatchJobSynchroniseAvsQueue = JobHandlerException $ do dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
jobs <- runDB $ do jobs <- runDBRead $ do
E.select (do E.select (do
(avsSync :& usrAvs) <- E.from $ E.table @AvsSync (avsSync :& usrAvs) <- E.from $ E.table @AvsSync
`E.leftJoin` E.table @UserAvs `E.leftJoin` E.table @UserAvs
`E.on` (\(avsSync :& usrAvs) -> avsSync E.^. AvsSyncUser E.=?. usrAvs E.?. UserAvsUser) `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 lastSync = usrAvs E.?. UserAvsLastSynch
proceed = E.isNothing pause proceed = E.isNothing pause
E.||. E.isNothing lastSync E.||. E.isNothing lastSync
@ -124,7 +124,7 @@ dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
runDB $ deleteWhere [AvsSyncUser <-. (E.unValue . fst3 <$> jobs)] runDB $ deleteWhere [AvsSyncUser <-. (E.unValue . fst3 <$> jobs)]
$logInfoS "SynchronisAvs" [st|AVS synch performed for #{length linked} AVS linked users and #{length unlinked} unlinked users|] $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 -- 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 (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 uid, E.Value Nothing , E.Value True ) = accs & over _1 (Set.insert uid)
discernJob accs ( _ , _ , E.Value False ) = accs discernJob accs ( _ , _ , E.Value False ) = accs