Showing field and degrees compiles, join-on needs testing

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
 

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
+_userTableFeatures :: Lens' UserTableData (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms)
-courseIs :: CourseId -> UserTableWhere
+_userTableFeatures = _dbrOutput . _4
-courseIs cid ((_user `E.InnerJoin` participant) `E.LeftOuterJoin` _note) = participant E.^. CourseParticipantCourse E.==. E.val cid
 
 
 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) =>
+colUserSemester :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
-    --                          UserTableWhere
+colUserSemester = sortable (Just "course-user-semesternr") (i18nCell MsgStudyFeatureAge) $
-    --                          -> Colonnade
+    foldMap numCell . preview (_userTableFeatures . _1 . _Just . _studyFeaturesSemester)
-    --                               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
 
-makeCourseUserTable :: UserTableWhere -> _ -> _ -> DB Widget
+colUserField :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
-makeCourseUserTable whereClause colChoices psValidator =
+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
+      dbtSQLQuery  = userTableQuery cid
-      dbtRowKey ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note) = user E.^. UserId
+      dbtRowKey ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` _studyFeatures) = user E.^. UserId
-      dbtProj      = traverse $ \(user, E.Value registrationTime , E.Value userNoteId) -> return (user, registrationTime, userNoteId)
+      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

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

src/Utils/Lens.hs

@@ -80,6 +80,8 @@ makeLenses_ ''SheetType
 
 makePrisms ''AuthResult
 
+makeLenses_ ''StudyFeatures
+
 -- makeClassy_ ''Load