Showing field and degrees compiles, join-on needs testing
This commit is contained in:
SJost
parent
56c25c133a
commit
484d99305d
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -80,6 +80,8 @@ makeLenses_ ''SheetType
|
||||
|
||||
makePrisms ''AuthResult
|
||||
|
||||
makeLenses_ ''StudyFeatures
|
||||
|
||||
-- makeClassy_ ''Load
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user