From 9caf2af540c9c18e38bbbeb5c0b397e8b0a04f48 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 9 Oct 2023 07:24:01 +0000 Subject: [PATCH] chore(firm): initial stub --- .../utils/navigation/menu/de-de-formal.msg | 2 + .../uniworx/utils/navigation/menu/en-eu.msg | 2 + routes | 2 + src/Application.hs | 1 + src/Foundation/Navigation.hs | 3 + src/Handler/Firm.hs | 663 ++++++++++++++++++ 6 files changed, 673 insertions(+) create mode 100644 src/Handler/Firm.hs diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 5ea9b7e59..9e1c55f5a 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -133,6 +133,8 @@ MenuLmsFake: Testnutzer generieren MenuLmsLearners: Export Benutzer E‑Learning MenuLmsReport: Ergebnisse E‑Learning +MenuFirms: Firmen + MenuSap: SAP Schnittstelle MenuAvs: AVS Schnittstelle diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index b4a66104d..6145f0d81 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -134,6 +134,8 @@ MenuLmsFake: Generate Test Users MenuLmsLearners: E‑learning Users MenuLmsReport: E‑learning Results +MenuFirms: Companies + MenuSap: SAP Interface MenuAvs: AVS Interface diff --git a/routes b/routes index 7a68b54e3..e7f9fc7b9 100644 --- a/routes +++ b/routes @@ -113,6 +113,8 @@ /for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self +/firm FirmAllR GET +/firm/#CompanyShorthand FirmR GET POST /exam-office ExamOfficeR !exam-office: / EOExamsR GET POST !system-exam-office diff --git a/src/Application.hs b/src/Application.hs index 90d344bfd..45f24768e 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -159,6 +159,7 @@ import Handler.SAP import Handler.PrintCenter import Handler.ApiDocs import Handler.Swagger +import Handler.Firm import ServantApi () -- YesodSubDispatch instances import Servant.API diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 1dbc9384a..9fce295f5 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -123,6 +123,9 @@ breadcrumb ProblemFbutNoR = i18nCrumb MsgProblemsRWithoutFHeading $ Just breadcrumb ProblemAvsSynchR = i18nCrumb MsgProblemsAvsSynchHeading $ Just AdminProblemsR breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just ProblemAvsSynchR +breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing +breadcrumb FirmR = i18nCrumb MsgMenuFirms $ Just FirmAllR + breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload $ Just PrintCenterR diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs new file mode 100644 index 000000000..5d640d603 --- /dev/null +++ b/src/Handler/Firm.hs @@ -0,0 +1,663 @@ +-- 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 + + +getFirmAllR :: Handler Html +getFirmAllR = do + siteLayoutMsg MsgMenuFirms $ do + setTitleI MsgMenuFirms + [whamlet|STUB TO DO|] + + +getFirmR, postFirmR :: CompanyShorthand -> Handler Html +getFirmR = postFirmR +postFirmR _ = do + siteLayoutMsg MsgMenuFirms $ do + setTitleI MsgMenuFirms + [whamlet|STUB TO DO|] + + +-- isAdmin <- hasReadAccessTo AdminR +-- firmTable <- runDB $ do +-- view _2 <$> mkFirmAllTable isAdmin +-- siteLayoutMsg MsgMenuFirms $ do +-- setTitleI MsgMenuFirms +-- $(widgetFile "firm-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 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")