Alternative Query Attempt

This commit is contained in:
SJost 2019-03-05 17:20:34 +01:00
parent 382a34f970
commit 56c25c133a
3 changed files with 50 additions and 0 deletions

View File

@ -649,6 +649,31 @@ validateCourse CourseForm{..} =
--------------------
-- CourseUserTable
userTableQuery' :: CourseId -> E.Esqueleto query expr backend =>
E.LeftOuterJoin
(E.LeftOuterJoin
(E.InnerJoin
(expr (Entity User)) (expr (Entity CourseParticipant)))
(expr (Maybe (Entity CourseUserNote))))
(E.InnerJoin
(E.InnerJoin
(expr (Maybe (Entity StudyFeatures)))
(expr (Maybe (Entity StudyDegree))))
(expr (Maybe (Entity StudyTerms))))
-> 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
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
E.on $ degree E.?. StudyDegreeId E.==. features E.?. StudyFeaturesDegree
E.on $ E.just (participant E.^. CourseParticipantUser) E.==. note E.?. CourseUserNoteUser
E.on $ participant E.^. CourseParticipantUser E.==. user E.^. UserId
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)

View File

@ -1,6 +1,7 @@
module Handler.Utils.Database
( getSchoolsOf
, makeSchoolDictionaryDB, makeSchoolDictionary
, studyFeaturesQuery, studyFeaturesQuery'
) where
import Import
@ -29,3 +30,25 @@ getSchoolsOf uid uschool uuser = fmap (Import.map E.unValue) $ E.select $ E.from
E.where_ $ urights E.^. uuser E.==. E.val uid
E.orderBy [E.asc $ school E.^.SchoolName]
return $ school E.^. SchoolName
studyFeaturesQuery :: E.Esqueleto query expr backend
=> expr (E.Value (Maybe StudyFeaturesId)) -- ^ query is filtered by StudyFeatureId
-> (expr (Entity StudyFeatures)) `E.InnerJoin` (expr (Entity StudyDegree)) `E.InnerJoin` (expr (Entity StudyTerms))
-> query (expr (Entity StudyFeatures), expr (Entity StudyDegree), expr (Entity StudyTerms))
studyFeaturesQuery sfId (features `E.InnerJoin` degree `E.InnerJoin` terms) = do
E.on $ terms E.^. StudyTermsId E.==. features E.^. StudyFeaturesField
E.on $ degree E.^. StudyDegreeId E.==. features E.^. StudyFeaturesDegree
E.where_ $ (E.just (features E.^. StudyFeaturesId)) E.==. sfId
return (features, degree, terms)
-- | Variant of @studyFeaturesQuery@ to be used in outer joins
studyFeaturesQuery' :: E.Esqueleto query expr backend
=> expr (E.Value (Maybe StudyFeaturesId)) -- ^ query is filtered by StudyFeatureId
-> (expr (Maybe (Entity StudyFeatures)) `E.InnerJoin` (expr (Maybe (Entity StudyDegree))) `E.InnerJoin` (expr (Maybe (Entity StudyTerms))))
-> query (expr (Maybe (Entity StudyFeatures)), expr (Maybe (Entity StudyDegree)), expr (Maybe (Entity StudyTerms)))
studyFeaturesQuery' sfId (features `E.InnerJoin` degree `E.InnerJoin` terms) = do
E.on $ terms E.?. StudyTermsId E.==. features E.?. StudyFeaturesField
E.on $ degree E.?. StudyDegreeId E.==. features E.?. StudyFeaturesDegree
E.where_ $ features E.?. StudyFeaturesId E.==. sfId
return (features, degree, terms)

View File

@ -41,9 +41,11 @@ maybeCell =flip foldMap
---------------------
-- Icon cells
-- | Maybe display a tickmark/checkmark icon
tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a
tickmarkCell = cell . toWidget . hasTickmark
-- | Maybe display comment icon linking a given URL or show nothing at all
commentCell :: IsDBTable m a => Maybe (Route UniWorX) -> DBCell m a
commentCell Nothing = mempty
commentCell (Just link) = anchorCell link icon