-- SPDX-FileCopyrightText: 2022 Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances {-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only {-# LANGUAGE TypeApplications #-} module Handler.Qualification ( getQualificationAllR , getQualificationSchoolR , getQualificationR, postQualificationR ) where import Import -- import Jobs import Handler.Utils -- import Handler.Utils.Csv -- 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 -- TODO just a stub qualiTable <- runDB $ do view _2 <$> mkQualificationAllTable 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 getSupervisees :: DB (Set UserId) getSupervisees = do uid <- requireAuthId svs <- userSupervisorUser . entityVal <<$>> selectList [UserSupervisorSupervisor ==. uid] [Asc UserSupervisorUser] return $ Set.insert uid $ Set.fromAscList svs mkQualificationAllTable :: DB (Any, Widget) mkQualificationAllTable = do svs <- getSupervisees now <- liftIO getCurrentTime let resultDBTable = DBTable{..} where dbtSQLQuery quali = do let filterSvs quser = quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId Ex.&&. 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 -- TODO: or dbtProjSimple what is the difference? 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 , qtcValidUntil :: Day , qtcLastRefresh :: Day , qtcBlocked :: Maybe Day , qtcLmsStatusTxt :: Maybe Text , qtcLmsStatusDay :: Maybe Day } deriving Generic makeLenses_ ''QualificationTableCsv qtcExample :: QualificationTableCsv qtcExample = QualificationTableCsv { qtcDisplayName = "Max Mustermann" , qtcEmail = "m.mustermann@example.com" , qtcValidUntil = compDay , qtcLastRefresh = compDay , qtcBlocked = Nothing , 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 = ("e-learn-" <>) 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, MsgLmsUser) , ('qtcEmail , MsgTableLmsEmail) , ('qtcValidUntil , MsgLmsQualificationValidUntil) , ('qtcLastRefresh, MsgTableQualificationLastRefresh) , ('qtcLmsStatusTxt, MsgTableLmsStatus) , ('qtcLmsStatusDay, 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)) 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 instance HasEntity QualificationTableData User where hasEntity = resultUser instance HasUser QualificationTableData where hasUser = resultUser . _entityVal data QualificationTableAction = QualificationActExpire | QualificationActUnexpire deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe QualificationTableAction instance Finite QualificationTableAction nullaryPathPiece ''QualificationTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''QualificationTableAction id -- Not yet needed, since there is no additional data for now: data QualificationTableActionData = QualificationActExpireData | QualificationActUnexpireData deriving (Eq, Ord, Read, Show, Generic) isExpiryAct :: QualificationTableActionData -> Bool -- const true, but this may change in the future isExpiryAct QualificationActExpireData = True isExpiryAct QualificationActUnexpireData = True 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) -> 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 currentRoute <- fromMaybe (error "mkQualificationTable called from 404-handler") <$> liftHandler getCurrentRoute 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 q = qualificationTableQuery qid fltrSvs q dbtRowKey = queryUser >>> (E.^. UserId) dbtProj = dbtProjFilteredPostId dbtColonnade = cols dbtSorting = mconcat [ single $ sortUserNameLink queryUser , single $ sortUserEmail queryUser , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) , single ("blocked-due" , SortColumn $ queryQualUser >>> (E.^. QualificationUserBlockedDue)) -- , single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted)) -- , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus)) , single ("lms-status-plus",SortColumn $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}" , queryLmsUser row E.?. LmsUserStarted]) ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser , 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 "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 (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> preview (resultQualUser . _entityVal . _qualificationUserBlockedDue . _Just . _qualificationBlockedDay) <*> getStatusPlusTxt <*> getStatusPlusDay getStatusPlusTxt = (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case Just LmsBlocked{} -> return $ Just "Failed" 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 = Just $ SomeRoute currentRoute , 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 currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler isAdmin <- hasReadAccessTo AdminR ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do qent@Entity{entityVal=Qualification{qualificationAuditDuration=auditMonths}} <- getBy404 $ SchoolQualificationShort sid qsh let acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) acts = mconcat [ singletonMap QualificationActExpire $ pure QualificationActExpireData , singletonMap QualificationActUnexpire $ pure QualificationActUnexpireData ] colChoices = mconcat [ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) , colUserNameLinkHdr MsgLmsUser ForProfileR , colUserEmail , 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) -> qualificationBlockedCellNoReason b , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification -- , sortable (Just "lms-started") (i18nCell MsgTableLmsElearning <> spacerCell <> i18nCell MsgTableLmsStarted) -- $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d -- , sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltip (MsgTableLmsStatusTooltip auditMonths)) $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap lmsStatusPlusCell lu ] psValidator = def tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator return (tbl, qent) formResult lmsRes $ \case _ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page for now (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 redirect currentRoute _ -> return () let heading = citext2widget $ qualificationName quali siteLayout heading $ do setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh $(widgetFile "qualification")