993 lines
49 KiB
Haskell
993 lines
49 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
|
--
|
|
-- 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
|