From 484d99305d4a4f48c48df2cedb244b08a01c52f4 Mon Sep 17 00:00:00 2001 From: SJost Date: Tue, 5 Mar 2019 19:06:12 +0100 Subject: [PATCH] Showing field and degrees compiles, join-on needs testing --- messages/uniworx/de.msg | 2 + src/Handler/Course.hs | 84 +++++++++++++------------------- src/Handler/Utils/Table/Cells.hs | 6 ++- src/Utils/Lens.hs | 2 + 4 files changed, 43 insertions(+), 51 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 713524bf1..38c834069 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -405,6 +405,8 @@ SheetCorrectorSubmissionsTip: Abgabe erfolgt über ein Uni2work-externes Verfahr SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen. +StudyFeatureAge: Fachsemester +StudyFeatureDegree: Abschluss FieldPrimary: Hauptfach FieldSecondary: Nebenfach diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index b4d40a905..953d349d3 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -650,7 +650,16 @@ validateCourse CourseForm{..} = -- CourseUserTable -userTableQuery' :: CourseId -> E.Esqueleto query expr backend => + +type UserTableExpr = (E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote)) + `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin`E.SqlExpr (Maybe (Entity StudyTerms))) +type UserTableData = DBRow (Entity User, UTCTime, Maybe CourseUserNoteId, (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms)) + +forceUserTableType :: (UserTableExpr -> a) -> (UserTableExpr -> a) +forceUserTableType = id + +userTableQuery :: CourseId -> E.Esqueleto query expr backend => E.LeftOuterJoin (E.LeftOuterJoin (E.InnerJoin @@ -664,7 +673,7 @@ userTableQuery' :: CourseId -> E.Esqueleto query expr backend => -> query (expr (Entity User), expr (E.Value UTCTime), expr (E.Value (Maybe (Key CourseUserNote))), (expr (Maybe (Entity StudyFeatures)), expr (Maybe (Entity StudyDegree)), expr (Maybe (Entity StudyTerms)))) -userTableQuery' cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.LeftOuterJoin` _studyFeatures@(features `E.InnerJoin` degree `E.InnerJoin` terms)) = do +userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.LeftOuterJoin` _studyFeatures@(features `E.InnerJoin` degree `E.InnerJoin` terms)) = do E.on $ participant E.^. CourseParticipantField E.==. features E.?. StudyFeaturesId --(features, degree, terms) <- studyFeaturesQuery (participant E.^. CourseParticipantField) studyFeatures E.on $ terms E.?. StudyTermsId E.==. features E.?. StudyFeaturesField @@ -674,33 +683,6 @@ userTableQuery' cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E. E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid return (user, participant E.^. CourseParticipantRegistration, note E.?. CourseUserNoteId, (features,degree,terms)) -type UserTableExpr = (E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote)) -type UserTableWhere = UserTableExpr -> E.SqlExpr (E.Value Bool) -type UserTableData = DBRow (Entity User, UTCTime, Maybe CourseUserNoteId) - -forceUserTableType :: (UserTableExpr -> a) -> (UserTableExpr -> a) -forceUserTableType = id - -userTableQuery :: UserTableWhere -> UserTableExpr - -> E.SqlQuery ( E.SqlExpr (Entity User) - , E.SqlExpr (E.Value UTCTime) - , E.SqlExpr (E.Value (Maybe CourseUserNoteId)) - -- , E.SqlExpr (E.ValueList (Entity StudyFeatures), E.SqlExpr (Entity StudyDegree), E.SqlExpr (Entity StudyTerms)) - ) -userTableQuery whereClause t@((user `E.InnerJoin` participant) `E.LeftOuterJoin` note) = do - E.on $ E.just (participant E.^. CourseParticipantUser) E.==. note E.?. CourseUserNoteUser - E.on $ participant E.^. CourseParticipantUser E.==. user E.^. UserId - E.where_ $ whereClause t - -- let feature = E.case_ [E.when_ (E.isNothing $ participant E.^. CourseParticipantField) E.then_ E.nothing] - -- (E.else_ features ) - -- let dfeat :: _hole -- E.SqlQuery (E.ValueList (E.SqlExpr (Entity StudyFeatures), E.SqlExpr (Entity StudyDegree), E.SqlExpr (Entity StudyTerms))) - -- dfeat = E.subList_select $ E.from $ \(feature `E.InnerJoin` degree `E.InnerJoin` terms) -> do - -- E.on $ feature E.^. StudyFeaturesField E.==. terms E.^. StudyTermsId - -- E.on $ feature E.^. StudyFeaturesDegree E.==. degree E.^. StudyDegreeId - -- E.where_ $ (E.just (feature E.^. StudyFeaturesId)) E.==. (participant E.^. CourseParticipantField) - -- E.limit 1 - -- return (feature,degree,terms) - return (user, participant E.^. CourseParticipantRegistration, note E.?. CourseUserNoteId) instance HasEntity UserTableData User where hasEntity = _dbrOutput . _1 @@ -715,40 +697,40 @@ _userTableRegistration = _dbrOutput . _2 _userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId) _userTableNote = _dbrOutput . _3 --- default Where-Clause -courseIs :: CourseId -> UserTableWhere -courseIs cid ((_user `E.InnerJoin` participant) `E.LeftOuterJoin` _note) = participant E.^. CourseParticipantCourse E.==. E.val cid +_userTableFeatures :: Lens' UserTableData (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms) +_userTableFeatures = _dbrOutput . _4 colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c) colUserComment tid ssh csh = sortable (Just "course-user-note") (i18nCell MsgCourseUserNote) - $ \DBRow{ dbrOutput=(Entity uid _, _, mbNoteKey) } -> + $ \DBRow{ dbrOutput=(Entity uid _, _, mbNoteKey,_) } -> maybeEmpty mbNoteKey $ const $ anchorCellM (courseLink <$> encrypt uid) (toWidget $ hasComment True) where courseLink = CourseR tid ssh csh . CUserR - -- makeCourseUserTable :: (ToSortable h, Functor h) => - -- UserTableWhere - -- -> Colonnade - -- h - -- (DBRow - -- (Entity User, E.Value UTCTime, - -- E.Value (Maybe CourseUserNoteId))) - -- (DBCell (HandlerT UniWorX IO) ()) - -- -> PSValidator (HandlerT UniWorX IO) () - -- -> ReaderT SqlBackend (HandlerT UniWorX IO) Widget +colUserSemester :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) +colUserSemester = sortable (Just "course-user-semesternr") (i18nCell MsgStudyFeatureAge) $ + foldMap numCell . preview (_userTableFeatures . _1 . _Just . _studyFeaturesSemester) -makeCourseUserTable :: UserTableWhere -> _ -> _ -> DB Widget -makeCourseUserTable whereClause colChoices psValidator = +colUserField :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) +colUserField = sortable (Just "course-user-field") (i18nCell MsgCourseStudyFeature) $ + foldMap htmlCell . view (_userTableFeatures . _3) + +colUserDegree :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) +colUserDegree = sortable (Just "course-user-degree") (i18nCell MsgStudyFeatureDegree) $ + foldMap htmlCell . preview (_userTableFeatures . _2 . _Just) + +makeCourseUserTable :: CourseId -> _ -> _ -> DB Widget +makeCourseUserTable cid colChoices psValidator = -- return [whamlet|TODO|] -- TODO -- -- psValidator has default sorting and filtering let dbtIdent = "courseUsers" :: Text dbtStyle = def - dbtSQLQuery = userTableQuery whereClause - dbtRowKey ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note) = user E.^. UserId - dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId) -> return (user, registrationTime, userNoteId) + dbtSQLQuery = userTableQuery cid + dbtRowKey ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` _studyFeatures) = user E.^. UserId + dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms)) dbtColonnade = colChoices dbtSorting = Map.fromList [] -- TODO dbtFilter = Map.fromList [] -- TODO @@ -761,16 +743,18 @@ getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCUsersR tid ssh csh = do Entity cid course <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh let heading = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|] - whereClause = courseIs cid colChoices = mconcat [ colUserParticipantLink tid ssh csh , colUserEmail , colUserMatriclenr + , colUserDegree + , colUserField + , colUserSemester , sortable (Just "registration") (i18nCell MsgRegisteredHeader) (dateCell . view _userTableRegistration) , colUserComment tid ssh csh ] psValidator = def - tableWidget <- runDB $ makeCourseUserTable whereClause colChoices psValidator + tableWidget <- runDB $ makeCourseUserTable cid colChoices psValidator siteLayout heading $ do setTitle [shamlet| #{toPathPiece tid} - #{csh}|] -- TODO: creat hamlet wrapper diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index c6ec3e24d..47f4f6e8b 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -9,6 +9,8 @@ import Data.Monoid (Any(..)) import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Trans.Writer (WriterT) +import Text.Blaze (ToMarkup(..)) + import Utils.Lens import Handler.Utils @@ -35,8 +37,10 @@ writerCell :: IsDBTable m w => WriterT w m () -> DBCell m w writerCell act = mempty & cellContents %~ (<* act) maybeCell :: (IsDBTable m a) => Maybe a -> (a -> DBCell m a) -> DBCell m a -maybeCell =flip foldMap +maybeCell = flip foldMap +htmlCell :: (IsDBTable m a, ToMarkup c) => c -> DBCell m a +htmlCell = cell . toWidget . toMarkup --------------------- -- Icon cells diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index b8ac05e63..fc7e7a18e 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -80,6 +80,8 @@ makeLenses_ ''SheetType makePrisms ''AuthResult +makeLenses_ ''StudyFeatures + -- makeClassy_ ''Load