285 lines
14 KiB
Haskell
285 lines
14 KiB
Haskell
module Handler.Utils.Table.Columns where
|
|
|
|
import Import
|
|
|
|
-- import Data.CaseInsensitive (CI)
|
|
-- import qualified Data.CaseInsensitive as CI
|
|
|
|
-- import Data.Monoid (Any(..))
|
|
-- import Control.Monad.Writer.Class (MonadWriter(..))
|
|
-- import Control.Monad.Trans.Writer (WriterT)
|
|
|
|
-- import Text.Blaze (ToMarkup(..))
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import Database.Esqueleto.Utils as E
|
|
|
|
import Utils.Lens
|
|
import Handler.Utils
|
|
import Handler.Utils.Table.Cells
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
|
|
--------------------------------
|
|
-- 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
|
|
|
|
|
|
-----------------------
|
|
-- Numbers and Indices
|
|
|
|
-- | Simple index column, also indicating whether there is a row at all
|
|
-- For a version without indication, use `Handler.Utils.Pagination.dbRow` instead.
|
|
dbRowIndicator :: IsDBTable m Any => Colonnade Sortable (DBRow r) (DBCell m Any)
|
|
dbRowIndicator = sortable Nothing (i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> tellCell (Any True) $ textCell $ tshow dbrIndex
|
|
|
|
|
|
---------------
|
|
-- 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 MsgFileTitle) 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 MsgFileTitle) 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 MsgFileModified) (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 MsgFileModified) (conDTCell . E.unValue . row2time)
|
|
where conDTCell = ifCell condition dateTimeCell $ const mempty
|
|
|
|
|
|
sortFilePath :: IsString s => (r -> E.SqlExpr (Entity File)) -> (s, SortColumn r)
|
|
sortFilePath queryPath = ("path", SortColumn $ queryPath >>> (E.^. FileTitle))
|
|
|
|
sortFileModification :: IsString s => (r -> E.SqlExpr (Entity File)) -> (s, SortColumn r)
|
|
sortFileModification queryModification = ("time", SortColumn $ queryModification >>> (E.^. FileModified))
|
|
|
|
defaultSortingByFileTitle :: PSValidator m x -> PSValidator m x
|
|
defaultSortingByFileTitle = defaultSorting [SortAscBy "path"]
|
|
|
|
defaultSortingByFileModification :: PSValidator m x -> PSValidator m x
|
|
defaultSortingByFileModification = defaultSorting [SortAscBy "time"]
|
|
|
|
|
|
|
|
---------------
|
|
-- User names
|
|
|
|
-- | Generic sort key from msg does not work, since we have no show Instance for RenderMesage UniWorX msg. Dangerous anyway!
|
|
colUserName' :: (IsDBTable m c, HasUser a, RenderMessage UniWorX msg, Show msg) => msg -> Colonnade Sortable a (DBCell m c)
|
|
colUserName' msg = sortable (Just $ fromString $ show msg) (i18nCell msg) cellHasUser
|
|
|
|
colUserName :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
|
|
colUserName = sortable (Just "user-name") (i18nCell MsgCourseMembers) cellHasUser
|
|
|
|
colUserNameLink :: (IsDBTable m c, HasEntity a User) => (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c)
|
|
colUserNameLink userLink = sortable (Just "user-name") (i18nCell MsgCourseMembers) (cellHasUserLink userLink)
|
|
|
|
-- | Intended to work with @nameWidget@, showing highlighter Surname within Displayname
|
|
-- TOOD: We want to sort first by UserSurname and then by UserDisplayName, not supportet by dbTable
|
|
-- see also @defaultSortingName@
|
|
sortUserName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
|
|
sortUserName queryUser = ("user-name", SortColumn $ toSortKey . queryUser)
|
|
where toSortKey user = (user E.^. UserSurname) E.++. (user E.^. UserDisplayName)
|
|
|
|
-- | Alias for sortUserName for consistency, since column comes in two variants
|
|
sortUserNameLink :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
|
|
sortUserNameLink = sortUserName
|
|
|
|
sortUserSurname :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
|
|
sortUserSurname queryUser = ("user-surname", SortColumn $ queryUser >>> (E.^. UserSurname))
|
|
|
|
sortUserDisplayName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
|
|
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, untested, working with single sorter
|
|
|
|
-- | Alias for sortUserName for consistency
|
|
fltrUserNameLink :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t)
|
|
fltrUserNameLink = fltrUserName
|
|
|
|
fltrUserName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
|
|
=> (a -> E.SqlExpr (Entity User))
|
|
-> (d, FilterColumn t)
|
|
fltrUserName queryUser = ( "user-name", FilterColumn $ mkContainsFilter queryName )
|
|
where
|
|
queryName = queryUser >>> (E.^. UserDisplayName)
|
|
|
|
fltrUserNameExact :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
|
|
=> (a -> E.SqlExpr (Entity User))
|
|
-> (d, FilterColumn t)
|
|
fltrUserNameExact queryUser = ( "user-name", FilterColumn $ mkExactFilter queryName )
|
|
where
|
|
queryName = queryUser >>> (E.^. UserDisplayName)
|
|
|
|
fltrUserSurname :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
|
|
=> (a -> E.SqlExpr (Entity User))
|
|
-> (d, FilterColumn t)
|
|
fltrUserSurname queryUser = ( "user-surname", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserSurname))
|
|
|
|
fltrUserDisplayName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
|
|
=> (a -> E.SqlExpr (Entity User))
|
|
-> (d, FilterColumn t)
|
|
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)), IsString d)
|
|
=> (a -> E.SqlExpr (Entity User))
|
|
-> (d, FilterColumn t)
|
|
fltrUserNameEmail queryUser = ( "user-name-email", FilterColumn $ anyFilter
|
|
[ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName)
|
|
, mkContainsFilter $ queryUser >>> (E.^. UserSurname)
|
|
, mkContainsFilterWith CI.mk $ queryUser >>> (E.^. UserEmail)
|
|
]
|
|
)
|
|
|
|
fltrUserNameLinkUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
|
|
fltrUserNameLinkUI = fltrUserNameUI
|
|
|
|
fltrUserNameUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
|
|
fltrUserNameUI mPrev =
|
|
prismAForm (singletonFilter "user-name") mPrev $ aopt textField (fslI MsgCourseMembers)
|
|
|
|
fltrUserNameEmailUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
|
|
fltrUserNameEmailUI mPrev =
|
|
prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgCourseMembers)
|
|
|
|
-------------------
|
|
-- Matriclenumber
|
|
colUserMatriclenr :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
|
|
colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer
|
|
|
|
sortUserMatriclenr :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t)
|
|
sortUserMatriclenr queryUser = ("user-matriclenumber", SortColumn $ queryUser >>> (E.^. UserMatrikelnummer))
|
|
|
|
fltrUserMatriclenr :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))
|
|
, IsString d
|
|
)
|
|
=> (a -> E.SqlExpr (Entity User))
|
|
-> (d, FilterColumn t)
|
|
fltrUserMatriclenr queryUser = ("user-matriclenumber", FilterColumn . mkContainsFilterWith 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 MsgMatrikelNr)
|
|
|
|
|
|
----------------
|
|
-- User E-Mail
|
|
colUserEmail :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
|
|
colUserEmail = sortable (Just "user-email") (i18nCell MsgEMail) cellHasEMail
|
|
|
|
sortUserEmail :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t)
|
|
sortUserEmail queryUser = ( "user-email", SortColumn $ queryUser >>> (E.^. UserEmail))
|
|
|
|
fltrUserEmail :: ( IsFilterColumn t (a -> Set (CI Text) -> E.SqlExpr (E.Value Bool))
|
|
, IsString d
|
|
)
|
|
=> (a -> E.SqlExpr (Entity User))
|
|
-> (d, FilterColumn t)
|
|
fltrUserEmail queryUser = ("user-email", FilterColumn . mkContainsFilter $ queryUser >>> (E.^. UserEmail))
|
|
|
|
fltrUserEmailUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
|
|
fltrUserEmailUI mPrev =
|
|
prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgEMail)
|
|
|
|
|
|
--------------------
|
|
-- Study features --
|
|
--------------------
|
|
|
|
colFeaturesSemester :: (IsDBTable m c, HasStudyFeatures x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c)
|
|
colFeaturesSemester feature = sortable (Just "features-semester") (i18nCell MsgStudyFeatureAge) $ maybe mempty cellHasSemester . firstOf feature
|
|
|
|
sortFeaturesSemester :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyFeatures))) -> (d, SortColumn t)
|
|
sortFeaturesSemester queryFeatures = ("features-semester", SortColumn $ queryFeatures >>> (E.?. StudyFeaturesSemester))
|
|
|
|
fltrFeaturesSemester :: ( IsFilterColumn t (a -> Set Int -> E.SqlExpr (E.Value Bool))
|
|
, IsString d
|
|
)
|
|
=> (a -> E.SqlExpr (Maybe (Entity StudyFeatures)))
|
|
-> (d, FilterColumn t)
|
|
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 MsgStudyFeatureAge)
|
|
|
|
|
|
colField :: (IsDBTable m c, HasStudyTerms x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c)
|
|
colField terms = sortable (Just "terms") (i18nCell MsgStudyTerm) $ maybe mempty cellHasField . firstOf terms
|
|
|
|
sortField :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyTerms))) -> (d, SortColumn t)
|
|
sortField queryTerms = ("terms", SortColumn $ queryTerms >>> (E.?. StudyTermsName))
|
|
|
|
fltrField :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))
|
|
, IsString d
|
|
)
|
|
=> (a -> E.SqlExpr (Maybe (Entity StudyTerms)))
|
|
-> (d, FilterColumn t)
|
|
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 MsgStudyTerm)
|
|
|
|
|
|
colDegreeShort :: (IsDBTable m c, HasStudyDegree x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c)
|
|
colDegreeShort terms = sortable (Just "degree-short") (i18nCell MsgDegreeShort) $ maybe mempty cellHasDegreeShort . firstOf terms
|
|
|
|
sortDegreeShort :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyDegree))) -> (d, SortColumn t)
|
|
sortDegreeShort queryTerms = ("degree-short", SortColumn $ queryTerms >>> (E.?. StudyDegreeShorthand))
|
|
|
|
fltrDegree :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))
|
|
, IsString d
|
|
)
|
|
=> (a -> E.SqlExpr (Maybe (Entity StudyDegree)))
|
|
-> (d, FilterColumn t)
|
|
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 MsgDegreeName)
|