feat(allocations): show table of course applications
This commit is contained in:
Gregor Kleen
parent
d621e61b11
commit
f5da3bebba
@ -969,6 +969,7 @@ MenuCourseList: Kurse
|
||||
MenuCourseMembers: Kursteilnehmer
|
||||
MenuCourseAddMembers: Kursteilnehmer hinzufügen
|
||||
MenuCourseCommunication: Kursmitteilung
|
||||
MenuCourseApplications: Bewerbungen
|
||||
MenuTermShow: Semester
|
||||
MenuSubmissionDelete: Abgabe löschen
|
||||
MenuUsers: Benutzer
|
||||
@ -1513,4 +1514,12 @@ AllocationSchoolShort: Institut
|
||||
Allocation: Zentralanmeldung
|
||||
AllocationRegisterTo: Anmeldungen bis
|
||||
|
||||
AllocationListTitle: Zentralanmeldungen
|
||||
AllocationListTitle: Zentralanmeldungen
|
||||
|
||||
CourseApplicationsListTitle: Bewerbungen
|
||||
CourseApplicationId: Bewerbungsnummer
|
||||
CourseApplicationRatingPoints: Bewertung
|
||||
CourseApplicationVeto: Veto
|
||||
|
||||
UserDisplayName: Voller Name
|
||||
UserMatriculation: Matrikelnummer
|
||||
@ -12,10 +12,10 @@ User json -- Each Uni2work user has a corresponding row in this table; create
|
||||
authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
|
||||
lastAuthentication UTCTime Maybe -- last login date
|
||||
tokensIssuedAfter UTCTime Maybe -- do not accept bearer tokens issued before this time (accept all tokens if null)
|
||||
matrikelnummer Text Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...)
|
||||
matrikelnummer UserMatriculation Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...)
|
||||
email (CI Text) -- Case-insensitive eMail address
|
||||
displayName Text -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained)
|
||||
surname Text -- Display user names always through 'nameWidget displayName surname'
|
||||
displayName UserDisplayName -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained)
|
||||
surname UserSurname -- Display user names always through 'nameWidget displayName surname'
|
||||
firstName Text -- For export in tables, pre-split firstName from displayName
|
||||
title Text Maybe -- For upcoming name customisation
|
||||
maxFavourites Int default=12 -- max number of rows with this userId in table "CourseFavourite"; for convenience links; user-defined
|
||||
|
||||
@ -64,8 +64,6 @@ import qualified Yesod.Core.Types as Yesod (Logger(..))
|
||||
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
|
||||
import Data.Proxy
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
|
||||
import System.Exit
|
||||
|
||||
@ -18,6 +18,7 @@ module Database.Esqueleto.Utils
|
||||
, SqlHashable
|
||||
, sha256
|
||||
, maybe
|
||||
, SqlProject(..)
|
||||
) where
|
||||
|
||||
|
||||
@ -232,3 +233,16 @@ maybe onNothing onJust val = E.case_
|
||||
(onJust $ E.veryUnsafeCoerceSqlExprValue val)
|
||||
]
|
||||
(E.else_ onNothing)
|
||||
|
||||
|
||||
class (PersistEntity entity, PersistField value) => SqlProject entity value entity' value' | entity value entity' -> value', entity value value' -> entity' where
|
||||
sqlProject :: E.SqlExpr entity' -> EntityField entity value -> E.SqlExpr (E.Value value')
|
||||
unSqlProject :: forall p1 p2. p1 entity -> p2 entity' -> value -> value'
|
||||
|
||||
instance (PersistEntity val, PersistField typ) => SqlProject val typ (E.Entity val) typ where
|
||||
sqlProject = (E.^.)
|
||||
unSqlProject _ _ = id
|
||||
|
||||
instance (PersistEntity val, PersistField typ) => SqlProject val typ (Maybe (E.Entity val)) (Maybe typ) where
|
||||
sqlProject = (E.?.)
|
||||
unSqlProject _ _ = Just
|
||||
|
||||
@ -1041,6 +1041,7 @@ tagAccessPredicate AuthAllocationRegistered = APDB $ \mAuthId route _ -> case ro
|
||||
r -> $unsupportedAuthPredicate AuthAllocationRegistered r
|
||||
tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
|
||||
CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do
|
||||
cTime <- liftIO getCurrentTime
|
||||
let authorizedIfExists f = do
|
||||
[E.Value ok] <- lift . E.select . return . E.exists $ E.from f
|
||||
whenExceptT ok Authorized
|
||||
@ -1101,12 +1102,16 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
-- participant is applicant for this course
|
||||
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseApplication) -> do
|
||||
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \((course `E.InnerJoin` courseApplication) `E.LeftOuterJoin` allocation) -> do
|
||||
E.on $ allocation E.?. AllocationId E.==. courseApplication E.^. CourseApplicationAllocation
|
||||
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
|
||||
E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val participant
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
E.where_ $ E.maybe E.true (E.maybe E.false $ \f -> f E.<=. E.val cTime) (allocation E.?. AllocationStaffAllocationFrom)
|
||||
E.&&. E.maybe E.true (E.maybe E.true $ \t -> t E.>=. E.val cTime) (allocation E.?. AllocationStaffAllocationTo)
|
||||
|
||||
unauthorizedI MsgUnauthorizedParticipant
|
||||
r -> $unsupportedAuthPredicate AuthParticipant r
|
||||
tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of
|
||||
@ -1770,6 +1775,8 @@ instance YesodBreadcrumbs UniWorX where
|
||||
breadcrumb (CourseR tid ssh csh CExamListR) = return ("Prüfungen", Just $ CourseR tid ssh csh CShowR)
|
||||
breadcrumb (CourseR tid ssh csh CExamNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CExamListR)
|
||||
|
||||
breadcrumb (CourseR tid ssh csh CApplicationsR) = return ("Bewerbungen", Just $ CourseR tid ssh csh CShowR)
|
||||
|
||||
breadcrumb (CExamR tid ssh csh examn EShowR) = return (original examn, Just $ CourseR tid ssh csh CExamListR)
|
||||
breadcrumb (CExamR tid ssh csh examn EEditR) = return ("Bearbeiten", Just $ CExamR tid ssh csh examn EShowR)
|
||||
breadcrumb (CExamR tid ssh csh examn EUsersR) = return ("Teilnehmer", Just $ CExamR tid ssh csh examn EShowR)
|
||||
@ -2239,6 +2246,28 @@ pageActions (CourseR tid ssh csh CShowR) =
|
||||
anyM examNames $ examAccess . E.unValue
|
||||
in runDB $ lecturerAccess `or2M` existsVisible
|
||||
}
|
||||
, MenuItem
|
||||
{ menuItemType = PageActionSecondary
|
||||
, menuItemLabel = MsgMenuCourseApplications
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CApplicationsR
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' =
|
||||
let courseWhere course = course <$ do
|
||||
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
existsApplications = E.selectExists . E.from $ \(course `E.InnerJoin` courseApplication) -> do
|
||||
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
|
||||
void $ courseWhere course
|
||||
courseApplications = fmap (any E.unValue) . E.select . E.from $ \course -> do
|
||||
void $ courseWhere course
|
||||
return $ course E.^. CourseApplicationsRequired
|
||||
courseAllocation = E.selectExists . E.from $ \(course `E.InnerJoin` allocationCourse) -> do
|
||||
E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse
|
||||
void $ courseWhere course
|
||||
in runDB $ courseAllocation `or2M` courseApplications `or2M` existsApplications
|
||||
}
|
||||
, MenuItem
|
||||
{ menuItemType = PageActionSecondary
|
||||
, menuItemLabel = MsgMenuCourseMembers
|
||||
|
||||
@ -18,7 +18,7 @@ allocationListIdent = "allocations"
|
||||
queryAllocation :: Getter AllocationTableExpr (E.SqlExpr (Entity Allocation))
|
||||
queryAllocation = id
|
||||
|
||||
resultAllocation :: Getter AllocationTableData (Entity Allocation)
|
||||
resultAllocation :: Lens' AllocationTableData (Entity Allocation)
|
||||
resultAllocation = _dbrOutput
|
||||
|
||||
allocationTermLink :: TermId -> SomeRoute UniWorX
|
||||
@ -43,9 +43,9 @@ getAllocationListR = do
|
||||
|
||||
dbtColonnade :: Colonnade Sortable _ _
|
||||
dbtColonnade = mconcat
|
||||
[ anchorColonnade (views (resultAllocation . _entityVal . _allocationTerm) allocationTermLink) . colTermShort $ resultAllocation . _entityVal . _allocationTerm
|
||||
, anchorColonnade (views (resultAllocation . _entityVal . _allocationSchool) allocationSchoolLink) . colSchoolShort $ resultAllocation . _entityVal . _allocationSchool
|
||||
, anchorColonnade (views (resultAllocation . _entityVal) allocationLink) . colAllocationName $ resultAllocation . _entityVal . _allocationName
|
||||
[ anchorColonnade (views (resultAllocation . _entityVal . _allocationTerm) allocationTermLink) $ colTermShort (resultAllocation . _entityVal . _allocationTerm)
|
||||
, anchorColonnade (views (resultAllocation . _entityVal . _allocationSchool) allocationSchoolLink) $ colSchoolShort (resultAllocation . _entityVal . _allocationSchool)
|
||||
, anchorColonnade (views (resultAllocation . _entityVal) allocationLink) $ colAllocationName (resultAllocation . _entityVal . _allocationName)
|
||||
]
|
||||
|
||||
dbtSorting = mconcat
|
||||
@ -57,12 +57,12 @@ getAllocationListR = do
|
||||
dbtFilter = mconcat
|
||||
[ fltrTerm $ queryAllocation . to (E.^. AllocationTerm)
|
||||
, fltrSchool $ queryAllocation . to (E.^. AllocationSchool)
|
||||
, fltrAllocationName $ queryAllocation . to (E.^. AllocationName)
|
||||
, fltrAllocation queryAllocation
|
||||
]
|
||||
dbtFilterUI = mconcat
|
||||
[ fltrTermUI
|
||||
, fltrSchoolUI
|
||||
, fltrAllocationNameUI
|
||||
, fltrAllocationUI
|
||||
]
|
||||
|
||||
dbtStyle = def
|
||||
@ -77,6 +77,7 @@ getAllocationListR = do
|
||||
|
||||
psValidator :: PSValidator _ _
|
||||
psValidator = def
|
||||
& defaultSorting [SortAscBy "term", SortAscBy "school", SortAscBy "allocation"]
|
||||
|
||||
table <- runDB $ dbTableWidget' psValidator DBTable{..}
|
||||
|
||||
|
||||
@ -6,8 +6,10 @@ module Handler.Course.Application
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Table.Columns
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
import System.FilePath (addExtension)
|
||||
|
||||
@ -37,6 +39,192 @@ getCAFilesR tid ssh csh cID = do
|
||||
|
||||
serveSomeFiles archiveName $ fsSource .| C.map entityVal
|
||||
|
||||
|
||||
type CourseApplicationsTableExpr = ( E.SqlExpr (Entity CourseApplication)
|
||||
`E.InnerJoin` E.SqlExpr (Entity User)
|
||||
)
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Allocation))
|
||||
`E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity StudyFeatures))
|
||||
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))
|
||||
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree))
|
||||
)
|
||||
type CourseApplicationsTableData = DBRow ( Entity CourseApplication
|
||||
, Entity User
|
||||
, E.Value Bool -- hasFiles
|
||||
, Maybe (Entity Allocation)
|
||||
, Maybe (Entity StudyFeatures)
|
||||
, Maybe (Entity StudyTerms)
|
||||
, Maybe (Entity StudyDegree)
|
||||
)
|
||||
|
||||
courseApplicationsIdent :: Text
|
||||
courseApplicationsIdent = "applications"
|
||||
|
||||
queryCourseApplication :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity CourseApplication))
|
||||
queryCourseApplication = to $ $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
||||
|
||||
queryUser :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity User))
|
||||
queryUser = to $ $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
|
||||
|
||||
queryHasFiles :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool))
|
||||
queryHasFiles = to $ hasFiles . $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
||||
where
|
||||
hasFiles appl = E.exists . E.from $ \courseApplicationFile ->
|
||||
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. appl E.^. CourseApplicationId
|
||||
|
||||
queryAllocation :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity Allocation)))
|
||||
queryAllocation = to $(sqlLOJproj 3 2)
|
||||
|
||||
queryStudyFeatures :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyFeatures)))
|
||||
queryStudyFeatures = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 3 3)
|
||||
|
||||
queryStudyTerms :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyTerms)))
|
||||
queryStudyTerms = to $ $(sqlIJproj 3 2) . $(sqlLOJproj 3 3)
|
||||
|
||||
queryStudyDegree :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyDegree)))
|
||||
queryStudyDegree = to $ $(sqlIJproj 3 3) . $(sqlLOJproj 3 3)
|
||||
|
||||
resultCourseApplication :: Lens' CourseApplicationsTableData (Entity CourseApplication)
|
||||
resultCourseApplication = _dbrOutput . _1
|
||||
|
||||
resultUser :: Lens' CourseApplicationsTableData (Entity User)
|
||||
resultUser = _dbrOutput . _2
|
||||
|
||||
resultHasFiles :: Lens' CourseApplicationsTableData Bool
|
||||
resultHasFiles = _dbrOutput . _3 . _Value
|
||||
|
||||
resultAllocation :: Traversal' CourseApplicationsTableData (Entity Allocation)
|
||||
resultAllocation = _dbrOutput . _4 . _Just
|
||||
|
||||
resultStudyFeatures :: Traversal' CourseApplicationsTableData (Entity StudyFeatures)
|
||||
resultStudyFeatures = _dbrOutput . _5 . _Just
|
||||
|
||||
resultStudyTerms :: Traversal' CourseApplicationsTableData (Entity StudyTerms)
|
||||
resultStudyTerms = _dbrOutput . _6 . _Just
|
||||
|
||||
resultStudyDegree :: Traversal' CourseApplicationsTableData (Entity StudyDegree)
|
||||
resultStudyDegree = _dbrOutput . _7 . _Just
|
||||
|
||||
getCApplicationsR, postCApplicationsR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCApplicationsR = postCApplicationsR
|
||||
postCApplicationsR = fail "not implemented" -- dbtable of _all_ course applications
|
||||
postCApplicationsR tid ssh csh = do
|
||||
table <- runDB $ do
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
|
||||
let
|
||||
allocationLink :: Allocation -> SomeRoute UniWorX
|
||||
allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR
|
||||
|
||||
participantLink :: MonadCrypto m => UserId -> m (SomeRoute UniWorX)
|
||||
participantLink uid = do
|
||||
cID <- encrypt uid
|
||||
return . SomeRoute . CourseR tid ssh csh $ CUserR cID
|
||||
|
||||
dbtSQLQuery :: CourseApplicationsTableExpr -> E.SqlQuery _
|
||||
dbtSQLQuery = runReaderT $ do
|
||||
courseApplication <- view queryCourseApplication
|
||||
hasFiles <- view queryHasFiles
|
||||
user <- view queryUser
|
||||
allocation <- view queryAllocation
|
||||
studyFeatures <- view queryStudyFeatures
|
||||
studyTerms <- view queryStudyTerms
|
||||
studyDegree <- view queryStudyDegree
|
||||
|
||||
lift $ do
|
||||
E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
|
||||
E.on $ studyTerms E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
|
||||
E.on $ studyFeatures E.?. StudyFeaturesId E.==. courseApplication E.^. CourseApplicationField
|
||||
E.on $ courseApplication E.^. CourseApplicationAllocation E.==. allocation E.?. AllocationId
|
||||
E.on $ user E.^. UserId E.==. courseApplication E.^. CourseApplicationUser
|
||||
E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid
|
||||
|
||||
return (courseApplication, user, hasFiles, allocation, studyFeatures, studyTerms, studyDegree)
|
||||
|
||||
dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) CourseApplicationsTableData
|
||||
dbtProj = runReaderT $ do
|
||||
appId <- view $ resultCourseApplication . _entityKey
|
||||
cID <- encrypt appId
|
||||
|
||||
guardM . hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR -- TODO: replace with CAShowR
|
||||
|
||||
view id
|
||||
|
||||
dbtRowKey = view $ queryCourseApplication . to (E.^. CourseApplicationId)
|
||||
|
||||
dbtColonnade :: Colonnade Sortable _ _
|
||||
dbtColonnade = mconcat
|
||||
[ emptyOpticColonnade (resultAllocation . _entityVal) $ \l -> anchorColonnade (views l allocationLink) $ colAllocationShorthand (l . _allocationShorthand)
|
||||
, colApplicationId (resultCourseApplication . _entityKey)
|
||||
, anchorColonnadeM (views (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
|
||||
, colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
|
||||
, emptyOpticColonnade (resultStudyTerms . _entityVal) colStudyTerms
|
||||
, emptyOpticColonnade (resultStudyDegree . _entityVal) colStudyDegree
|
||||
, emptyOpticColonnade (resultStudyFeatures . _entityVal . _studyFeaturesSemester) colStudyFeaturesSemester
|
||||
, colApplicationText (resultCourseApplication . _entityVal . _courseApplicationText)
|
||||
, lmap ((tid, ssh, csh), ) $ colApplicationFiles ($(multifocusL 5) (_1 . _1) (_1 . _2) (_1 . _3) (_2 . resultCourseApplication . _entityKey) (_2 . resultHasFiles))
|
||||
, colApplicationVeto (resultCourseApplication . _entityVal . _courseApplicationRatingVeto)
|
||||
, colApplicationRatingPoints (resultCourseApplication . _entityVal . _courseApplicationRatingPoints)
|
||||
, colApplicationRatingComment (resultCourseApplication . _entityVal . _courseApplicationRatingComment)
|
||||
]
|
||||
|
||||
dbtSorting = mconcat
|
||||
[ sortAllocationShorthand $ queryAllocation . to (E.?. AllocationShorthand)
|
||||
, sortUserName' $ $(multifocusG 2) (queryUser . to (E.^. UserDisplayName)) (queryUser . to (E.^. UserSurname))
|
||||
, sortUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
|
||||
, sortStudyTerms queryStudyTerms
|
||||
, sortStudyDegree queryStudyDegree
|
||||
, sortStudyFeaturesSemester $ queryStudyFeatures . to (E.?. StudyFeaturesSemester)
|
||||
, sortApplicationText $ queryCourseApplication . to (E.^. CourseApplicationText)
|
||||
, sortApplicationFiles queryHasFiles
|
||||
, sortApplicationVeto $ queryCourseApplication . to (E.^. CourseApplicationRatingVeto)
|
||||
, sortApplicationRatingPoints $ queryCourseApplication . to (E.^. CourseApplicationRatingPoints)
|
||||
, sortApplicationRatingComment $ queryCourseApplication . to (E.^. CourseApplicationRatingComment)
|
||||
]
|
||||
|
||||
dbtFilter = mconcat
|
||||
[ fltrAllocation queryAllocation
|
||||
, fltrUserName' $ queryUser . to (E.^. UserDisplayName)
|
||||
, fltrUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
|
||||
, fltrStudyTerms queryStudyTerms
|
||||
, fltrStudyDegree queryStudyDegree
|
||||
, fltrStudyFeaturesSemester $ queryStudyFeatures . to (E.?. StudyFeaturesSemester)
|
||||
, fltrApplicationText $ queryCourseApplication . to (E.^. CourseApplicationText)
|
||||
, fltrApplicationFiles queryHasFiles
|
||||
, fltrApplicationVeto $ queryCourseApplication . to (E.^. CourseApplicationRatingVeto)
|
||||
, fltrApplicationRatingPoints $ queryCourseApplication . to (E.^. CourseApplicationRatingPoints)
|
||||
, fltrApplicationRatingComment $ queryCourseApplication . to (E.^. CourseApplicationRatingComment)
|
||||
]
|
||||
dbtFilterUI = mconcat
|
||||
[ fltrAllocationUI
|
||||
, fltrUserNameUI'
|
||||
, fltrUserMatriculationUI
|
||||
, fltrStudyTermsUI
|
||||
, fltrStudyDegreeUI
|
||||
, fltrStudyFeaturesSemesterUI
|
||||
, fltrApplicationTextUI
|
||||
, fltrApplicationFilesUI
|
||||
, fltrApplicationVetoUI
|
||||
, fltrApplicationRatingPointsUI
|
||||
, fltrApplicationRatingCommentUI
|
||||
]
|
||||
|
||||
dbtStyle = def
|
||||
{ dbsFilterLayout = defaultDBSFilterLayout
|
||||
}
|
||||
dbtParams = def
|
||||
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
|
||||
dbtIdent = courseApplicationsIdent
|
||||
|
||||
psValidator :: PSValidator _ _
|
||||
psValidator = def
|
||||
|
||||
dbTableWidget' psValidator DBTable{..}
|
||||
|
||||
let title = prependCourseTitle tid ssh csh MsgCourseApplicationsListTitle
|
||||
|
||||
siteLayoutMsg title $ do
|
||||
setTitleI title
|
||||
table
|
||||
|
||||
@ -5,8 +5,6 @@ module Handler.CryptoIDDispatch
|
||||
|
||||
import Import
|
||||
|
||||
import Data.Proxy
|
||||
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
|
||||
|
||||
@ -43,8 +43,6 @@ import Data.Either (partitionEithers)
|
||||
import Data.Aeson (eitherDecodeStrict')
|
||||
import Data.Aeson.Text (encodeToLazyText)
|
||||
|
||||
import Data.Proxy
|
||||
|
||||
import qualified Text.Email.Validate as Email
|
||||
|
||||
import Yesod.Core.Types (FileInfo(..))
|
||||
|
||||
@ -100,6 +100,9 @@ msgCell = textCell . toMessage
|
||||
---------------------
|
||||
-- Icon cells
|
||||
|
||||
iconCell :: IsDBTable m a => Icon -> DBCell m a
|
||||
iconCell = cell . toWidget . icon
|
||||
|
||||
addIconFixedWidth :: (IsDBTable m a) => DBCell m a -> DBCell m a
|
||||
addIconFixedWidth = over cellAttrs $ insertClass "icon-fixed-width"
|
||||
|
||||
|
||||
@ -12,6 +12,7 @@ import Import
|
||||
-- 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
|
||||
@ -22,6 +23,8 @@ import qualified Data.CaseInsensitive as CI
|
||||
import qualified Colonnade
|
||||
import Colonnade.Encode (Colonnade(..), OneColonnade(..))
|
||||
|
||||
import Text.Blaze (toMarkup)
|
||||
|
||||
|
||||
--------------------------------
|
||||
-- Generic Columns
|
||||
@ -42,27 +45,32 @@ type OpticColonnade focus
|
||||
( IsDBTable m x
|
||||
, FromSortable h
|
||||
)
|
||||
=> Getting focus r' focus
|
||||
=> (forall focus'. Getting focus' r' focus)
|
||||
-> Colonnade h r' (DBCell m x)
|
||||
|
||||
type OpticSortColumn focus
|
||||
type OpticSortColumn' focus
|
||||
= forall t sortingMap.
|
||||
( IsMap sortingMap
|
||||
, ContainerKey sortingMap ~ SortingKey
|
||||
, MapValue sortingMap ~ SortColumn t
|
||||
)
|
||||
=> Getting (E.SqlExpr focus) t (E.SqlExpr focus)
|
||||
=> (forall focus'. Getting focus' t focus)
|
||||
-> sortingMap
|
||||
|
||||
type OpticFilterColumn t focus
|
||||
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))
|
||||
)
|
||||
=> Getting (E.SqlExpr focus) t (E.SqlExpr focus)
|
||||
=> (forall focus'. Getting focus' t focus)
|
||||
-> filterMap
|
||||
|
||||
type OpticFilterColumn t focus = OpticFilterColumn' t (Set focus) (E.SqlExpr (E.Value focus))
|
||||
|
||||
-----------------------
|
||||
-- Numbers and Indices
|
||||
|
||||
@ -81,11 +89,10 @@ colTermShort resultTid = Colonnade.singleton (fromSortable header) body
|
||||
header = Sortable (Just "term") (i18nCell MsgTerm)
|
||||
body = i18nCell . ShortTermIdentifier . unTermKey . view resultTid
|
||||
|
||||
sortTerm :: OpticSortColumn (E.Value TermId)
|
||||
sortTerm :: OpticSortColumn TermId
|
||||
sortTerm queryTid = singletonMap "term" . SortColumn $ view queryTid
|
||||
|
||||
fltrTerm :: IsFilterColumn t (t -> Set TermId -> E.SqlExpr (E.Value Bool))
|
||||
=> OpticFilterColumn t (E.Value TermId)
|
||||
fltrTerm :: OpticFilterColumn t TermId
|
||||
fltrTerm queryTid = singletonMap "term" . FilterColumn $ mkExactFilter (view queryTid)
|
||||
|
||||
fltrTermUI :: DBFilterUI
|
||||
@ -101,11 +108,10 @@ colSchoolShort resultSsh = Colonnade.singleton (fromSortable header) body
|
||||
header = Sortable (Just "school") (i18nCell MsgSchool)
|
||||
body = i18nCell . unSchoolKey . view resultSsh
|
||||
|
||||
sortSchool :: OpticSortColumn (E.Value SchoolId)
|
||||
sortSchool :: OpticSortColumn SchoolId
|
||||
sortSchool querySsh = singletonMap "school" . SortColumn $ view querySsh
|
||||
|
||||
fltrSchool :: IsFilterColumn t (t -> Set SchoolId -> E.SqlExpr (E.Value Bool))
|
||||
=> OpticFilterColumn t (E.Value SchoolId)
|
||||
fltrSchool :: OpticFilterColumn t SchoolId
|
||||
fltrSchool querySsh = singletonMap "school" . FilterColumn $ mkExactFilter (view querySsh)
|
||||
|
||||
fltrSchoolUI :: DBFilterUI
|
||||
@ -121,15 +127,126 @@ colAllocationName resultName = Colonnade.singleton (fromSortable header) body
|
||||
header = Sortable (Just "allocation") (i18nCell MsgAllocationName)
|
||||
body = i18nCell . view resultName
|
||||
|
||||
sortAllocationName :: OpticSortColumn (E.Value AllocationName)
|
||||
sortAllocationName :: OpticSortColumn AllocationName
|
||||
sortAllocationName queryName = singletonMap "allocation" . SortColumn $ view queryName
|
||||
|
||||
fltrAllocationName :: IsFilterColumn t (t -> Set AllocationName -> E.SqlExpr (E.Value Bool))
|
||||
=> OpticFilterColumn t (E.Value AllocationName)
|
||||
fltrAllocationName queryName = singletonMap "allocation" . FilterColumn $ mkContainsFilter (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 Text) (E.SqlExpr allocation)
|
||||
fltrAllocation query = singletonMap "allocation" . FilterColumn $ anyFilter
|
||||
[ mkContainsFilterWith (unSqlProject' . CI.mk) $ views query (`E.sqlProject` AllocationShorthand)
|
||||
, mkContainsFilterWith (unSqlProject' . CI.mk) $ views query (`E.sqlProject` AllocationName)
|
||||
]
|
||||
where
|
||||
unSqlProject' = E.unSqlProject (Proxy @Allocation) (Proxy @allocation)
|
||||
|
||||
fltrAllocationNameUI :: DBFilterUI
|
||||
fltrAllocationNameUI mPrev = prismAForm (singletonFilter "allocation" . maybePrism _PathPiece) mPrev $ aopt (ciField :: Field _ AllocationName) (fslI MsgAllocation)
|
||||
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
|
||||
|
||||
-------------------------
|
||||
-- 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
|
||||
@ -178,9 +295,24 @@ 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
|
||||
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
|
||||
@ -189,11 +321,12 @@ colUserNameLink :: (IsDBTable m c, HasEntity a User) => (CryptoUUIDUser -> Route
|
||||
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)
|
||||
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)
|
||||
@ -261,7 +394,25 @@ fltrUserNameEmailUI mPrev =
|
||||
prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgCourseMembers)
|
||||
|
||||
-------------------
|
||||
-- Matriclenumber
|
||||
-- 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
|
||||
|
||||
@ -304,6 +455,109 @@ fltrUserEmailUI mPrev =
|
||||
-- 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
|
||||
|
||||
@ -408,3 +662,24 @@ anchorColonnadeM mkUrl = imapColonnade anchorColonnade'
|
||||
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
|
||||
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
module Handler.Utils.Table.Pagination
|
||||
( module Handler.Utils.Table.Pagination.Types
|
||||
, dbFilterKey
|
||||
, SomeExprValue(..)
|
||||
, SortColumn(..), SortDirection(..)
|
||||
, SortingSetting(..)
|
||||
, pattern SortAscBy, pattern SortDescBy
|
||||
@ -130,7 +131,10 @@ dbFilterKey :: PathPiece dbtIdent => dbtIdent -> FilterKey -> Text
|
||||
dbFilterKey ident = toPathPiece . WithIdent ident
|
||||
|
||||
|
||||
data SomeExprValue = forall a. PersistField a => SomeExprValue { getSomeExprValue :: E.SqlExpr (E.Value a) }
|
||||
|
||||
data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
|
||||
| SortColumns { getSortColumns :: t -> [SomeExprValue] }
|
||||
|
||||
data SortDirection = SortAsc | SortDesc
|
||||
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
|
||||
@ -147,9 +151,11 @@ deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 1
|
||||
} ''SortDirection
|
||||
|
||||
sqlSortDirection :: t -> (SortColumn t, SortDirection) -> E.SqlExpr E.OrderBy
|
||||
sqlSortDirection t (SortColumn e, SortAsc ) = E.asc $ e t
|
||||
sqlSortDirection t (SortColumn e, SortDesc) = E.desc $ e t
|
||||
sqlSortDirection :: t -> (SortColumn t, SortDirection) -> [E.SqlExpr E.OrderBy]
|
||||
sqlSortDirection t (SortColumn e , SortAsc ) = pure . E.asc $ e t
|
||||
sqlSortDirection t (SortColumn e , SortDesc) = pure . E.desc $ e t
|
||||
sqlSortDirection t (SortColumns es, SortAsc ) = es t <&> \(SomeExprValue v) -> E.asc v
|
||||
sqlSortDirection t (SortColumns es, SortDesc) = es t <&> \(SomeExprValue v) -> E.desc v
|
||||
|
||||
|
||||
data SortingSetting = SortingSetting
|
||||
@ -867,7 +873,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
|
||||
rows' <- E.select . E.from $ \t -> do
|
||||
res <- dbtSQLQuery t
|
||||
E.orderBy (map (sqlSortDirection t) psSorting')
|
||||
E.orderBy $ concatMap (sqlSortDirection t) psSorting'
|
||||
case csvMode of
|
||||
FormSuccess DBCsvExport -> return ()
|
||||
FormSuccess DBCsvImport{} -> return ()
|
||||
|
||||
@ -91,6 +91,8 @@ import Data.Void as Import (Void)
|
||||
|
||||
import Algebra.Lattice as Import hiding (meet, join)
|
||||
|
||||
import Data.Proxy as Import (Proxy(..))
|
||||
|
||||
import Language.Haskell.TH.Instances as Import ()
|
||||
import Data.List.NonEmpty.Instances as Import ()
|
||||
import Data.NonNull.Instances as Import ()
|
||||
|
||||
@ -18,6 +18,17 @@ type Points = Centi
|
||||
|
||||
type Email = Text
|
||||
|
||||
type UserDisplayName = Text
|
||||
type UserSurname = Text
|
||||
type UserMatriculation = Text
|
||||
|
||||
type StudyDegreeName = Text
|
||||
type StudyDegreeShorthand = Text
|
||||
type StudyDegreeKey = Int
|
||||
type StudyTermsName = Text
|
||||
type StudyTermsShorthand = Text
|
||||
type StudyTermsKey = Int
|
||||
|
||||
type SchoolName = CI Text
|
||||
type SchoolShorthand = CI Text
|
||||
type CourseName = CI Text
|
||||
|
||||
@ -59,6 +59,8 @@ data Icon
|
||||
| IconApplyTrue
|
||||
| IconApplyFalse
|
||||
| IconNoCorrectors
|
||||
| IconApplicationVeto
|
||||
| IconApplicationFiles
|
||||
deriving (Eq, Ord, Enum, Bounded, Show, Read)
|
||||
|
||||
iconText :: Icon -> Text
|
||||
@ -92,6 +94,8 @@ iconText = \case
|
||||
IconApplyTrue -> "file-alt"
|
||||
IconApplyFalse -> "trash"
|
||||
IconNoCorrectors -> "user-slash"
|
||||
IconApplicationVeto -> "times"
|
||||
IconApplicationFiles -> "file-alt"
|
||||
|
||||
instance Universe Icon
|
||||
instance Finite Icon
|
||||
|
||||
@ -14,7 +14,7 @@ import Control.Lens as Utils.Lens
|
||||
, Index, index, (<.)
|
||||
)
|
||||
import Control.Lens.Extras as Utils.Lens (is)
|
||||
import Utils.Lens.TH as Utils.Lens (makeLenses_, makeClassyFor_)
|
||||
import Utils.Lens.TH as Utils.Lens
|
||||
import Data.Set.Lens as Utils.Lens
|
||||
|
||||
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
|
||||
|
||||
@ -1,10 +1,17 @@
|
||||
module Utils.Lens.TH where
|
||||
module Utils.Lens.TH
|
||||
( makeLenses_, makeClassyFor_
|
||||
, multifocusG, multifocusL
|
||||
) where
|
||||
|
||||
import ClassyPrelude (Maybe(..), (<>))
|
||||
import ClassyPrelude
|
||||
import Control.Lens
|
||||
import Control.Lens.Internal.FieldTH
|
||||
import Language.Haskell.TH
|
||||
|
||||
import Numeric.Natural
|
||||
|
||||
import Data.Foldable (Foldable(foldl))
|
||||
|
||||
-- import Control.Lens.Misc
|
||||
{-
|
||||
NOTE: The code for lensRules_ and makeLenses_ was stolen from package lens-misc-0.0.2.0,
|
||||
@ -65,3 +72,47 @@ makeClassyFor_ recName = makeFieldOptics (classyRulesFor_ clNamer) recName
|
||||
clNamer :: ClassyNamer
|
||||
-- clNamer _ = Just (clsName, funName) -- for newer versions >= 4.17
|
||||
clNamer _ = Just (mkName clsName, mkName funName)
|
||||
|
||||
multifocusG :: Natural -> ExpQ
|
||||
multifocusG = multifocusOptic
|
||||
[e|to . view|]
|
||||
(\s a -> [t|Getting $(a) $(s) $(a)|])
|
||||
(\s a -> [t|Getter $(s) $(a)|])
|
||||
(\doGet _doSet -> [e|to $(doGet)|])
|
||||
|
||||
multifocusL :: Natural -> ExpQ
|
||||
multifocusL = multifocusOptic
|
||||
[e|cloneLens|]
|
||||
(\s a -> [t|ALens' $(s) $(a)|])
|
||||
(\s a -> [t|Lens' $(s) $(a)|])
|
||||
(\doGet doSet -> [e|lens $(doGet) $(doSet)|])
|
||||
|
||||
|
||||
multifocusOptic :: _ -> _ -> _ -> _ -> Natural -> ExpQ
|
||||
multifocusOptic _ _ _ _ 0 = [e|united|]
|
||||
multifocusOptic doClone _ _ _ 1 = doClone
|
||||
multifocusOptic doClone alensT lensT lens' (fromIntegral -> n) = do
|
||||
ll <- newName "l"
|
||||
ls <- replicateM n $ newName "l"
|
||||
s <- newName "s"
|
||||
xs <- replicateM n $ newName "x"
|
||||
|
||||
tS <- newName "s"
|
||||
tXs <- replicateM n $ newName "x" :: Q [Name]
|
||||
|
||||
let tup = foldl (\t x -> [t|$(t) $(varT x)|]) (tupleT (length tXs)) tXs
|
||||
mkL x = alensT (varT tS) (varT x)
|
||||
|
||||
letE
|
||||
[ sigD ll $ foldr (\x t -> [t|$(mkL x) -> $(t)|]) (lensT (varT tS) tup) tXs
|
||||
, funD ll
|
||||
[ clause
|
||||
(map (viewP doClone . varP) ls)
|
||||
(normalB $ lens'
|
||||
(lamE [varP s] . tupE . flip map ls $ \l -> [e| $(varE s) ^. $(varE l) |])
|
||||
(lamE [varP s, tupP $ map varP xs] . foldr (\(x, l) x' -> [e|$(x') & $(varE l) .~ $(varE x)|]) (varE s) $ zip xs ls)
|
||||
)
|
||||
[]
|
||||
]
|
||||
]
|
||||
(varE ll)
|
||||
|
||||
@ -23,7 +23,7 @@ setSerializable act = setSerializable' (0 :: Integer)
|
||||
let
|
||||
delay :: NominalDiffTime
|
||||
delay = 1e-3 * 2 ^ logBackoff
|
||||
$logWarnS "Sql" $ tshow (delay, e)
|
||||
$logDebugS "Sql" $ tshow (delay, e)
|
||||
transactionUndo
|
||||
threadDelay . round $ delay * 1e6
|
||||
setSerializable' (succ logBackoff)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user