-- SPDX-FileCopyrightText: 2022-23 Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances {-# LANGUAGE TypeApplications #-} module Handler.Qualification ( getQualificationAllR , getQualificationSchoolR , getQualificationR, postQualificationR ) where import Import import Jobs import Handler.Utils import Handler.Utils.Users import Handler.Utils.LMS import Handler.Utils.Company import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Csv as Csv import qualified Data.Text as T import qualified Data.CaseInsensitive as CI import qualified Data.Conduit.List as C import Database.Persist.Sql (updateWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Legacy as E -- import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH -- import Handler.Utils.Qualification (validQualification) getQualificationSchoolR :: SchoolId -> Handler Html getQualificationSchoolR ssh = redirect (QualificationAllR, [("qualification-overview-school", toPathPiece ssh)]) getQualificationAllR :: Handler Html getQualificationAllR = do isAdmin <- hasReadAccessTo AdminR qualiTable <- runDB $ do view _2 <$> mkQualificationAllTable isAdmin siteLayoutMsg MsgMenuQualifications $ do setTitleI MsgMenuQualifications $(widgetFile "qualification-all") type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64) resultAllQualification :: Lens' AllQualificationTableData Qualification resultAllQualification = _dbrOutput . _1 . _entityVal resultAllQualificationActive :: Lens' AllQualificationTableData Word64 resultAllQualificationActive = _dbrOutput . _2 . _unValue resultAllQualificationTotal :: Lens' AllQualificationTableData Word64 resultAllQualificationTotal = _dbrOutput . _3 . _unValue mkQualificationAllTable :: Bool -> DB (Any, Widget) mkQualificationAllTable isAdmin = do svs <- getSupervisees now <- liftIO getCurrentTime let resultDBTable = DBTable{..} where dbtSQLQuery quali = do let filterSvs quser = quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId Ex.&&. (E.val isAdmin E.||. quser Ex.^. QualificationUserUser `Ex.in_` E.vals svs) cusers = Ex.subSelectCount $ do quser <- Ex.from $ Ex.table @QualificationUser Ex.where_ $ filterSvs quser cactive = Ex.subSelectCount $ do quser <- Ex.from $ Ex.table @QualificationUser Ex.where_ $ filterSvs quser Ex.&&. validQualification now quser return (quali, cactive, cusers) dbtRowKey = (Ex.^. QualificationId) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat [ colSchool $ resultAllQualification . _qualificationSchool , sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> let qsh = qualificationShorthand quali in anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qsh , sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) -> let qsh = qualificationShorthand quali qnm = qualificationName quali in anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qnm , sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) -> maybeCell (qualificationDescription quali) markupCellLargeModal , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration) , sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $ foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin) , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) $ \row -> let elearnstart = row ^. resultAllQualification . _qualificationElearningStart reminder = row ^. resultAllQualification . _qualificationRefreshReminder in tickmarkCell $ elearnstart && isJust reminder , sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $ foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder) , sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip) $ tickmarkCell . view (resultAllQualification . _qualificationExpiryNotification) -- , sortable (Just "qelearrenew") (i18nCell MsgTableLmsElearningRenews & cellTooltip MsgQualificationElearningRenew) -- $ tickmarkCell . view (resultAllQualification . _qualificationElearningRenews) -- , sortable Nothing (i18nCell MsgTableQualificationLmsReuses & cellTooltip MsgTableQualificationLmsReusesTooltip) -- $ \(view (resultAllQualification . _qualificationLmsReuses) -> reuseQid) -> maybeCell reuseQid qualificationIdShortCell , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip) $ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip) $ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) -> tickmarkCell $ isJust mbSapId , sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip) $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal ] dbtSorting = mconcat [ sortSchool $ to (E.^. QualificationSchool) , singletonMap "qshort" $ SortColumn (E.^. QualificationShorthand) , singletonMap "qname" $ SortColumn (E.^. QualificationName) , singletonMap "qelearning" $ SortColumn (E.^. QualificationElearningStart) , singletonMap "noteexpiry" $ SortColumn (E.^. QualificationExpiryNotification) ] dbtFilter = mconcat [ fltrSchool $ to (E.^. QualificationSchool) , singletonMap "qelearning" . FilterColumn $ E.mkExactFilterLast (E.^. QualificationElearningStart) ] dbtFilterUI = mconcat [ fltrSchoolUI , \mPrev -> prismAForm (singletonFilter "qelearning" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableLmsElearning) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def dbtIdent :: Text dbtIdent = "qualification-overview" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] resultDBTableValidator = def & defaultSorting [SortAscBy "school", SortAscBy "qshort"] dbTable resultDBTableValidator resultDBTable data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. { qtcDisplayName :: UserDisplayName , qtcEmail :: UserEmail , qtcCompany :: Maybe Text , qtcValidUntil :: Day , qtcLastRefresh :: Day , qtcBlockStatus :: Maybe Bool , qtcBlockFrom :: Maybe UTCTime , qtcScheduleRenewal:: Bool , qtcLmsStatusTxt :: Maybe Text , qtcLmsStatusDay :: Maybe UTCTime } deriving Generic makeLenses_ ''QualificationTableCsv qtcExample :: QualificationTableCsv qtcExample = QualificationTableCsv { qtcDisplayName = "Max Mustermann" , qtcEmail = "m.mustermann@example.com" , qtcCompany = Just "Example Brothers LLC" , qtcValidUntil = compDay , qtcLastRefresh = compDay , qtcBlockStatus = Nothing , qtcBlockFrom = Nothing , qtcScheduleRenewal= True , qtcLmsStatusTxt = Just "Success" , qtcLmsStatusDay = Just compTime } where compTime :: UTCTime compTime = $compileTime compDay :: Day compDay = utctDay compTime qtcOptions :: Csv.Options qtcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc } where renameLtc "qtcDisplayName" = "licensee" renameLtc other = replaceLtc $ camelToPathPiece' 1 other replaceLtc ('l':'m':'s':'-':t) = prefixLms t replaceLtc other = other prefixLms = ("elearn-" <>) instance Csv.ToNamedRecord QualificationTableCsv where toNamedRecord = Csv.genericToNamedRecord qtcOptions instance Csv.DefaultOrdered QualificationTableCsv where headerOrder = Csv.genericHeaderOrder qtcOptions instance CsvColumnsExplained QualificationTableCsv where csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList [ ('qtcDisplayName , SomeMessage MsgLmsUser) , ('qtcEmail , SomeMessage MsgTableLmsEmail) , ('qtcCompany , SomeMessage MsgTablePrimeCompany) , ('qtcValidUntil , SomeMessage MsgLmsQualificationValidUntil) , ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh) , ('qtcBlockStatus , SomeMessage MsgInfoQualificationBlockStatus) , ('qtcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom) , ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip) , ('qtcLmsStatusTxt , SomeMessage MsgTableLmsStatus) , ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay) ] type QualificationTableExpr = ( E.SqlExpr (Entity QualificationUser) `E.InnerJoin` E.SqlExpr (Entity User) ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock)) queryQualUser :: QualificationTableExpr -> E.SqlExpr (Entity QualificationUser) queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) queryUser :: QualificationTableExpr -> E.SqlExpr (Entity User) queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) queryLmsUser :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) queryLmsUser = $(sqlLOJproj 3 2) queryQualBlock :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock)) queryQualBlock = $(sqlLOJproj 3 3) type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity QualificationUserBlock), E.Value (Maybe CompanyId)) resultQualUser :: Lens' QualificationTableData (Entity QualificationUser) resultQualUser = _dbrOutput . _1 resultUser :: Lens' QualificationTableData (Entity User) resultUser = _dbrOutput . _2 resultLmsUser :: Traversal' QualificationTableData (Entity LmsUser) resultLmsUser = _dbrOutput . _3 . _Just resultQualBlock :: Traversal' QualificationTableData (Entity QualificationUserBlock) resultQualBlock = _dbrOutput . _4 . _Just resultCompanyId :: Traversal' QualificationTableData CompanyId resultCompanyId = _dbrOutput . _5 . _unValue . _Just instance HasEntity QualificationTableData User where hasEntity = resultUser instance HasUser QualificationTableData where hasUser = resultUser . _entityVal instance HasEntity QualificationTableData QualificationUser where hasEntity = resultQualUser instance HasQualificationUser QualificationTableData where hasQualificationUser = resultQualUser . _entityVal -- instance HasEntity QualificationUserBlock where -- hasQualificationUserBlock = resultQualBlock data QualificationTableAction = QualificationActExpire | QualificationActUnexpire | QualificationActBlockSupervisor | QualificationActBlock | QualificationActUnblock | QualificationActRenew | QualificationActGrant | QualificationActStartELearning deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe QualificationTableAction instance Finite QualificationTableAction nullaryPathPiece ''QualificationTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''QualificationTableAction id {- isAdminAct :: QualificationTableAction -> Bool isAdminAct QualificationActExpire = False isAdminAct QualificationActUnexpire = False isAdminAct QualificationActBlockSupervisor = False isAdminAct _ = True -} data QualificationTableActionData = QualificationActExpireData | QualificationActUnexpireData | QualificationActBlockSupervisorData | QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool } | QualificationActUnblockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool } | QualificationActRenewData { qualTableActChangeReason :: Text } | QualificationActGrantData { qualTableActGrantUntil :: Day } | QualificationActStartELearningData -- { qualTableActELearnUntil :: Maybe Day } deriving (Eq, Ord, Show, Generic) isExpiryAct :: QualificationTableActionData -> Bool isExpiryAct QualificationActExpireData = True isExpiryAct QualificationActUnexpireData = True isExpiryAct _ = False isBlockAct :: QualificationTableActionData -> Bool isBlockAct QualificationActBlockSupervisorData = True isBlockAct QualificationActBlockData{} = True isBlockAct QualificationActUnblockData{} = True isBlockAct _ = False blockActRemoveSupervisors :: QualificationTableActionData -> Bool blockActRemoveSupervisors QualificationActBlockSupervisorData = True blockActRemoveSupervisors QualificationActBlockData{qualTableActRemoveSupervisors=res} = res blockActRemoveSupervisors _ = False -- qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr -- -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) -- , E.SqlExpr (Entity User) -- , E.SqlExpr (Maybe (Entity LmsUser)) -- ) -- qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUse) = do -- 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_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) -- return (qualUser, user, lmsUser) qualificationTableQuery :: UTCTime -> QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) , E.SqlExpr (Entity User) , E.SqlExpr (Maybe (Entity LmsUser)) , E.SqlExpr (Maybe (Entity QualificationUserBlock)) , E.SqlExpr (E.Value (Maybe CompanyId)) ) qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do -- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps -- E.on $ qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId E.&&. qualBlock `isLatestBlockBefore` E.val now 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_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) return (qualUser, user, lmsUser, qualBlock, selectCompanyUserPrime user) mkQualificationTable :: ( Functor h, ToSortable h , AsCornice h p QualificationTableData (DBCell (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))) cols ) => Bool -> Entity Qualification -> Map QualificationTableAction (AForm Handler QualificationTableActionData) -> ((CompanyId -> CompanyName) -> cols) -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData)) -> DB (FormResult (QualificationTableActionData, Set UserId), Widget) mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do svs <- getSupervisees now <- liftIO getCurrentTime -- lookup all companies cmpMap <- memcachedBy (Just . Right $ 30 * diffMinute) ("CompanyDictionary"::Text) $ do cmps <- selectList [] [] -- [Asc CompanyShorthand] return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps let getCompanyName :: CompanyId -> CompanyName getCompanyName cid = maybe (unCompanyKey cid) companyName $ Map.lookup cid cmpMap -- use shorthand in case of impossible failure nowaday = utctDay now mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) dbtIdent :: Text dbtIdent = "qualification" fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs dbtSQLQuery = qualificationTableQuery now qid fltrSvs dbtRowKey = queryUser >>> (E.^. UserId) dbtProj = dbtProjId dbtColonnade = cols getCompanyName dbtSorting = Map.fromList [ sortUserNameLink queryUser , sortUserEmail queryUser , sortUserMatriclenr queryUser , ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) , ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) , ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified)) , ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) , ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) , ("lms-status-plus",SortColumnNullsInv $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay) , E.joinV (queryLmsUser row E.?. LmsUserNotified) , queryLmsUser row E.?. LmsUserStarted]) , ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) , ("user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.orderBy [E.asc (comp E.^. CompanyName)] return (comp E.^. CompanyName) ) -- , ("validity", SortColumn $ queryQualUser >>> validQualification now) ] dbtFilter = Map.fromList [ fltrUserNameEmail queryUser , ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> 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))) )) , fltrAVSCardNos queryUser , ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if | Set.null criteria -> E.true | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria ) , ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> 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 $ CI.original criterion E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit ) , ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now)) , ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> if | Just renewal <- mbRenewal , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday | otherwise -> E.true ) , ("tobe-notified", FilterColumn $ \row criterion -> if | Just True <- getLast criterion -> quserToNotify now (queryQualUser row) (queryQualBlock row) | otherwise -> E.true ) , ("status" , FilterColumn . E.mkExactFilterMaybeLast' (views (to queryLmsUser) (E.?. LmsUserId)) $ views (to queryLmsUser) (E.?. LmsUserStatus)) ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgLmsUser mPrev , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumberFraport) , fltrAVSCardNosUI mPrev , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) , if isNothing mbRenewal then mempty else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) , prismAForm (singletonFilter "tobe-notified" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsNotificationDue) , prismAForm (singletonFilter "status" . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtCsvEncode = Just DBTCsvEncode { dbtCsvExportForm = pure () , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) , dbtCsvName = csvName , dbtCsvSheetName = csvName , dbtCsvNoExportData = Just id , dbtCsvHeader = const $ return $ Csv.headerOrder qtcExample , dbtCsvExampleData = Just [qtcExample] } where doEncode' :: QualificationTableData -> QualificationTableCsv doEncode' = QualificationTableCsv <$> view (resultUser . _entityVal . _userDisplayName) <*> view (resultUser . _entityVal . _userDisplayEmail) <*> preview (resultCompanyId . to getCompanyName . _CI) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not) <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom) <*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal) <*> getStatusPlusTxt <*> getStatusPlusDay getStatusPlusTxt = (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case Just LmsBlocked{} -> return $ Just "Failed" Just LmsExpired{} -> return $ Just "Expired" Just LmsSuccess{} -> return $ Just "Success" Nothing -> maybeM (return Nothing) (const $ return $ Just "Open") $ preview (resultLmsUser . _entityVal . _lmsUserStarted) getStatusPlusDay = (join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case lsd@(Just _) -> return lsd Nothing -> preview (resultLmsUser . _entityVal . _lmsUserStarted) dbtCsvDecode = Nothing dbtExtraReps = [] dbtParams = DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Nothing , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> multiActionA acts (fslI MsgTableAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def } postprocess :: FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData) -> FormResult ( QualificationTableActionData, Set UserId) postprocess inp = do (First (Just act), usrMap) <- inp let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap return (act, usrSet) -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableActionData)) -- resultDBTableValidator = def -- & defaultSorting [SortAscBy csvLmsIdent] over _1 postprocess <$> dbTable psValidator DBTable{..} getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html getQualificationR = postQualificationR postQualificationR sid qsh = do isAdmin <- hasReadAccessTo AdminR msgGrantWarning <- messageIconI Warning IconWarning MsgQualificationActGrantWarning msgUnexpire <- messageIconI Info IconWarning MsgQualificationActUnexpireWarning now <- liftIO getCurrentTime let nowaday = utctDay now ((lmsRes, qualificationTable), Entity qid quali, lmsQualiReused) <- runDB $ do qent@Entity{ entityKey=qid , entityVal=Qualification{ qualificationAuditDuration=auditMonths , qualificationValidDuration=validMonths , qualificationLmsReuses =reuseQuali }} <- getBy404 $ SchoolQualificationShort sid qsh lmsQualiReused <- traverseJoin get reuseQuali -- Block copied to Handler/Qualifications TODO: refactor let getBlockReasons unblk = Ex.select $ do (quser :& qblock) <- Ex.from $ Ex.table @QualificationUser `Ex.innerJoin` Ex.table @QualificationUserBlock `Ex.on` (\(quser :& qblock) -> quser Ex.^. QualificationUserId Ex.==. qblock Ex.^. QualificationUserBlockQualificationUser) Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. Ex.val qid Ex.&&. unblk (qblock Ex.^. QualificationUserBlockUnblock) Ex.groupBy (qblock Ex.^. QualificationUserBlockReason) let countRows' :: Ex.SqlExpr (Ex.Value Int64) = Ex.countRows Ex.orderBy [Ex.desc countRows'] Ex.limit 9 pure (qblock Ex.^. QualificationUserBlockReason) suggestionsBlock :: HandlerFor UniWorX (OptionList Text) suggestionsBlock = mkOptionListText <$> runDB (getBlockReasons Ex.not_) suggestionsUnblock = mkOptionListText <$> runDB (getBlockReasons id) dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) acts = mconcat $ [ singletonMap QualificationActExpire $ pure QualificationActExpireData , singletonMap QualificationActUnexpire $ QualificationActUnexpireData <$ aformMessage msgUnexpire ] ++ bool -- nonAdmin actions, ie. Supervisor [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- Admin-only actions [ singletonMap QualificationActUnblock $ QualificationActUnblockData <$> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) , singletonMap QualificationActBlock $ QualificationActBlockData <$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor) (Just False) , singletonMap QualificationActRenew $ QualificationActRenewData <$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationRenewReason) Nothing , singletonMap QualificationActGrant $ QualificationActGrantData <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry <* aformMessage msgGrantWarning , singletonMap QualificationActStartELearning $ pure QualificationActStartELearningData -- <$> aopt dayField (fslI MsgQualificationReduceValidUntil) Nothing ] isAdmin linkLmsUser = toMaybe isAdmin (LmsUserR sid qsh) linkUserName = bool ForProfileR ForProfileDataR isAdmin colChoices getCompanyName = mconcat [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , colUserNameModalHdr MsgLmsUser linkUserName , colUserEmail , sortable (Just "user-company") (i18nCell MsgTablePrimeCompany) $ \(preview resultCompanyId -> mcid) -> maybeEmpty mcid $ \cid -> companyCell (unCompanyKey cid) (getCompanyName cid) False , guardMonoid isAdmin $ colUserMatriclenr isAdmin -- , 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) (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil)) , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> qualificationValidReasonCell' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths)) $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusCell isAdmin linkLmsUser) lu -- QualificationUserLastNotified is about notification on actual validity changes. If a user's licence is about to expire and renewed before expiry via e-learning, this value does not change. -- NOTE: If this column is reinstatiated, header and tooltip were already updated to avoid any confusion! -- , sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified & cellTooltip MsgTableQualificationLastNotifiedTooltip) -- $ \( view $ resultQualUser . _entityVal . _qualificationUserLastNotified -> d) -> dateTimeCell d ] psValidator = def & defaultSorting [SortDescBy "last-refresh"] tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator return (tbl, qent, lmsQualiReused) formResult lmsRes $ \case (QualificationActRenewData renewReason, selectedUsers) | isAdmin -> do noks <- runDB $ renewValidQualificationUsers qid (canonical $ Just $ Left renewReason) Nothing $ Set.toList selectedUsers addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks reloadKeepGetParams $ QualificationR sid qsh (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do runDB . forM_ selectedUsers $ upsertQualificationUser qid now grantValidday Nothing "Admin" addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers reloadKeepGetParams $ QualificationR sid qsh (QualificationActStartELearningData, Set.toList -> selectedUsers) | isAdmin -> do -- whenIsJust mbExpDay $ \expDay -> -- when expDay > nowaday $ -- -- updateWhere [QualificationUserQualification ==. qid, QualificationUserUser <-. selectedUsers, QualificationUserValidUntil >. expDay] [QualificationUserValidUntil =. expDay] -- DO NOT USE: no audit -- NOTE: if needed, create function Handler.Utils.Qualification.updateQualificationUser qid QualificationChangeReason -> Day -> [UserId] -> DB Int validQualHolderEnts <- runDB $ selectValidQualifications qid selectedUsers now let validQualHolders = view (_entityVal . _qualificationUserUser) <$> validQualHolderEnts jobs <- forM validQualHolders $ queueJob . JobLmsEnqueueUser qid let nrTodo = length selectedUsers nrEnqueued = length $ catMaybes jobs addMessageI (bool Warning Success $ nrEnqueued > 0 && nrEnqueued == nrTodo) $ MsgQualificationActStartELearningStatus qsh nrEnqueued nrTodo -- transaction audit identical to automatic start, performed by JobLmsEnqueueUser reloadKeepGetParams $ QualificationR sid qsh (action, selectedUsers) | isExpiryAct action -> do let isUnexpire = action == QualificationActUnexpireData upd <- runDB $ do forM_ selectedUsers $ \uid -> audit TransactionQualificationUserScheduleRenewal { transactionUser = uid , transactionQualification = qid , transactionQualificationScheduleRenewal = Just isUnexpire } updateWhereCount [QualificationUserQualification ==. qid, QualificationUserUser <-. Set.toList selectedUsers] [QualificationUserScheduleRenewal =. isUnexpire] let msgKind = if upd > 0 then Success else Warning msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire addMessageI msgKind msgVal reloadKeepGetParams $ QualificationR sid qsh (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do let selUserIds = Set.toList selectedUsers (unblock, reason) = case action of QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany) QualificationActBlockData{..} -> (False, Left qualTableActBlockReason) QualificationActUnblockData{..} -> (True , Left qualTableActBlockReason) _ -> error "Handle.Qualification.isBlockAct returned non-block action" -- cannot occur due to earlier checks notify = case action of QualificationActBlockData{qualTableActNotify} -> qualTableActNotify _ -> False oks <- runDB $ do when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds] qualificationUserBlocking qid selUserIds unblock Nothing reason notify let nrq = length selectedUsers warnLevel = if | oks < 0 -> Error | oks == nrq -> Success | otherwise -> Warning fbmsg = if unblock then MsgQualificationStatusUnblock else MsgQualificationStatusBlock addMessageI warnLevel $ fbmsg qsh oks nrq reloadKeepGetParams $ QualificationR sid qsh _ -> addMessageI Error MsgInvalidFormAction let heading = citext2widget $ qualificationName quali siteLayout heading $ do setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh $(widgetFile "qualification")