-- SPDX-FileCopyrightText: 2023 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances {-# LANGUAGE TypeApplications #-} module Handler.Firm ( getFirmAllR , getFirmR, postFirmR ) where import Import -- import Jobs import Handler.Utils -- 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 -- avoids repetition of local definitions -- single :: (k,a) -> Map k a -- single = uncurry Map.singleton getFirmR, postFirmR :: CompanyShorthand -> Handler Html getFirmR = postFirmR postFirmR _ = do siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms [whamlet|STUB TO DO|] getFirmAllR :: Handler Html getFirmAllR = do uid <- requireAuthId isAdmin <- hasReadAccessTo AdminR firmTable <- runDB $ do view _2 <$> mkFirmAllTable (toMaybe (not isAdmin) uid) -- filter to associated companies for non-admins siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms -- $(widgetFile "firm-all") [whamlet|!!!STUB!!!TO DO!!! ^{firmTable} |] type AllCompanyTableData = DBRow (Entity Company, Ex.Value Word64, Ex.Value Word64, Ex.Value Word64) resultAllCompany :: Lens' AllCompanyTableData Company resultAllCompany = _dbrOutput . _1 . _entityVal resultAllCompanySupervisors :: Lens' AllCompanyTableData Word64 resultAllCompanySupervisors = _dbrOutput . _2 . _unValue resultAllCompanyUsers :: Lens' AllCompanyTableData Word64 resultAllCompanyUsers = _dbrOutput . _3 . _unValue resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64 resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue mkQualificationAllTable :: Maybe UserId -> DB (Any, Widget) mkQualificationAllTable mbUid = do now <- liftIO getCurrentTime let resultDBTable = DBTable{..} where dbtSQLQuery cmpy = do let filterCmpy usrCmpy = usrCmpy E.^. UserCompanyCompany Ex.==. cmpy E.^. CompanyId cforeign = Ex.subSelectCount $ Ex.distinct $ do usrSuper <- Ex.from $ Ex.table @UserSupervisor Ex.where_ (Ex.exists $ do usrCmpy <- Ex.from $ Ex.table @UserCompany Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser ) E.&&. Ex.notExists (do usrCmpy <- Ex.from $ Ex.table @UserCompany Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor ) return $ usrSuper E.^. UserSupervisorSupervisor cusers = Ex.subSelectCount $ do usrCmpy <- Ex.from $ Ex.table @UserCompany Ex.where_ $ filterCmpy usrCmpy csupers = Ex.subSelectCount $ do usrCmpy <- Ex.from $ Ex.table @UserCompany Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanySupervisor whenIsJust mbUid $ \uid -> Ex.where_ $ Ex.exists $ do -- only show associated companies usrCmpy <- Ex.from $ Ex.table @UserCompany Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser Ex.==. E.val uid return (cmpy, csupers, cusers, cforeign) dbtRowKey = (Ex.^. CompanyShorthand) 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 Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $ foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder) , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart) , sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip) $ tickmarkCell . view (resultAllQualification . _qualificationExpiryNotification) , 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 -- -- 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 -- , 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, SecondaryJobs Inc" -- , qtcCompanyNumbers = CsvSemicolonList [27,69] -- , 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 MsgTableCompanies) -- , ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos) -- , ('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), [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 -- resultQualBlock :: Traversal' QualificationTableData (Entity QualificationUserBlock) -- resultQualBlock = _dbrOutput . _4 . _Just -- resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany] -- resultCompanyUser = _dbrOutput . _5 -- 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 -- 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 -- | QualificationActGrantData { qualTableActGrantUntil :: 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)) -- ) -- 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) -- 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 now qid fltrSvs -- dbtRowKey = queryUser >>> (E.^. UserId) -- dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> 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, qUsrBlock, cmpUsr) -- dbtColonnade = cols cmpMap -- dbtSorting = mconcat -- [ single $ sortUserNameLink queryUser -- , single $ sortUserEmail queryUser -- , single $ sortUserMatriclenr queryUser -- , single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) -- , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) -- , single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified)) -- , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) -- , single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) -- , single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay) -- , E.joinV (queryLmsUser row E.?. LmsUserNotified) -- , 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) -- ) -- -- , single ("validity", SortColumn $ queryQualUser >>> validQualification now) -- ] -- 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 now)) -- , 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 -- ) -- , single ("tobe-notified", FilterColumn $ \row criterion -> -- if | Just True <- getLast criterion -> quserToNotify now (queryQualUser row) (queryQualBlock row) -- | otherwise -> E.true -- ) -- , single ("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 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) -- , 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) -- <*> (view resultCompanyUser >>= getCompanies) -- <*> (view resultCompanyUser >>= getCompanyNos) -- <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) -- <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) -- <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not) -- <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom) -- <*> 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 . _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) <- runDB $ do -- qent@Entity{ -- entityKey=qid -- , entityVal=Qualification{ -- qualificationAuditDuration=auditMonths -- , qualificationValidDuration=validMonths -- }} <- getBy404 $ SchoolQualificationShort sid qsh -- -- 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 7 -- pure (qblock Ex.^. QualificationUserBlockReason) -- mkOption :: Ex.Value Text -> Option Text -- mkOption (Ex.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t } -- suggestionsBlock :: HandlerFor UniWorX (OptionList Text) -- suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons Ex.not_) -- suggestionsUnblock = mkOptionList . fmap mkOption <$> 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 $ pure QualificationActRenewData -- , singletonMap QualificationActGrant $ QualificationActGrantData -- <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry -- <* aformMessage msgGrantWarning -- ] isAdmin -- linkLmsUser = toMaybe isAdmin (LmsUserR sid qsh) -- linkUserName = bool ForProfileR ForProfileDataR 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 "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 -- , 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 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 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 -- (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")