diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 1dd86e0ac..319ca6f36 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -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 \ No newline at end of file +AllocationListTitle: Zentralanmeldungen + +CourseApplicationsListTitle: Bewerbungen +CourseApplicationId: Bewerbungsnummer +CourseApplicationRatingPoints: Bewertung +CourseApplicationVeto: Veto + +UserDisplayName: Voller Name +UserMatriculation: Matrikelnummer \ No newline at end of file diff --git a/models/users b/models/users index 33a92adf1..21143848c 100644 --- a/models/users +++ b/models/users @@ -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 diff --git a/src/Application.hs b/src/Application.hs index fc6d0fc8f..fe1bc98ff 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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 diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 201091a2d..beaddbc0d 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -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 diff --git a/src/Foundation.hs b/src/Foundation.hs index c4c722ff2..60c71de8f 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 diff --git a/src/Handler/Allocation/List.hs b/src/Handler/Allocation/List.hs index 372625b7e..d87161bd7 100644 --- a/src/Handler/Allocation/List.hs +++ b/src/Handler/Allocation/List.hs @@ -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{..} diff --git a/src/Handler/Course/Application.hs b/src/Handler/Course/Application.hs index 7bdbb62ba..998ff9670 100644 --- a/src/Handler/Course/Application.hs +++ b/src/Handler/Course/Application.hs @@ -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 diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs index 54c2ec760..8a34cde8d 100644 --- a/src/Handler/CryptoIDDispatch.hs +++ b/src/Handler/CryptoIDDispatch.hs @@ -5,8 +5,6 @@ module Handler.CryptoIDDispatch import Import -import Data.Proxy - import qualified Data.Text as Text import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..)) diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 540b05040..b040cf31e 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -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(..)) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 4a7e437b8..9df6e64d6 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -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" diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 0808063ba..77372489b 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -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 + diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 4d4fad644..7fdeb9ea8 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -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 () diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 4e32cd1c8..ea3a99691 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -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 () diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs index 53ff47cce..a023f44d7 100644 --- a/src/Model/Types/Common.hs +++ b/src/Model/Types/Common.hs @@ -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 diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 30f62a959..23aa34f6e 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -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 diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 2ffad4deb..8f1cc1357 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -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(..)) diff --git a/src/Utils/Lens/TH.hs b/src/Utils/Lens/TH.hs index 701c87b76..0042fb308 100644 --- a/src/Utils/Lens/TH.hs +++ b/src/Utils/Lens/TH.hs @@ -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) diff --git a/src/Utils/Sql.hs b/src/Utils/Sql.hs index aae593c05..b0aa13ef2 100644 --- a/src/Utils/Sql.hs +++ b/src/Utils/Sql.hs @@ -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)