-- 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 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 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) -- avoids repetition of local definitions single :: (k,a) -> Map k a single = uncurry Map.singleton 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 (utctDay 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 & cellTooltip MsgTableDiffDaysTooltip) $ foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin) -- , sortable Nothing (i18nCell MsgQualificationRefreshWithin) $ foldMap textCell . view (resultAllQualification . _qualificationRefreshWithin . to formatCalendarDiffDays) -- does not work, since there is a maybe in between , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart) , 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) ] 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 -- getQualificationEditR, postQualificationEditR :: SchoolId -> QualificationShorthand -> Handler Html -- getQualificationEditR = postQualificationEditR -- postQualificationEditR = error "TODO" data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. { qtcDisplayName :: UserDisplayName , qtcEmail :: UserEmail , qtcCompany :: Maybe Text , qtcCompanyNumbers :: CsvSemicolonList Int , qtcValidUntil :: Day , qtcLastRefresh :: Day , qtcBlocked :: Maybe Day , qtcScheduleRenewal:: Bool , qtcLmsStatusTxt :: Maybe Text , qtcLmsStatusDay :: Maybe Day } deriving Generic makeLenses_ ''QualificationTableCsv qtcExample :: QualificationTableCsv qtcExample = QualificationTableCsv { qtcDisplayName = "Max Mustermann" , qtcEmail = "m.mustermann@example.com" , qtcCompany = Just "Example Brothers LLC, SecondaryJobs Inc" , qtcCompanyNumbers = CsvSemicolonList [27,69] , qtcValidUntil = compDay , qtcLastRefresh = compDay , qtcBlocked = Nothing , qtcScheduleRenewal= True , qtcLmsStatusTxt = Just "Success" , qtcLmsStatusDay = Just compDay } 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 MsgTableCompanies) , ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos) , ('qtcValidUntil , SomeMessage MsgLmsQualificationValidUntil) , ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh) , ('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)) queryQualUser :: QualificationTableExpr -> E.SqlExpr (Entity QualificationUser) queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1) queryUser :: QualificationTableExpr -> E.SqlExpr (Entity User) queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1) queryLmsUser :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) queryLmsUser = $(sqlLOJproj 2 2) type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), [Entity UserCompany]) 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 resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany] resultCompanyUser = _dbrOutput . _4 instance HasEntity QualificationTableData User where hasEntity = resultUser instance HasUser QualificationTableData where hasUser = resultUser . _entityVal data QualificationTableAction = QualificationActExpire | QualificationActUnexpire | QualificationActBlockSupervisor | QualificationActBlock | QualificationActUnblock | QualificationActRenew | QualificationActGrant 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 } | QualificationActUnblockData | QualificationActRenewData | QualificationActGrantData { qualTableActGrantUntil :: Day } deriving (Eq, Ord, Read, 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 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` lmsUser) = 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) 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) -> (Map CompanyId Company -> 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 $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do cmps <- selectList [] [] -- [Asc CompanyShorthand] return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps let 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 qid fltrSvs dbtRowKey = queryUser >>> (E.^. UserId) dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr) -> do -- cmps <- E.select . E.from $ \(usrComp `E.InnerJoin` comp) -> do -- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId -- E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val (entityKey usr) -- E.orderBy [E.asc (comp E.^. CompanyName)] -- return (comp E.^. CompanyName, comp E.^. CompanyAvsId, usrComp E.^. UserCompanySupervisor) cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany] return (qualUsr, usr, lmsUsr, cmpUsr) dbtColonnade = cols cmpMap dbtSorting = mconcat [ single $ sortUserNameLink queryUser , single $ sortUserEmail queryUser , single $ sortUserMatriclenr queryUser , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) , single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified)) , single ("blocked-due" , SortColumnNeverNull $ queryQualUser >>> (E.^. QualificationUserBlockedDue)) , single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}" , queryLmsUser row E.?. LmsUserStarted]) , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) , single ( "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) ) ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser , single ("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))) )) , single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of Nothing -> E.false Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo) ) , single ("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 ) , single ("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 ) , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday)) , single ("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 ) ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgLmsUser mPrev , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo) , 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) ] 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) <*> (view resultCompanyUser >>= getCompanies) <*> (view resultCompanyUser >>= getCompanyNos) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> preview (resultQualUser . _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedDay) <*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal) <*> getStatusPlusTxt <*> getStatusPlusDay getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of [] -> pure Nothing somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) 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 . _lmsUserStatus)) >>= \case Just ls -> return $ Just $ lmsStatusDay ls Nothing -> utctDay <<$>> 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) <- runDB $ do qent@Entity{entityVal=Qualification{ qualificationAuditDuration=auditMonths , qualificationValidDuration=validMonths }} <- getBy404 $ SchoolQualificationShort sid qsh let dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) acts = mconcat $ [ singletonMap QualificationActExpire $ pure QualificationActExpireData , singletonMap QualificationActUnexpire $ QualificationActUnexpireData <$ aformMessage msgUnexpire ] ++ bool [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- nonAdmin actions, ie. Supervisor [ singletonMap QualificationActUnblock $ pure QualificationActUnblockData -- Admin-only actions , singletonMap QualificationActBlock $ QualificationActBlockData <$> apreq textField (fslI MsgQualificationBlockReason) Nothing <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) , singletonMap QualificationActRenew $ pure QualificationActRenewData , singletonMap QualificationActGrant $ QualificationActGrantData <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry <* aformMessage msgGrantWarning ] isAdmin linkLmsUser = toMaybe isAdmin LmsUserR linkUserName = bool ForProfileR ForProfileDataR isAdmin blockedDueCell = bool qualificationBlockedCellNoReason qualificationBlockedCell isAdmin colChoices cmpMap = mconcat [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , colUserNameModalHdr MsgLmsUser linkUserName , colUserEmail , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> let icnSuper = text2markup " " <> icon IconSupervisor cs = [ (cmpName, cmpSpr) | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap ] companies = intercalate (text2markup ", ") $ (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs in wgtCell companies , guardMonoid isAdmin colUserMatriclenr , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d , sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltipSimple ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> blockedDueCell b , 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 , sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified) $ \( view $ resultQualUser . _entityVal . _qualificationUserLastNotified -> d) -> dateTimeCell d ] psValidator = def & defaultSorting [SortDescBy "last-refresh"] tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator return (tbl, qent) formResult lmsRes $ \case (QualificationActRenewData, selectedUsers) | isAdmin -> do noks <- runDB $ renewValidQualificationUsers qid $ 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 nowaday grantValidday Nothing addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers reloadKeepGetParams $ QualificationR sid qsh (action, selectedUsers) | isExpiryAct action -> do let isUnexpire = action == QualificationActUnexpireData upd <- runDB $ 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 qubr = case action of QualificationActUnblockData -> Nothing QualificationActBlockSupervisorData -> Just $ mkQualificationBlocked QualificationBlockReturnedByCompany nowaday QualificationActBlockData{..} -> Just $ QualificationBlocked { qualificationBlockedDay = nowaday , qualificationBlockedReason = qualTableActBlockReason } _ -> error "Handle.Qualification.isBlockAct returned non-block action" notify = case action of QualificationActBlockData{qualTableActNotify} -> qualTableActNotify _ -> False oks <- runDB $ do deleteWhere [UserSupervisorUser <-. selUserIds] deleteWhere [UserCompanyUser <-. selUserIds] qualificationUserBlocking qid selUserIds notify qubr let nrq = length selectedUsers warnLevel = if | oks < 0 -> Error | oks == nrq -> Success | otherwise -> Warning fbmsg = if | isNothing qubr -> MsgQualificationStatusUnblock | otherwise -> 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")