-- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Handler.Utils.Table.Columns where import Import hiding (link) -- import qualified Data.Map as Map import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E hiding ((->.)) import Database.Esqueleto.Utils (mkExactFilter, mkExactFilterWith, mkContainsFilter, mkContainsFilterWith, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus, anyFilter) --import Database.Esqueleto.Experimental ((:&)(..)) --import qualified Database.Esqueleto.Experimental as Ex import Handler.Utils.Table.Cells import Handler.Utils.Table.Pagination import Handler.Utils.Form import Handler.Utils.Widgets import Handler.Utils.DateTime import Handler.Utils.StudyFeatures import Handler.Utils.Avs (queryAvsCardNos) import Handler.Utils.Concurrent import qualified Data.CaseInsensitive as CI import qualified Colonnade import Colonnade.Encode (Colonnade(..), OneColonnade(..)) import Text.Blaze (toMarkup) import qualified Data.Set as Set -------------------------------- -- Generic Columns -- reuse encourages consistency -- -- The constant string for sort/filter keys -- should never be mentioned outside of this module -- to ensure consistency! -- -- Each section should have the following parts: -- * colXYZ : column definitions plus variants -- * sortXYZ : sorting definitions for these columns -- * fltrXYZ : filter definitions for these columns -- * additional helper, such as default sorting -------------------------------- type OpticColonnade focus = forall m x r' h. ( IsDBTable m x , FromSortable h ) => (forall focus'. Getting focus' r' focus) -> Colonnade h r' (DBCell m x) type OpticSortColumn' focus = forall t r' sortingMap. ( IsMap sortingMap , ContainerKey sortingMap ~ SortingKey , MapValue sortingMap ~ SortColumn t r' ) => (forall focus'. Getting focus' t focus) -> sortingMap type OpticSortColumn val = OpticSortColumn' (E.SqlExpr (E.Value val)) type OpticFilterColumn' t inp focus = forall fs filterMap. ( IsMap filterMap , ContainerKey filterMap ~ FilterKey , MapValue filterMap ~ FilterColumn t fs , IsFilterColumn t (t -> inp -> E.SqlExpr (E.Value Bool)) ) => (forall focus'. Getting focus' t focus) -> filterMap type OpticFilterColumn t focus = OpticFilterColumn' t (Set focus) (E.SqlExpr (E.Value focus)) ----------- -- Terms -- ----------- colTermShort :: OpticColonnade TermId colTermShort resultTid = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "term") (i18nCell MsgTableTerm) body = i18nCell . ShortTermIdentifier . unTermKey . view resultTid sortTerm :: OpticSortColumn TermId sortTerm queryTid = singletonMap "term" . SortColumn $ view queryTid fltrTerm :: OpticFilterColumn t TermId fltrTerm queryTid = singletonMap "term" . FilterColumn $ mkExactFilter (view queryTid) fltrTermUI :: DBFilterUI fltrTermUI mPrev = prismAForm (singletonFilter "term" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift termField) (fslI MsgTableTerm) ------------- -- Schools -- ------------- colSchool :: OpticColonnade SchoolId colSchool resultSsh = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "school") (i18nCell MsgTableSchool) body = i18nCell . unSchoolKey . view resultSsh sortSchool :: OpticSortColumn SchoolId sortSchool querySsh = singletonMap "school" . SortColumn $ view querySsh colSchoolShort :: OpticColonnade SchoolId colSchoolShort resultSsh = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "school-short") (i18nCell MsgTableSchoolShort) body = i18nCell . unSchoolKey . view resultSsh sortSchoolShort :: OpticSortColumn SchoolId sortSchoolShort querySsh = singletonMap "school-short" . SortColumn $ view querySsh colSchoolName :: OpticColonnade SchoolName colSchoolName resultSn = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "school-name") (i18nCell MsgTableSchoolName) body = i18nCell . view resultSn sortSchoolName :: OpticSortColumn SchoolName sortSchoolName querySn = singletonMap "school-name" . SortColumn $ view querySn fltrSchool :: OpticFilterColumn t SchoolId fltrSchool querySsh = singletonMap "school" . FilterColumn $ mkExactFilter (view querySsh) fltrSchoolUI :: DBFilterUI fltrSchoolUI mPrev = prismAForm (singletonFilter "school" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift schoolField) (fslI MsgTableSchool) ----------- -- Exams -- ----------- colExamName :: OpticColonnade ExamName colExamName resultName = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "exam-name") (i18nCell MsgTableExamName) body = views resultName i18nCell sortExamName :: OpticSortColumn ExamName sortExamName queryName = singletonMap "exam-name" . SortColumn $ view queryName colExamTime :: OpticColonnade (Maybe UTCTime, Maybe UTCTime) colExamTime resultTimes = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "exam-time") (i18nCell MsgTableExamTime) body = views resultTimes $ \(eStart, eEnd) -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) eEnd) eStart sortExamTime :: OpticSortColumn' (E.SqlExpr (E.Value (Maybe UTCTime)), E.SqlExpr (E.Value (Maybe UTCTime))) sortExamTime queryTimes = singletonMap "exam-time" . SortColumns . toListOf $ queryTimes . _1 . to SomeExprValue <> queryTimes . _2 . to SomeExprValue colExamClosed :: OpticColonnade (Maybe UTCTime) colExamClosed resultClosed = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "exam-closed") (i18nCell MsgUtilExamClosed) body = views resultClosed $ foldMap dateTimeCell sortExamClosed :: OpticSortColumn (Maybe UTCTime) sortExamClosed queryClosed = singletonMap "exam-closed" . SortColumn $ view queryClosed colExamFinished :: OpticColonnade (Maybe UTCTime) colExamFinished resultFinished = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "exam-finished") (i18nCell MsgTableExamFinished) body = views resultFinished $ foldMap dateTimeCell colExamFinishedOffice :: OpticColonnade (Maybe UTCTime) colExamFinishedOffice resultFinished = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "exam-finished") (i18nCell MsgExamFinishedOffice) body = views resultFinished $ foldMap dateTimeCell sortExamFinished :: OpticSortColumn (Maybe UTCTime) sortExamFinished queryFinished = singletonMap "exam-finished" . SortColumn $ view queryFinished colExamLabel :: OpticColonnade (Maybe ExamOfficeLabelName) colExamLabel resultLabel = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "exam-label") (i18nCell MsgTableExamLabel) body = views resultLabel $ maybe mempty i18nCell sortExamLabel :: OpticSortColumn (Maybe ExamOfficeLabelName) sortExamLabel queryLabel = singletonMap "exam-label" . SortColumn $ view queryLabel ---------------------- -- Exam occurrences -- ---------------------- colOccurrenceStart :: OpticColonnade UTCTime colOccurrenceStart resultStart = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "occurrence-start") (i18nCell MsgExamOccurrenceStart) body = views resultStart dateTimeCell sortOccurrenceStart :: PersistField utctime => OpticSortColumn utctime sortOccurrenceStart queryStart = singletonMap "occurrence-start" . SortColumn $ view queryStart ------------------ -- Exam results -- ------------------ colExamResult :: OpticColonnade ExamResultPassedGrade colExamResult resultResult = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "exam-result") (i18nCell MsgTableExamResult) body = views resultResult i18nCell sortExamResult :: OpticSortColumn (Maybe ExamResultPassedGrade) sortExamResult queryResult = singletonMap "exam-result" $ SortColumn $ view queryResult fltrExamResultPoints :: OpticFilterColumn' t (Set ExamResultPassedGrade) (E.SqlExpr (E.Value (Maybe ExamResultPassedGrade))) fltrExamResultPoints queryExamResult = singletonMap "exam-result" . FilterColumn $ \row criteria -> if | Set.null criteria -> E.true | otherwise -> view queryExamResult row `E.in_` E.valList (Just <$> Set.toList criteria) fltrExamResultPointsUI :: DBFilterUI fltrExamResultPointsUI mPrev = prismAForm (singletonFilter "exam-result" . maybePrism _PathPiece) mPrev $ aopt (examResultPassedGradeField . Just $ SomeMessage MsgTableNoFilter) (fslI MsgTableExamResult) ------------- -- Courses -- ------------- colCourseName :: OpticColonnade CourseName colCourseName resultName = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "course-name") (i18nCell MsgTableCourse) body = views resultName i18nCell sortCourseName :: OpticSortColumn CourseName sortCourseName queryName = singletonMap "course-name" . SortColumn $ view queryName --------------- -- Files --------------- -- | Generic column for links to FilePaths, where the link depends on the entire table row colFilePath :: (IsDBTable m c) => (t -> E.Value FilePath) -> (t -> Route UniWorX) -> Colonnade Sortable t (DBCell m c) colFilePath row2path row2link = sortable (Just "path") (i18nCell MsgTableFileTitle) makeCell where makeCell row = let filePath = E.unValue $ row2path row link = row2link row in anchorCell link $ str2widget filePath -- | Generic column for links to FilePaths, where the link only depends on the FilePath itself colFilePathSimple :: (IsDBTable m c) => (t -> E.Value FilePath) -> (FilePath -> Route UniWorX) -> Colonnade Sortable t (DBCell m c) colFilePathSimple row2path row2link = sortable (Just "path") (i18nCell MsgTableFileTitle) makeCell where makeCell row = let filePath = E.unValue $ row2path row link = row2link filePath in anchorCell link $ str2widget filePath -- | Generic column for File Modification colFileModification :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c) colFileModification row2time = sortable (Just "time") (i18nCell MsgTableFileModified) (dateTimeCell . E.unValue . row2time) colFileModificationWhen :: (IsDBTable m c) => (UTCTime -> Bool) -> (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c) colFileModificationWhen condition row2time = sortable (Just "time") (i18nCell MsgTableFileModified) (conDTCell . E.unValue . row2time) where conDTCell = ifCell condition dateTimeCell $ const mempty sortFilePath :: (IsFileReference record) => (t -> E.SqlExpr (Entity record)) -> (SortingKey, SortColumn t r') sortFilePath queryPath = ("path", SortColumn $ queryPath >>> (E.^. fileReferenceTitleField)) sortFileModification :: (IsFileReference record) => (t -> E.SqlExpr (Entity record)) -> (SortingKey, SortColumn t r') sortFileModification queryModification = ("time", SortColumn $ queryModification >>> (E.^. fileReferenceModifiedField)) defaultSortingByFileTitle :: PSValidator m x -> PSValidator m x defaultSortingByFileTitle = defaultSorting [SortAscBy "path"] defaultSortingByFileModification :: PSValidator m x -> PSValidator m x defaultSortingByFileModification = defaultSorting [SortAscBy "time"] --------------- -- User names --------------- colUserDisplayName :: OpticColonnade (UserDisplayName, UserSurname) colUserDisplayName resultDisplayName = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "user-name") (i18nCell MsgUserDisplayName) body = views resultDisplayName $ cell . uncurry nameWidget sortUserName' :: OpticSortColumn' (E.SqlExpr (E.Value UserDisplayName), E.SqlExpr (E.Value UserSurname)) sortUserName' queryDisplayName = singletonMap "user-name" . SortColumns $ \(view queryDisplayName -> (dn, sn)) -> [ SomeExprValue sn , SomeExprValue dn ] fltrUserName' :: OpticFilterColumn t UserDisplayName fltrUserName' queryDisplayName = singletonMap "user-name" . FilterColumn . mkContainsFilter $ view queryDisplayName fltrUserNameUI' :: DBFilterUI fltrUserNameUI' mPrev = prismAForm (singletonFilter "user-name") mPrev $ aopt textField (fslI MsgUserDisplayName) colUserSex :: OpticColonnade (Maybe Sex) colUserSex resultSex = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "user-sex") (i18nCell MsgTableSex) body = views resultSex $ maybe mempty i18nCell sortUserSex :: OpticSortColumn (Maybe Sex) sortUserSex querySex = singletonMap "user-sex" . SortColumn $ view querySex fltrUserSex :: OpticFilterColumn' t (Set Sex) (E.SqlExpr (E.Value (Maybe Sex))) fltrUserSex querySex = singletonMap "user-sex" . FilterColumn $ mkExactFilterWith Just (view querySex) fltrUserSexUI :: DBFilterUI fltrUserSexUI mPrev = prismAForm (singletonFilter "user-sex" . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler $ selectField optionsFinite :: Field _ Sex) (fslI MsgTableSex) colUserName :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c) colUserName = sortable (Just "user-name") (i18nCell MsgTableCourseMembers) cellHasUser colUserNameLink :: (IsDBTable m c, HasEntity a User) => (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c) colUserNameLink = colUserNameLinkHdr MsgTableCourseMembers colUserNameLinkHdr :: (IsDBTable m c, HasEntity a User, RenderMessage UniWorX msg) => msg -> (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c) colUserNameLinkHdr colHeader userLink = sortable (Just "user-name") (i18nCell colHeader) (cellHasUserLink userLink) colUserNameModalHdr :: (IsDBTable m c, HasEntity a User, RenderMessage UniWorX msg) => msg -> (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c) colUserNameModalHdr colHeader userLink = sortable (Just "user-name") (i18nCell colHeader) (cellHasUserModal userLink) -- | like `colUserNameModalHdr` but without checking access rights before displaying the link (no risk, but non-admins may see links that are unusable for them) colUserNameModalHdrAdmin :: (IsDBTable m c, HasEntity a User, RenderMessage UniWorX msg) => msg -> (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c) colUserNameModalHdrAdmin colHeader userLink = sortable (Just "user-name") (i18nCell colHeader) (cellHasUserModalAdmin userLink) -- | Intended to work with @nameWidget@, showing highlighter Surname within Displayname sortUserName :: (t -> E.SqlExpr (Entity User)) -> (SortingKey, SortColumn t r') sortUserName = ("user-name",) . sortUserNameBare sortUserNameBare :: (t -> E.SqlExpr (Entity User)) -> SortColumn t r' sortUserNameBare queryUser = SortColumns $ queryUser >>> \user -> [ SomeExprValue $ user E.^. UserSurname , SomeExprValue $ user E.^. UserDisplayName ] sortUserNameBareM :: (t -> E.SqlExpr (Maybe (Entity User))) -> SortColumn t r' sortUserNameBareM queryUser = SortColumns $ queryUser >>> \user -> [ SomeExprValue $ user E.?. UserSurname , SomeExprValue $ user E.?. UserDisplayName ] -- | Alias for sortUserName for consistency, since column comes in two variants sortUserNameLink :: (t -> E.SqlExpr (Entity User)) -> (SortingKey, SortColumn t r') sortUserNameLink = sortUserName sortUserSurname :: (t -> E.SqlExpr (Entity User)) -> (SortingKey, SortColumn t r') sortUserSurname queryUser = ("user-surname", SortColumn $ queryUser >>> (E.^. UserSurname)) sortUserDisplayName :: (t -> E.SqlExpr (Entity User)) -> (SortingKey, SortColumn t r') sortUserDisplayName queryUser = ("user-display-name", SortColumn $ queryUser >>> (E.^. UserDisplayName)) defaultSortingByName :: PSValidator m x -> PSValidator m x defaultSortingByName = -- defaultSorting [SortAscBy "user-surname", SortAscBy "user-display-name"] -- old way, requiring two exta sorters defaultSorting [SortAscBy "user-name"] -- new way, working with single sorter -- | Alias for sortUserName for consistency fltrUserNameLink :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (Entity User)) -> (FilterKey, FilterColumn t fs) fltrUserNameLink = fltrUserName fltrUserName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (Entity User)) -> (FilterKey, FilterColumn t fs) fltrUserName queryUser = ( "user-name", FilterColumn $ mkContainsFilter queryName ) where queryName = queryUser >>> (E.^. UserDisplayName) fltrUserNameExact :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (Entity User)) -> (FilterKey, FilterColumn t fs) fltrUserNameExact queryUser = ( "user-name", FilterColumn $ mkExactFilter queryName ) where queryName = queryUser >>> (E.^. UserDisplayName) fltrUserSurname :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (Entity User)) -> (FilterKey, FilterColumn t fs) fltrUserSurname queryUser = ( "user-surname", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserSurname)) fltrUserDisplayName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (Entity User)) -> (FilterKey, FilterColumn t fs) fltrUserDisplayName queryUser = ( "user-display-name", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName)) -- | Search all names, i.e. DisplayName, Surname, EMail fltrUserNameEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (Entity User)) -> (FilterKey, FilterColumn t fs) fltrUserNameEmail queryUser = ( "user-name-email", FilterColumn $ anyFilter [ mkContainsFilterWithCommaPlus id $ queryUser >>> (E.^. UserDisplayName) , mkContainsFilterWithCommaPlus id $ queryUser >>> (E.^. UserSurname) , mkContainsFilterWithCommaPlus CI.mk $ queryUser >>> (E.^. UserDisplayEmail) ] ) fltrUserNameUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrUserNameUI = fltrUserNameLinkUI fltrUserNameLinkUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrUserNameLinkUI = fltrUserNameLinkHdrUI MsgTableCourseMembers fltrUserNameLinkHdrUI :: (RenderMessage UniWorX msg) => msg -> Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrUserNameLinkHdrUI msg mPrev = prismAForm (singletonFilter "user-name") mPrev $ aopt textField (fslI msg) fltrUserDisplayNameHdrUI :: (RenderMessage UniWorX msg) => msg -> Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrUserDisplayNameHdrUI msg mPrev = prismAForm (singletonFilter "user-display-name") mPrev $ aopt textField (fslI msg) fltrUserNameEmailUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrUserNameEmailUI = fltrUserNameEmailHdrUI MsgTableCourseMembers fltrUserNameEmailHdrUI :: (RenderMessage UniWorX msg) => msg -> Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrUserNameEmailHdrUI msg mPrev = prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI msg & setTooltip MsgTableFilterCommaPlus) ------------------- -- Matriculation -- ------------------- colUserMatriculation :: OpticColonnade (Maybe UserMatriculation) colUserMatriculation resultMatriculation = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "user-matriculation") (i18nCell MsgTableUserMatriculation) body = views resultMatriculation . maybe mempty $ cell . toWidget sortUserMatriculation :: OpticSortColumn (Maybe UserMatriculation) sortUserMatriculation queryMatriculation = singletonMap "user-matriculation" . SortColumn $ view queryMatriculation fltrUserMatriculation :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value (Maybe UserMatriculation))) fltrUserMatriculation queryMatriculation = singletonMap "user-matriculation" . FilterColumn . mkContainsFilterWithComma Just $ view queryMatriculation fltrUserMatriculationUI :: DBFilterUI fltrUserMatriculationUI mPrev = prismAForm (singletonFilter "user-matriculation") mPrev $ aopt textField (fslI MsgTableUserMatriculation) colUserMatriclenr :: (IsDBTable m c, HasEntity a User) => Bool -> Colonnade Sortable a (DBCell m c) colUserMatriclenr isAdmin = sortable (Just "user-matriclenumber") (i18nCell MsgTableMatrikelNr) $ cellHasMatrikelnummerLinked isAdmin sortUserMatriclenr :: (t -> E.SqlExpr (Entity User)) -> (SortingKey, SortColumn t r') sortUserMatriclenr queryUser = ("user-matriclenumber", SortColumn $ queryUser >>> (E.^. UserMatrikelnummer)) fltrUserMatriclenr :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (Entity User)) -> (FilterKey, FilterColumn t fs) fltrUserMatriclenr queryUser = ("user-matriclenumber", FilterColumn . mkContainsFilterWithComma Just $ queryUser >>> (E.^. UserMatrikelnummer)) fltrUserMatriclenrUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrUserMatriclenrUI mPrev = prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgTableMatrikelNr & setTooltip MsgTableFilterComma) ---------------- -- User E-Mail ---------------- colUserEmail :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c) colUserEmail = sortable (Just "user-email") (i18nCell MsgTableEmail) cellHasEMail sortUserEmail :: (t -> E.SqlExpr (Entity User)) -> (SortingKey, SortColumn t r') sortUserEmail queryUser = ( "user-email", SortColumn $ queryUser >>> (E.^. UserDisplayEmail)) fltrUserEmail :: ( IsFilterColumn t (a -> Set (CI Text) -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (Entity User)) -> (FilterKey, FilterColumn t fs) fltrUserEmail queryUser = ("user-email", FilterColumn . mkContainsFilter $ queryUser >>> (E.^. UserDisplayEmail)) fltrUserEmailUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrUserEmailUI mPrev = prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgTableEmail) -- | Icon column showing whether the user prefers emails, and if so, whether a pdf password is set colUserLetterEmailPin :: (IsDBTable m c, HasEntity a User) => Colonnade Sortable a (DBCell m c) colUserLetterEmailPin = sortable (Just "user-mail-pref-pin") (i18nCell MsgPrefersPostal) cellMailPrefPin sortUserLetterEmailPin :: (t -> E.SqlExpr (Entity User)) -> (SortingKey, SortColumn t r') sortUserLetterEmailPin queryUser = ( "user-mail-pref-pin" , SortColumn (toSortVal . queryUser)) where toSortVal :: E.SqlExpr (Entity User) -> E.SqlExpr (E.Value Int64) toSortVal usr = E.case_ [ E.when_ ( usr E.^. UserPrefersPostal) E.then_ (E.val 1) , E.when_ (E.isJust $ usr E.^. UserPinPassword) E.then_ (E.val 2) ] (E.else_ (E.val 3)) -------------------- -- Study features -- -------------------- colStudyDegree :: OpticColonnade StudyDegree colStudyDegree resultDegree = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "features-degree") (i18nCell MsgTableStudyFeatureDegree) body = views resultDegree $ \StudyDegree{..} -> cell . maybe (toWidget $ toMarkup studyDegreeKey) toWidget $ studyDegreeShorthand <|> studyDegreeName sortStudyDegree :: forall studyDegree name shorthand key. ( E.SqlProject StudyDegree (Maybe StudyDegreeName) studyDegree name , E.SqlProject StudyDegree (Maybe StudyDegreeShorthand) studyDegree shorthand , E.SqlProject StudyDegree StudyDegreeKey studyDegree key , PersistField key, PersistField name, PersistField shorthand ) => OpticSortColumn' (E.SqlExpr studyDegree) sortStudyDegree queryDegree = singletonMap "features-degree" . SortColumns $ \(view queryDegree -> degree) -> [ SomeExprValue $ degree `E.sqlProject` StudyDegreeName , SomeExprValue $ degree `E.sqlProject` StudyDegreeShorthand , SomeExprValue $ degree `E.sqlProject` StudyDegreeKey ] fltrStudyDegree :: forall studyDegree t name shorthand key. ( E.SqlProject StudyDegree (Maybe StudyDegreeName) studyDegree name , E.SqlProject StudyDegree (Maybe StudyDegreeShorthand) studyDegree shorthand , E.SqlProject StudyDegree StudyDegreeKey studyDegree key , E.SqlString name, E.SqlString shorthand, PersistField key ) => OpticFilterColumn' t (Set Text) (E.SqlExpr studyDegree) fltrStudyDegree queryDegree = singletonMap "features-degree" . FilterColumn $ anyFilter [ mkContainsFilterWith (unSqlProject' . Just) $ view queryDegree >>> (`E.sqlProject` StudyDegreeName) , mkContainsFilterWith (unSqlProject' . Just) $ view queryDegree >>> (`E.sqlProject` StudyDegreeShorthand) , mkExactFilterWith (fmap unSqlProject' . (readMay :: Text -> Maybe StudyDegreeKey)) $ view queryDegree >>> (`E.sqlProject` StudyDegreeKey) >>> E.just ] where unSqlProject' :: E.SqlProject StudyDegree value studyDegree value' => value -> value' unSqlProject' = E.unSqlProject (Proxy @StudyDegree) (Proxy @studyDegree) fltrStudyDegreeUI :: DBFilterUI fltrStudyDegreeUI mPrev = prismAForm (singletonFilter "features-degree") mPrev $ aopt textField (fslI MsgTableStudyFeatureDegree) colStudyTerms :: OpticColonnade StudyTerms colStudyTerms resultTerms = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "features-terms") (i18nCell MsgTableStudyTerm) body = views resultTerms $ \StudyTerms{..} -> cell . maybe (toWidget $ toMarkup studyTermsKey) toWidget $ studyTermsShorthand <|> studyTermsName sortStudyTerms :: forall studyTerms name shorthand key. ( E.SqlProject StudyTerms (Maybe StudyTermsName) studyTerms name , E.SqlProject StudyTerms (Maybe StudyTermsShorthand) studyTerms shorthand , E.SqlProject StudyTerms StudyTermsKey studyTerms key , PersistField key, PersistField name, PersistField shorthand ) => OpticSortColumn' (E.SqlExpr studyTerms) sortStudyTerms queryTerms = singletonMap "features-terms" . SortColumns $ \(view queryTerms -> terms) -> [ SomeExprValue $ terms `E.sqlProject` StudyTermsName , SomeExprValue $ terms `E.sqlProject` StudyTermsShorthand , SomeExprValue $ terms `E.sqlProject` StudyTermsKey ] fltrStudyTerms :: forall studyTerms t name shorthand key. ( E.SqlProject StudyTerms (Maybe StudyTermsName) studyTerms name , E.SqlProject StudyTerms (Maybe StudyTermsShorthand) studyTerms shorthand , E.SqlProject StudyTerms StudyTermsKey studyTerms key , E.SqlString name, E.SqlString shorthand, PersistField key ) => OpticFilterColumn' t (Set Text) (E.SqlExpr studyTerms) fltrStudyTerms queryTerms = singletonMap "features-terms" . FilterColumn $ anyFilter [ mkContainsFilterWith (unSqlProject' . Just) $ view queryTerms >>> (`E.sqlProject` StudyTermsName) , mkContainsFilterWith (unSqlProject' . Just) $ view queryTerms >>> (`E.sqlProject` StudyTermsShorthand) , mkExactFilterWith (fmap unSqlProject' . (readMay :: Text -> Maybe StudyTermsKey)) $ view queryTerms >>> (`E.sqlProject` StudyTermsKey) >>> E.just ] where unSqlProject' :: E.SqlProject StudyTerms value studyTerms value' => value -> value' unSqlProject' = E.unSqlProject (Proxy @StudyTerms) (Proxy @studyTerms) fltrStudyTermsUI :: DBFilterUI fltrStudyTermsUI mPrev = prismAForm (singletonFilter "features-terms") mPrev $ aopt textField (fslI MsgTableStudyTerm) colStudyFeaturesSemester :: OpticColonnade Int colStudyFeaturesSemester resultSemester = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "features-semester") (i18nCell MsgTableStudyFeatureAge) body = views resultSemester $ cell . toWidget . toMarkup sortStudyFeaturesSemester :: forall semester. PersistField semester => OpticSortColumn semester sortStudyFeaturesSemester querySemester = singletonMap "features-semester" . SortColumn $ view querySemester fltrStudyFeaturesSemester :: forall studyFeatures t semester. ( E.SqlProject StudyFeatures Int studyFeatures semester , PersistField semester ) => OpticFilterColumn' t (Set Int) (E.SqlExpr (E.Value semester)) fltrStudyFeaturesSemester querySemester = singletonMap "features-semester" . FilterColumn . mkExactFilterWith unSqlProject' $ view querySemester where unSqlProject' :: Int -> semester unSqlProject' = E.unSqlProject (Proxy @StudyFeatures) (Proxy @studyFeatures) fltrStudyFeaturesSemesterUI :: DBFilterUI fltrStudyFeaturesSemesterUI mPrev = prismAForm (singletonFilter "features-semester" . maybePrism _PathPiece) mPrev $ aopt (intField :: Field _ Int) (fslI MsgTableStudyFeatureAge) colFeaturesSemester :: (IsDBTable m c, HasStudyFeatures x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c) colFeaturesSemester feature = sortable (Just "features-semester") (i18nCell MsgTableStudyFeatureAge) $ maybe mempty cellHasSemester . firstOf feature sortFeaturesSemester :: (t -> E.SqlExpr (Maybe (Entity StudyFeatures))) -> (SortingKey, SortColumn t r') sortFeaturesSemester queryFeatures = ("features-semester", SortColumn $ queryFeatures >>> (E.?. StudyFeaturesSemester)) fltrFeaturesSemester :: ( IsFilterColumn t (a -> Set Int -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (Maybe (Entity StudyFeatures))) -> (FilterKey, FilterColumn t fs) fltrFeaturesSemester queryFeatures = ("features-semester", FilterColumn . mkExactFilterWith Just $ queryFeatures >>> (E.?. StudyFeaturesSemester)) fltrFeaturesSemesterUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrFeaturesSemesterUI mPrev = prismAForm (singletonFilter "features-semester" . maybePrism _PathPiece) mPrev $ aopt (intField :: Field (YesodDB UniWorX) Int) (fslI MsgTableStudyFeatureAge) colField :: (IsDBTable m c, HasStudyTerms x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c) colField terms = sortable (Just "terms") (i18nCell MsgTableStudyTerm) $ maybe mempty cellHasField . firstOf terms sortField :: (t -> E.SqlExpr (Maybe (Entity StudyTerms))) -> (SortingKey, SortColumn t r') sortField queryTerms = ("terms", SortColumn $ queryTerms >>> (E.?. StudyTermsName)) fltrField :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (Maybe (Entity StudyTerms))) -> (FilterKey, FilterColumn t fs) fltrField queryFeatures = ( "terms" , FilterColumn $ anyFilter [ mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyTermsName) , mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyTermsShorthand) , mkExactFilterWith readMay $ queryFeatures >>> (E.?. StudyTermsKey) ] ) fltrFieldUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrFieldUI mPrev = prismAForm (singletonFilter "terms") mPrev $ aopt textField (fslI MsgTableStudyTerm) colDegreeShort :: (IsDBTable m c, HasStudyDegree x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c) colDegreeShort terms = sortable (Just "degree-short") (i18nCell MsgTableDegreeShort) $ maybe mempty cellHasDegreeShort . firstOf terms sortDegreeShort :: (t -> E.SqlExpr (Maybe (Entity StudyDegree))) -> (SortingKey, SortColumn t r') sortDegreeShort queryTerms = ("degree-short", SortColumn $ queryTerms >>> (E.?. StudyDegreeShorthand)) fltrDegree :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (Maybe (Entity StudyDegree))) -> (FilterKey, FilterColumn t fs) fltrDegree queryFeatures = ( "degree" , FilterColumn $ anyFilter [ mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyDegreeName) , mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyDegreeShorthand) , mkExactFilterWith readMay $ queryFeatures >>> (E.?. StudyDegreeKey) ] ) fltrDegreeUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrDegreeUI mPrev = prismAForm (singletonFilter "degree") mPrev $ aopt textField (fslI MsgTableDegreeName) colStudyFeatures :: OpticColonnade UserTableStudyFeatures colStudyFeatures resultFeatures = Colonnade.singleton (fromSortable header) body where header = Sortable Nothing (i18nCell MsgTableColumnStudyFeatures) body = views (resultFeatures . _UserTableStudyFeatures) . flip listCell $ \UserTableStudyFeature{..} -> cell $(widgetFile "table/cell/user-study-feature") fltrRelevantStudyFeaturesTerms :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId)) fltrRelevantStudyFeaturesTerms queryTermUser = singletonMap "features-terms" . FilterColumn $ \t criterias -> E.subSelectOr . E.from $ \(term `E.InnerJoin` studyFeatures) -> do E.on $ isTermStudyFeature term studyFeatures let (tid, uid) = t ^. queryTermUser E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. uid E.&&. term E.^. TermId E.==. tid return $ anyFilter [ mkContainsFilterWith Just $ \t' -> E.subSelectForeign t' StudyFeaturesField (E.^. StudyTermsName) , mkContainsFilterWith Just $ \t' -> E.subSelectForeign t' StudyFeaturesField (E.^. StudyTermsShorthand) , mkExactFilterWith readMay $ \t' -> E.subSelectForeign t' StudyFeaturesField $ E.just . (E.^. StudyTermsKey) ] studyFeatures criterias fltrRelevantStudyFeaturesTermsUI :: DBFilterUI fltrRelevantStudyFeaturesTermsUI = fltrStudyTermsUI fltrRelevantStudyFeaturesDegree :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId)) fltrRelevantStudyFeaturesDegree queryTermUser = singletonMap "features-degree" . FilterColumn $ \t criterias -> E.subSelectOr . E.from $ \(term `E.InnerJoin` studyFeatures) -> do E.on $ isTermStudyFeature term studyFeatures let (tid, uid) = t ^. queryTermUser E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. uid E.&&. term E.^. TermId E.==. tid return $ anyFilter [ mkContainsFilterWith Just $ \t' -> E.subSelectForeign t' StudyFeaturesDegree (E.^. StudyDegreeName) , mkContainsFilterWith Just $ \t' -> E.subSelectForeign t' StudyFeaturesDegree (E.^. StudyDegreeShorthand) , mkExactFilterWith readMay $ \t' -> E.subSelectForeign t' StudyFeaturesDegree $ E.just . (E.^. StudyDegreeKey) ] studyFeatures criterias fltrRelevantStudyFeaturesDegreeUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrRelevantStudyFeaturesDegreeUI mPrev = prismAForm (singletonFilter "features-degree") mPrev $ aopt textField (fslI MsgTableDegreeName) fltrRelevantStudyFeaturesSemester :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId)) fltrRelevantStudyFeaturesSemester queryTermUser = singletonMap "features-semester" . FilterColumn $ \t criterias -> E.subSelectOr . E.from $ \(term `E.InnerJoin` studyFeatures) -> do E.on $ isTermStudyFeature term studyFeatures let (tid, uid) = t ^. queryTermUser E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. uid E.&&. term E.^. TermId E.==. tid return $ mkExactFilterWith (readMay :: Text -> Maybe Int) (E.just . (E.^. StudyFeaturesSemester)) studyFeatures criterias fltrRelevantStudyFeaturesSemesterUI :: DBFilterUI fltrRelevantStudyFeaturesSemesterUI = fltrFeaturesSemesterUI -------------------- -- Qualifications -------------------- fltrQualification :: OpticFilterColumn t QualificationShorthand fltrQualification queryQual = singletonMap "qualification" . FilterColumn $ mkExactFilter (view queryQual) fltrQualificationUI :: DBFilterUI fltrQualificationUI = fltrQualificationHdrUI MsgTableQualification fltrQualificationHdrUI :: (RenderMessage UniWorX msg) => msg -> DBFilterUI fltrQualificationHdrUI msg mPrev = prismAForm (singletonFilter "qualification" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift qualificationFieldShort) (fslI msg) --------------- -- Companies -- --------------- {- -- colUserCompany :: (HandlerSite (DBCell m) ~ UniWorX, IsDBTable m c, HasEntity a User) => Colonnade Sortable a (DBCell m c) colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \heu -> do let uid = heu ^. hasEntity . _entityKey companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) let companies = intersperse (text2markup ", ") $ (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' icnSuper = text2markup " " <> icon IconSupervisor cell $ toWgt $ mconcat companies -} -- PROBLEM: how to type sqlCell compatible with dbTable that as actions, i.e. MForm instead of YesodDB? colUserCompany :: (IsDBTable (YesodDB UniWorX) c, HasEntity a User) => Colonnade Sortable a (DBCell (YesodDB UniWorX) c) colUserCompany = sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \heu -> let uid = heu ^. hasEntity . _entityKey in sqlCell $ do companies' <- E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) let companies = intersperse (text2markup ", ") $ (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' icnSuper = text2markup " " <> icon IconSupervisor pure $ toWgt $ mconcat companies sortUserCompany :: (t -> E.SqlExpr (Entity User)) -> (SortingKey, SortColumn t r') sortUserCompany queryUser = ( "user-company" , SortColumn $ queryUser >>> (\user -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. user E.^. UserId E.orderBy [E.asc (comp E.^. CompanyName)] return (comp E.^. CompanyName) )) -- | Search companies by name or shorthand fltrCompanyName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (Entity Company)) -> (FilterKey, FilterColumn t fs) fltrCompanyName query = ( "company-name", FilterColumn $ anyFilter [ mkContainsFilterWithComma CI.mk $ query >>> (E.^. CompanyName) , mkContainsFilterWithComma CI.mk $ query >>> (E.^. CompanyShorthand) -- , mkExactFilterWithComma id $ query >>> (E.num2text . (E.^. CompanyAvsId)) ] ) fltrCompanyNameUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrCompanyNameUI = fltrCompanyNameNrHdrUI MsgTableCompany fltrCompanyNameHdrUI :: (RenderMessage UniWorX msg) => msg -> Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrCompanyNameHdrUI msg mPrev = prismAForm (singletonFilter "company-name") mPrev $ aopt textField (fslI msg & setTooltip MsgTableFilterCommaNameNr) fltrCompanyNameNr :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (Entity Company)) -> (FilterKey, FilterColumn t fs) fltrCompanyNameNr query = ("company-name-number", FilterColumn $ \needle (setFoldMap commaSeparatedText -> criterias) -> let numCrits = setMapMaybe readMay criterias fltrCName = mkContainsFilterWith CI.mk (query >>> (E.^. CompanyName)) needle criterias fltrCShort = mkContainsFilterWith CI.mk (query >>> (E.^. CompanyShorthand)) needle criterias fltrCno = mkExactFilter (query >>> (E.^. CompanyAvsId)) needle numCrits in if null numCrits then fltrCName E.||. fltrCShort else fltrCName E.||. fltrCShort E.||. fltrCno ) where setFoldMap :: (Text -> Set.Set Text) -> Set.Set Text -> Set.Set Text setFoldMap = foldMap fltrCompanyNameNrUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrCompanyNameNrUI = fltrCompanyNameNrHdrUI MsgTableCompanyFilter fltrCompanyNameNrHdrUI :: (RenderMessage UniWorX msg) => msg -> Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrCompanyNameNrHdrUI msg mPrev = prismAForm (singletonFilter "company-name-number") mPrev $ aopt textField (fslI msg & setTooltip MsgTableFilterCommaNameNr) fltrCompanyNameNrUsrHdrUI :: (RenderMessage UniWorX msg) => FilterKey -> msg -> Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrCompanyNameNrUsrHdrUI fk msg mPrev = prismAForm (singletonFilter fk) mPrev $ aopt textField (fslI msg & setTooltip MsgTableFilterCommaNameNr) fltrCompanyNameNrUsr :: (IsFilterColumn t (a -> Set (CI Text) -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (E.Value (Key User))) -> FilterColumn t fs fltrCompanyNameNrUsr query = FilterColumn . E.mkExistsFilter $ \(query -> user) 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.==. user E.&&. testcrit fltrCompanyShortNrUsr :: (IsFilterColumn t (a -> Set (CI Text) -> E.SqlExpr (E.Value Bool))) => (a -> E.SqlExpr (E.Value (Key User))) -> FilterColumn t fs fltrCompanyShortNrUsr query = FilterColumn . E.mkExistsFilter $ \(query -> user) 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.^. CompanyShorthand) :: 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.==. user E.&&. testcrit --------- -- AVS -- --------- fltrAVSCardNos :: (IsFilterColumnHandler t ([Text] -> Handler (a -> E.SqlExpr (E.Value Bool)))) => (a -> E.SqlExpr (Entity User)) -> (FilterKey, FilterColumn t fs) fltrAVSCardNos queryUser = ("avs-card", fch) where fch = FilterColumnHandler $ \case [] -> return (const E.true) cs -> do let crds = mapMaybe parseAvsCardNo $ foldMap anySeparatedText cs toutsecs <- getsYesod $ preview $ _appAvsConf . _Just . _avsTimeout maybeTimeoutHandler toutsecs (try $ queryAvsCardNos crds) >>= \case Nothing -> addMessageI Error MsgAvsCommunicationTimeout >> return (const E.false) (Just (Left err)) -> addMessage Error (someExc2Html err) >> return (const E.false) (Just (Right (null -> True))) -> return (const E.false) (Just (Right apids)) -> return $ \(queryUser -> user) -> E.exists $ E.from $ \usrAvs -> E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId E.&&. usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids someExc2Html :: SomeException -> Html someExc2Html (SomeException e) = text2Html $ tshow e fltrAVSCardNosUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) fltrAVSCardNosUI mPrev = prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo & setTooltip (SomeMsgs [SomeMessage MsgTableFilterComma, SomeMessage MsgAvsQueryNeeded])) ---------------------------- -- Colonnade manipulation -- ---------------------------- imapColonnade :: (a -> c -> c) -> Colonnade h a c -> Colonnade h a c -- ^ Not quite `imap` imapColonnade f (Colonnade ones) = Colonnade $ dimapColonnade' <$> ones where dimapColonnade' OneColonnade{..} = OneColonnade { oneColonnadeEncode = \x -> f x $ oneColonnadeEncode x , oneColonnadeHead } anchorColonnade :: forall h r' m a url. ( HasRoute UniWorX url , IsDBTable m a , HandlerSite m ~ UniWorX ) => (r' -> url) -> Colonnade h r' (DBCell m a) -> Colonnade h r' (DBCell m a) anchorColonnade = anchorColonnadeM . (return .) anchorColonnadeM :: forall h r' m a url. ( HasRoute UniWorX url , IsDBTable m a , HandlerSite m ~ UniWorX ) => (r' -> WidgetFor UniWorX url) -> Colonnade h r' (DBCell m a) -> Colonnade h r' (DBCell m a) anchorColonnadeM mkUrl = imapColonnade anchorColonnade' where anchorColonnade' :: r' -> DBCell m a -> DBCell m a anchorColonnade' inp (view dbCell -> (attrs, act)) = review dbCell . (attrs,) $ view (dbCell . _2) . anchorCellM (mkUrl inp) =<< act maybeAnchorColonnade :: forall h r' m a url. ( HasRoute UniWorX url , IsDBTable m a , HandlerSite m ~ UniWorX ) => (r' -> Maybe url) -> Colonnade h r' (DBCell m a) -> Colonnade h r' (DBCell m a) maybeAnchorColonnade = maybeAnchorColonnadeM . (hoistMaybe .) maybeAnchorColonnadeM :: forall h r' m a url. ( HasRoute UniWorX url , IsDBTable m a , HandlerSite m ~ UniWorX ) => (r' -> MaybeT (WidgetFor UniWorX) url) -> Colonnade h r' (DBCell m a) -> Colonnade h r' (DBCell m a) maybeAnchorColonnadeM mkUrl = imapColonnade anchorColonnade' where anchorColonnade' :: r' -> DBCell m a -> DBCell m a anchorColonnade' inp (view dbCell -> (attrs, act)) = review dbCell . (attrs,) $ view (dbCell . _2) . maybeAnchorCellM (mkUrl inp) =<< act emptyOpticColonnade :: forall h r' focus c. Monoid c => Getting (Endo [focus]) r' focus -- ^ View on @focus@ within @r'@ that may produce any number of results -> ((forall focus'. Getting focus' r' focus) -> Colonnade h r' c) -- ^ `OpticColonnade focus` -> Colonnade h r' c -- ^ Generalize an `OpticColonnade` from `Getter` to `Fold` by defaulting results of zero values to `mempty` emptyOpticColonnade = emptyOpticColonnade' mempty emptyOpticColonnade' :: forall h r' focus c. c -> Getting (Endo [focus]) r' focus -- ^ View on @focus@ within @r'@ that may produce any number of results -> ((forall focus'. Getting focus' r' focus) -> Colonnade h r' c) -- ^ `OpticColonnade focus` -> Colonnade h r' c -- ^ Generalize an `OpticColonnade` from `Getter` to `Fold` by defaulting results of zero values emptyOpticColonnade' defC l' c = Colonnade $ oldColonnade <&> \column -> column { oneColonnadeEncode = \s -> defaultColumn s $ oneColonnadeEncode column } where l :: Fold r' focus l = folding (toListOf l') Colonnade oldColonnade = c $ singular l -- This is safe (as long as we don't evaluate the `oneColonnadeEncode`s) -- because `Getter s a` is of kind @k -> *@ and can thus only be inspected -- by @c@ through application which is precluded by the type of `Getter s a` -- and the definition of `OneColonnade` defaultColumn :: r' -> (r' -> c) -> c defaultColumn x f | has l x = f x | otherwise = defC maybeOpticSortColumn :: OpticSortColumn (Maybe val) -> OpticSortColumn val maybeOpticSortColumn sortColumn = \queryFocus -> sortColumn $ queryFocus . to E.just