729 lines
35 KiB
Haskell
729 lines
35 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 qualified Database.Esqueleto.Utils as E
|
|
import Database.Esqueleto.Utils (mkExactFilter, mkExactFilterWith, mkContainsFilter, mkContainsFilterWith, anyFilter)
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Table.Cells
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import qualified Colonnade
|
|
import Colonnade.Encode (Colonnade(..), OneColonnade(..))
|
|
|
|
import Text.Blaze (toMarkup)
|
|
|
|
|
|
--------------------------------
|
|
-- 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 sortingMap.
|
|
( IsMap sortingMap
|
|
, ContainerKey sortingMap ~ SortingKey
|
|
, MapValue sortingMap ~ SortColumn t
|
|
)
|
|
=> (forall focus'. Getting focus' t focus)
|
|
-> sortingMap
|
|
|
|
type OpticSortColumn val = OpticSortColumn' (E.SqlExpr (E.Value val))
|
|
|
|
type OpticFilterColumn' t inp focus
|
|
= forall filterMap.
|
|
( IsMap filterMap
|
|
, ContainerKey filterMap ~ FilterKey
|
|
, MapValue filterMap ~ FilterColumn t
|
|
, 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))
|
|
|
|
-----------------------
|
|
-- 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
|
|
|
|
-----------
|
|
-- Terms --
|
|
-----------
|
|
|
|
colTermShort :: OpticColonnade TermId
|
|
colTermShort resultTid = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "term") (i18nCell MsgTerm)
|
|
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 MsgTerm)
|
|
|
|
-------------
|
|
-- Schools --
|
|
-------------
|
|
|
|
colSchool :: OpticColonnade SchoolId
|
|
colSchool resultSsh = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "school") (i18nCell MsgSchool)
|
|
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 MsgSchoolShort)
|
|
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 MsgSchoolName)
|
|
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 MsgSchool)
|
|
|
|
-----------------
|
|
-- Allocations --
|
|
-----------------
|
|
|
|
colAllocationName :: OpticColonnade AllocationName
|
|
colAllocationName resultName = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "allocation") (i18nCell MsgAllocationName)
|
|
body = i18nCell . view resultName
|
|
|
|
sortAllocationName :: OpticSortColumn AllocationName
|
|
sortAllocationName queryName = singletonMap "allocation" . SortColumn $ view queryName
|
|
|
|
fltrAllocation :: forall allocation t shorthand name.
|
|
( E.SqlProject Allocation AllocationShorthand allocation shorthand
|
|
, E.SqlProject Allocation AllocationName allocation name
|
|
, E.SqlString name, E.SqlString shorthand
|
|
)
|
|
=> OpticFilterColumn' t (Set (CI Text)) (E.SqlExpr allocation)
|
|
fltrAllocation query = singletonMap "allocation" . FilterColumn $ anyFilter
|
|
[ mkContainsFilterWith unSqlProject' $ views query (`E.sqlProject` AllocationShorthand) :: t -> Set (CI Text) -> E.SqlExpr (E.Value Bool)
|
|
, mkContainsFilterWith unSqlProject' $ views query (`E.sqlProject` AllocationName)
|
|
]
|
|
where
|
|
unSqlProject' :: E.SqlProject Allocation value allocation value' => value -> value'
|
|
unSqlProject' = E.unSqlProject (Proxy @Allocation) (Proxy @allocation)
|
|
|
|
fltrAllocationUI :: DBFilterUI
|
|
fltrAllocationUI mPrev = prismAForm (singletonFilter "allocation" . maybePrism _PathPiece) mPrev $ aopt (ciField :: Field _ AllocationName) (fslI MsgAllocation)
|
|
|
|
|
|
colAllocationShorthand :: OpticColonnade AllocationShorthand
|
|
colAllocationShorthand resultShort = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "allocation-short") (i18nCell MsgAllocation)
|
|
body = i18nCell . view resultShort
|
|
|
|
sortAllocationShorthand :: forall shorthand. PersistField shorthand => OpticSortColumn shorthand
|
|
sortAllocationShorthand queryShorthand = singletonMap "allocation-short" . SortColumn $ view queryShorthand
|
|
|
|
|
|
fltrAllocationActive :: UTCTime -- ^ current time
|
|
-> OpticFilterColumn' t (Last Bool) (E.SqlExpr (E.Entity Allocation))
|
|
fltrAllocationActive cTime queryAllocation = singletonMap "active" . FilterColumn $ \(view queryAllocation -> allocation) (Last criterion)
|
|
-> maybe (const E.true) ((E.==.) . E.val) criterion $ E.or
|
|
[ staffRegisterActive allocation
|
|
, staffAllocationActive allocation
|
|
, registerActive allocation
|
|
]
|
|
where
|
|
staffRegisterActive allocation
|
|
= E.maybe E.false (\f -> f E.<=. E.val cTime) (allocation E.^. AllocationStaffRegisterFrom)
|
|
E.&&. E.maybe E.true (\t -> E.val cTime E.<=. t) (allocation E.^. AllocationStaffRegisterTo)
|
|
staffAllocationActive allocation
|
|
= E.maybe E.false (\f -> f E.<=. E.val cTime) (allocation E.^. AllocationStaffAllocationFrom)
|
|
E.&&. E.maybe E.true (\t -> E.val cTime E.<=. t) (allocation E.^. AllocationStaffAllocationTo)
|
|
registerActive allocation
|
|
= E.maybe E.false (\f -> f E.<=. E.val cTime) (allocation E.^. AllocationRegisterFrom)
|
|
E.&&. E.maybe E.true (\t -> E.val cTime E.<=. t) (allocation E.^. AllocationRegisterTo)
|
|
|
|
fltrAllocationActiveUI :: DBFilterUI
|
|
fltrAllocationActiveUI mPrev = prismAForm (singletonFilter "active" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgAllocationActive)
|
|
|
|
|
|
-------------------------
|
|
-- Course Applications --
|
|
-------------------------
|
|
|
|
colApplicationId :: OpticColonnade CourseApplicationId
|
|
colApplicationId resultId = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable Nothing (i18nCell MsgCourseApplicationId)
|
|
body = views resultId $ cell . (toWidget . toMarkup =<<) . (encrypt :: CourseApplicationId -> WidgetT UniWorX IO CryptoFileNameCourseApplication)
|
|
|
|
colApplicationRatingPoints :: OpticColonnade (Maybe ExamGrade)
|
|
colApplicationRatingPoints resultPoints = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "points") (i18nCell MsgCourseApplicationRatingPoints)
|
|
body = views resultPoints $ maybe mempty i18nCell
|
|
|
|
sortApplicationRatingPoints :: OpticSortColumn (Maybe ExamGrade)
|
|
sortApplicationRatingPoints queryPoints = singletonMap "points" . SortColumn $ view queryPoints
|
|
|
|
fltrApplicationRatingPoints :: OpticFilterColumn t (Maybe ExamGrade)
|
|
fltrApplicationRatingPoints queryPoints = singletonMap "points" . FilterColumn . mkExactFilter $ view queryPoints
|
|
|
|
fltrApplicationRatingPointsUI :: DBFilterUI
|
|
fltrApplicationRatingPointsUI mPrev = prismAForm (singletonFilter "points" . maybePrism _PathPiece) mPrev $ aopt examGradeField (fslI MsgCourseApplicationRatingPoints)
|
|
|
|
colApplicationVeto :: OpticColonnade Bool
|
|
colApplicationVeto resultVeto = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "veto") (i18nCell MsgCourseApplicationVeto)
|
|
body = views resultVeto $ bool mempty (iconCell IconApplicationVeto)
|
|
|
|
sortApplicationVeto :: OpticSortColumn Bool
|
|
sortApplicationVeto queryVeto = singletonMap "veto" . SortColumn $ view queryVeto
|
|
|
|
fltrApplicationVeto :: OpticFilterColumn t Bool
|
|
fltrApplicationVeto queryVeto = singletonMap "veto" . FilterColumn . mkExactFilter $ view queryVeto
|
|
|
|
fltrApplicationVetoUI :: DBFilterUI
|
|
fltrApplicationVetoUI mPrev = prismAForm (singletonFilter "veto" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgCourseApplicationVeto)
|
|
|
|
colApplicationRatingComment :: OpticColonnade (Maybe Text)
|
|
colApplicationRatingComment resultComment = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "comment") (i18nCell MsgApplicationRatingComment)
|
|
body = views resultComment . maybe mempty $ cell . modal (toWidget $ hasComment True) . Right . toWidget
|
|
|
|
sortApplicationRatingComment :: OpticSortColumn (Maybe Text)
|
|
sortApplicationRatingComment queryComment = singletonMap "comment" . SortColumn $ view queryComment
|
|
|
|
fltrApplicationRatingComment :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value (Maybe Text)))
|
|
fltrApplicationRatingComment queryComment = singletonMap "comment" . FilterColumn . mkContainsFilterWith Just $ view queryComment
|
|
|
|
fltrApplicationRatingCommentUI :: DBFilterUI
|
|
fltrApplicationRatingCommentUI mPrev = prismAForm (singletonFilter "comment") mPrev $ aopt textField (fslI MsgApplicationRatingComment)
|
|
|
|
colApplicationText :: OpticColonnade (Maybe Text)
|
|
colApplicationText resultText = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "text") (i18nCell MsgCourseApplicationText)
|
|
body = views resultText . maybe mempty $ cell . modal (toWidget $ hasComment True) . Right . toWidget
|
|
|
|
sortApplicationText :: OpticSortColumn (Maybe Text)
|
|
sortApplicationText queryText = singletonMap "text" . SortColumn $ view queryText
|
|
|
|
fltrApplicationText :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value (Maybe Text)))
|
|
fltrApplicationText queryText = singletonMap "text" . FilterColumn . mkContainsFilterWith Just $ view queryText
|
|
|
|
fltrApplicationTextUI :: DBFilterUI
|
|
fltrApplicationTextUI mPrev = prismAForm (singletonFilter "text") mPrev $ aopt textField (fslI MsgCourseApplicationText)
|
|
|
|
|
|
colApplicationFiles :: OpticColonnade (TermId, SchoolId, CourseShorthand, CourseApplicationId, Bool) -- ^ `Bool` controls whether link is shown, use result of determination whether files exist
|
|
colApplicationFiles resultInfo = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "has-files") (i18nCell MsgCourseApplicationFiles)
|
|
body = views resultInfo $ \(tid, ssh, csh, appId, showLink) -> if
|
|
| showLink
|
|
-> flip anchorCellM (asWidgetT $ toWidget iconApplicationFiles) $ do
|
|
cID <- encrypt appId
|
|
return $ CApplicationR tid ssh csh cID CAFilesR
|
|
| otherwise
|
|
-> mempty
|
|
|
|
sortApplicationFiles :: OpticSortColumn Bool
|
|
sortApplicationFiles queryFiles = singletonMap "has-files" . SortColumn $ view queryFiles
|
|
|
|
fltrApplicationFiles :: OpticFilterColumn t Bool
|
|
fltrApplicationFiles queryFiles = singletonMap "has-files" . FilterColumn . mkExactFilter $ view queryFiles
|
|
|
|
fltrApplicationFilesUI :: DBFilterUI
|
|
fltrApplicationFilesUI mPrev = prismAForm (singletonFilter "has-files" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgCourseApplicationFiles)
|
|
|
|
---------------
|
|
-- 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
|
|
|
|
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)
|
|
|
|
|
|
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
|
|
sortUserName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
|
|
sortUserName queryUser = ("user-name", SortColumns $ queryUser >>> \user ->
|
|
[ SomeExprValue $ user E.^. UserSurname
|
|
, SomeExprValue $ 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, 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)
|
|
|
|
-------------------
|
|
-- Matriculation --
|
|
-------------------
|
|
|
|
colUserMatriculation :: OpticColonnade (Maybe UserMatriculation)
|
|
colUserMatriculation resultMatriculation = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "user-matriculation") (i18nCell MsgUserMatriculation)
|
|
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 . mkContainsFilterWith Just $ view queryMatriculation
|
|
|
|
fltrUserMatriculationUI :: DBFilterUI
|
|
fltrUserMatriculationUI mPrev = prismAForm (singletonFilter "user-matriculation") mPrev $ aopt textField (fslI MsgUserMatriculation)
|
|
|
|
|
|
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 --
|
|
--------------------
|
|
|
|
colStudyDegree :: OpticColonnade StudyDegree
|
|
colStudyDegree resultDegree = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "features-degree") (i18nCell MsgStudyFeatureDegree)
|
|
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 MsgStudyFeatureDegree)
|
|
|
|
|
|
colStudyTerms :: OpticColonnade StudyTerms
|
|
colStudyTerms resultTerms = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "features-terms") (i18nCell MsgStudyTerm)
|
|
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 MsgStudyTerm)
|
|
|
|
|
|
colStudyFeaturesSemester :: OpticColonnade Int
|
|
colStudyFeaturesSemester resultSemester = Colonnade.singleton (fromSortable header) body
|
|
where
|
|
header = Sortable (Just "features-semester") (i18nCell MsgStudyFeatureAge)
|
|
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 MsgStudyFeatureAge)
|
|
|
|
|
|
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)
|
|
|
|
----------------------------
|
|
-- 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' -> WidgetT UniWorX IO 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
|
|
|
|
emptyOpticColonnade :: forall h r' focus c.
|
|
( Monoid c
|
|
)
|
|
=> Fold 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 or more than one values to `mempty`
|
|
emptyOpticColonnade l c = Colonnade $ oldColonnade <&> \column -> column { oneColonnadeEncode = \s -> defaultColumn s $ oneColonnadeEncode column }
|
|
where
|
|
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 = case x ^.. l of
|
|
[_] -> f x
|
|
_ -> mempty
|
|
|