From a6e2f6491048186415546f5cbbd513b75c123026 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 22 Aug 2019 17:08:19 +0200 Subject: [PATCH] feat(home): clean up homepage --- messages/uniworx/de.msg | 4 +- src/Database/Esqueleto/Utils.hs | 16 ++- src/Foundation.hs | 12 ++- src/Handler/Allocation/List.hs | 9 +- src/Handler/Course/List.hs | 17 +++- src/Handler/Home.hs | 147 ++------------------------- src/Handler/Utils/Table/Columns.hs | 33 +++++- templates/home/openCourses.hamlet | 4 - templates/i18n/unauth-home/de.hamlet | 5 + 9 files changed, 87 insertions(+), 160 deletions(-) delete mode 100644 templates/home/openCourses.hamlet create mode 100644 templates/i18n/unauth-home/de.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 7e29f48b9..5cf794630 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -452,7 +452,6 @@ NotificationSettingsHeading displayName@Text: Benachrichtigungs-Einstellungen f TokensLastReset: Tokens zuletzt invalidiert TokensResetSuccess: Authorisierungs-Tokens invalidiert -HomeOpenCourses: Kurse mit offener Registrierung HomeOpenAllocations: Offene Zentralanmeldungen HomeUpcomingSheets: Anstehende Übungsblätter HomeUpcomingExams: Bevorstehende Prüfungen @@ -953,6 +952,8 @@ ErrorCryptoIdMismatch: Verschlüsselte Id der Abgabe passte nicht zu anderen Dat InvalidRoute: Konnte URL nicht interpretieren +MenuOpenCourses: Kurse mit offener Registrierung +MenuOpenAllocations: Aktive Zentralanmeldungen MenuHome: Aktuell MenuInformation: Informationen MenuImpressum: Impressum @@ -1471,6 +1472,7 @@ MailSchoolLecturerInviteHeading school@SchoolName: Einladung zum Dozent für „ SchoolLecturerInviteExplanation: Sie wurden eingeladen, Dozent für ein Institut zu sein. Sie können, nachdem Sie die Einladung annehmen, eigenständig neue Kurse anlegen. SchoolLecturerInvitationAccepted school@SchoolName: Einladung zum Dozent für „#{school}“ angenommen +AllocationActive: Aktiv AllocationName: Name AllocationTitle termText@Text ssh'@SchoolShorthand allocation@AllocationName: #{termText} - #{ssh'}: #{allocation} AllocationShortTitle termText@Text ssh'@SchoolShorthand ash@AllocationShorthand: #{termText} - #{ssh'} - #{ash} diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index beaddbc0d..74bfbb7d6 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -162,21 +162,17 @@ mkExistsFilter query row criterias | otherwise = any (E.exists . query row) $ Set.toList criterias -- | Combine several filters, using logical or -anyFilter :: (Foldable f) - => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool)) - -> t - -> Set.Set Text - -> E.SqlExpr (E.Value Bool) +anyFilter :: Foldable f + => f (t -> cs -> E.SqlExpr (E.Value Bool)) + -> (t -> cs -> E.SqlExpr (E.Value Bool)) anyFilter fltrs needle criterias = F.foldr aux false fltrs where aux fltr acc = fltr needle criterias E.||. acc -- | Combine several filters, using logical and -allFilter :: (Foldable f) - => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool)) - -> t - -> Set.Set Text - -> E.SqlExpr (E.Value Bool) +allFilter :: Foldable f + => f (t -> cs -> E.SqlExpr (E.Value Bool)) + -> (t -> cs -> E.SqlExpr (E.Value Bool)) allFilter fltrs needle criterias = F.foldr aux true fltrs where aux fltr acc = fltr needle criterias E.&&. acc diff --git a/src/Foundation.hs b/src/Foundation.hs index 26a321ed0..247a9bb91 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1978,9 +1978,17 @@ pageActions (HomeR) = } , MenuItem { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuAllocationList + , menuItemLabel = MsgMenuOpenCourses , menuItemIcon = Nothing - , menuItemRoute = SomeRoute AllocationListR + , menuItemRoute = SomeRoute (CourseListR, [("courses-openregistration", "True")]) + , menuItemModal = False + , menuItemAccessCallback' = return True + } + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuOpenAllocations + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute (AllocationListR, [("allocations-active", "True")]) , menuItemModal = False , menuItemAccessCallback' = return True } diff --git a/src/Handler/Allocation/List.hs b/src/Handler/Allocation/List.hs index d87161bd7..38069fc4c 100644 --- a/src/Handler/Allocation/List.hs +++ b/src/Handler/Allocation/List.hs @@ -32,6 +32,7 @@ allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocatio getAllocationListR :: Handler Html getAllocationListR = do + now <- liftIO getCurrentTime let dbtSQLQuery :: AllocationTableExpr -> E.SqlQuery _ dbtSQLQuery = return @@ -55,12 +56,14 @@ getAllocationListR = do ] dbtFilter = mconcat - [ fltrTerm $ queryAllocation . to (E.^. AllocationTerm) + [ fltrAllocationActive now queryAllocation + , fltrTerm $ queryAllocation . to (E.^. AllocationTerm) , fltrSchool $ queryAllocation . to (E.^. AllocationSchool) , fltrAllocation queryAllocation ] dbtFilterUI = mconcat - [ fltrTermUI + [ fltrAllocationActiveUI + , fltrTermUI , fltrSchoolUI , fltrAllocationUI ] @@ -77,7 +80,7 @@ getAllocationListR = do psValidator :: PSValidator _ _ psValidator = def - & defaultSorting [SortAscBy "term", SortAscBy "school", SortAscBy "allocation"] + & defaultSorting [SortDescBy "term", SortAscBy "school", SortAscBy "allocation"] table <- runDB $ dbTableWidget' psValidator DBTable{..} diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs index 57ab63b48..3f919290e 100644 --- a/src/Handler/Course/List.hs +++ b/src/Handler/Course/List.hs @@ -141,7 +141,22 @@ makeCourseTable whereClause colChoices psValidator = do Nothing -> E.val True Just b -> let regTo = course E.^. CourseRegisterTo regFrom = course E.^. CourseRegisterFrom - in (E.==.) (E.val b) $ (E.isNothing regTo E.||. E.val (Just now) E.<=. regTo) E.&&. E.val (Just now) E.>=. regFrom + courseOpen = E.maybe E.false (\f -> f E.<=. E.val now) regFrom + E.&&. E.maybe E.true (\t -> E.val now E.<=. t) regTo + alloc allocation = do + E.where_ . E.exists . E.from $ \allocationCourse -> + E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId + return allocation + allocOpen allocation = ( E.maybe E.false (\f -> f E.<=. E.val now) (allocation E.^. AllocationRegisterFrom) + E.&&. E.maybe E.true (\t -> E.val now E.<=. t) (allocation E.^. AllocationRegisterTo) + ) + E.||. ( courseOpen + E.&&. E.maybe E.false (\f -> f E.<=. E.val now) (allocation E.^. AllocationRegisterByCourse) + ) + in (E.==. E.val b) $ ( courseOpen + E.&&. E.not_ (E.exists . void $ E.from alloc) + ) + E.||. E.exists (E.from $ E.where_ . allocOpen <=< alloc) ) , ( "registered", FilterColumn $ \tExpr criterion -> case getLast (criterion :: Last Bool) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index c3ebe55dd..eec4b71ab 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -14,142 +14,16 @@ import qualified Database.Esqueleto.Utils as E getHomeR :: Handler Html getHomeR = do muid <- maybeAuthId - upcomingExamsWidget <- for muid $ runDB . homeUpcomingExams defaultLayout $ do setTitleI MsgHomeHeading - fromMaybe mempty upcomingExamsWidget - maybe mempty homeUpcomingSheets muid - homeOpenAllocations - homeOpenCourses + case muid of + Just uid -> do + homeUpcomingExams uid + homeUpcomingSheets uid + Nothing -> + $(i18nWidgetFile "unauth-home") -homeOpenAllocations :: Widget -homeOpenAllocations = do - cTime <- liftIO getCurrentTime - let tableData :: E.SqlExpr (Entity Allocation) - -> E.SqlQuery (E.SqlExpr (Entity Allocation)) - tableData allocation = do - E.where_ $ E.maybe E.false (\rf -> rf E.<=. E.val cTime) (allocation E.^. AllocationRegisterFrom) - E.&&. E.maybe E.true (\rt -> rt E.>=. E.val cTime) (allocation E.^. AllocationRegisterTo) - return allocation - - colonnade :: Colonnade Sortable (DBRow (Entity Allocation)) (DBCell (HandlerT UniWorX IO) ()) - colonnade = mconcat - [ -- dbRow - sortable (Just "term") (i18nCell MsgTerm) - $ \DBRow{ dbrOutput=Entity{entityVal = Allocation{..}} } -> - anchorCell (TermCourseListR allocationTerm) [whamlet|#{allocationTerm}|] - , sortable (Just "schoolshort") (i18nCell MsgAllocationSchoolShort) - $ \DBRow{ dbrOutput=(Entity _ Allocation{..}) } -> - anchorCell (TermSchoolCourseListR allocationTerm allocationSchool) [whamlet|_{unSchoolKey allocationSchool}|] - , sortable (Just "allocation") (i18nCell MsgAllocation) $ \DBRow{ dbrOutput=Entity{entityVal = Allocation{..}} } -> do - anchorCell (AllocationR allocationTerm allocationSchool allocationShorthand AShowR) allocationName - , sortable (Just "deadline") (i18nCell MsgAllocationRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = Allocation{..}} } -> - cell $ traverse (formatTime SelFormatDateTime) allocationRegisterTo >>= maybe mempty toWidget - ] - validator = def & defaultSorting [SortAscBy "deadline", SortAscBy "allocation"] - allocationTable <- liftHandlerT . runDB $ dbTableWidget' validator DBTable - { dbtSQLQuery = tableData - , dbtRowKey = (E.^. AllocationId) - , dbtColonnade = colonnade - , dbtProj = return - , dbtSorting = Map.fromList - [ ( "term" - , SortColumn $ \allocation -> allocation E.^. AllocationTerm - ) - , ( "schoolshort" - , SortColumn $ \allocation -> allocation E.^. AllocationSchool - ) - , ( "allocation" - , SortColumn $ \allocation -> allocation E.^. AllocationShorthand - ) - , ( "deadline" - , SortColumn $ \allocation -> allocation E.^. AllocationRegisterTo - ) - ] - , dbtFilter = mempty - , dbtFilterUI = mempty - , dbtStyle = def - , dbtParams = def - , dbtIdent = "open-allocations" :: Text - , dbtCsvEncode = noCsvEncode - , dbtCsvDecode = Nothing - } - $(widgetFile "home/openAllocations") - - -homeOpenCourses :: Widget -homeOpenCourses = do - cTime <- liftIO getCurrentTime - let tableData :: E.SqlExpr (Entity Course) - -> E.SqlQuery (E.SqlExpr (Entity Course)) - tableData course = do - E.where_ $ E.not_ (E.isNothing $ course E.^. CourseRegisterFrom) -- DO: do this with isAuthorized in dbtProj - E.&&. (course E.^. CourseRegisterFrom E.<=. E.val (Just cTime)) - E.&&. ( E.isNothing (course E.^. CourseRegisterTo) - E.||. course E.^. CourseRegisterTo E.>=. E.val (Just cTime) - ) - E.&&. E.not_ (E.exists . E.from $ \(allocation `E.InnerJoin` allocationCourse) -> do - E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation - E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId - E.where_ $ E.maybe E.true (\rf -> rf E.>. E.val cTime) (allocation E.^. AllocationRegisterFrom) - E.||. E.maybe E.false (\rt -> rt E.<. E.val cTime) (allocation E.^. AllocationRegisterTo) - E.where_ $ E.maybe E.true (\rf -> rf E.>. E.val cTime) (allocation E.^. AllocationRegisterByCourse) - ) - return course - - colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (HandlerT UniWorX IO) ()) - colonnade = mconcat - [ -- dbRow - sortable (Just "term") (i18nCell MsgTerm) - $ \DBRow{ dbrOutput=Entity{entityVal = Course{..}} } -> - anchorCell (TermCourseListR courseTerm) [whamlet|#{courseTerm}|] - , sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort) - $ \DBRow{ dbrOutput=(Entity _ Course{..}) } -> - anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{unSchoolKey courseSchool}|] - , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> do - let tid = courseTerm course - ssh = courseSchool course - csh = courseShorthand course - anchorCell (CourseR tid ssh csh CShowR) csh - , sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> - cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget - ] - validator = def & defaultSorting [SortAscBy "deadline", SortAscBy "course"] - courseTable <- liftHandlerT . runDB $ dbTableWidget' validator DBTable - { dbtSQLQuery = tableData - , dbtRowKey = (E.^. CourseId) - , dbtColonnade = colonnade - , dbtProj = return - , dbtSorting = Map.fromList - [ ( "term" - , SortColumn $ \course -> course E.^. CourseTerm - ) - , ( "schoolshort" - , SortColumn $ \course -> course E.^. CourseSchool - ) - , ( "course" - , SortColumn $ \course -> course E.^. CourseShorthand - ) - , ( "deadline" - , SortColumn $ \course -> course E.^. CourseRegisterTo - ) - ] - , dbtFilter = mempty {- [ ( "term" - , FilterColumn $ \(course `E.InnerJoin` _ `E.InnerJoin` _ ) tids -> if - | Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids) - ) - ] -} - , dbtFilterUI = mempty - , dbtStyle = def - , dbtParams = def - , dbtIdent = "open-courses" :: Text - , dbtCsvEncode = noCsvEncode - , dbtCsvDecode = Nothing - } - $(widgetFile "home/openCourses") - homeUpcomingSheets :: UserId -> Widget homeUpcomingSheets uid = do cTime <- liftIO getCurrentTime @@ -252,8 +126,7 @@ homeUpcomingSheets uid = do $(widgetFile "home/upcomingSheets") - -homeUpcomingExams :: UserId -> DB Widget +homeUpcomingExams :: UserId -> Widget homeUpcomingExams uid = do now <- liftIO getCurrentTime let fortnight = addWeeks 2 now @@ -379,7 +252,9 @@ homeUpcomingExams uid = do examDBTableValidator = def & defaultSorting [SortAscBy "time"] - (Any hasExams, examTable) <- dbTable examDBTableValidator examDBTable - return $(widgetFile "home/upcomingExams") + + (Any hasExams, examTable) <- liftHandlerT . runDB $ dbTable examDBTableValidator examDBTable + + $(widgetFile "home/upcomingExams") diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 77372489b..c8c7199fa 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -135,12 +135,13 @@ fltrAllocation :: forall allocation t shorthand name. , E.SqlProject Allocation AllocationName allocation name , E.SqlString name, E.SqlString shorthand ) - => OpticFilterColumn' t (Set Text) (E.SqlExpr allocation) + => OpticFilterColumn' t (Set (CI 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) + [ mkContainsFilterWith unSqlProject' $ views query (`E.sqlProject` AllocationShorthand) :: t -> Set (CI Text) -> E.SqlExpr (E.Value Bool) + , mkContainsFilterWith unSqlProject' $ views query (`E.sqlProject` AllocationName) ] where + unSqlProject' :: E.SqlProject Allocation value allocation value' => value -> value' unSqlProject' = E.unSqlProject (Proxy @Allocation) (Proxy @allocation) fltrAllocationUI :: DBFilterUI @@ -156,6 +157,32 @@ colAllocationShorthand resultShort = Colonnade.singleton (fromSortable header) b sortAllocationShorthand :: forall shorthand. PersistField shorthand => OpticSortColumn shorthand sortAllocationShorthand queryShorthand = singletonMap "allocation-short" . SortColumn $ view queryShorthand + +fltrAllocationActive :: UTCTime -- ^ current time + -> OpticFilterColumn' t (Last Bool) (E.SqlExpr (E.Entity Allocation)) +fltrAllocationActive cTime queryAllocation = singletonMap "active" . FilterColumn $ view queryAllocation >>> anyFilter + [ checkActive staffRegisterActive + , checkActive staffAllocationActive + , checkActive registerActive + ] + where + checkActive doCheck allocation + = maybe E.true (\b -> E.val b E.==. doCheck allocation) . getLast + + staffRegisterActive allocation + = E.maybe E.false (\f -> f E.<=. E.val cTime) (allocation E.^. AllocationStaffRegisterFrom) + E.&&. E.maybe E.true (\t -> E.val cTime E.<=. t) (allocation E.^. AllocationStaffRegisterTo) + staffAllocationActive allocation + = E.maybe E.false (\f -> f E.<=. E.val cTime) (allocation E.^. AllocationStaffAllocationFrom) + E.&&. E.maybe E.true (\t -> E.val cTime E.<=. t) (allocation E.^. AllocationStaffAllocationTo) + registerActive allocation + = E.maybe E.false (\f -> f E.<=. E.val cTime) (allocation E.^. AllocationRegisterFrom) + E.&&. E.maybe E.true (\t -> E.val cTime E.<=. t) (allocation E.^. AllocationRegisterTo) + +fltrAllocationActiveUI :: DBFilterUI +fltrAllocationActiveUI mPrev = prismAForm (singletonFilter "active" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgAllocationActive) + + ------------------------- -- Course Applications -- ------------------------- diff --git a/templates/home/openCourses.hamlet b/templates/home/openCourses.hamlet deleted file mode 100644 index 913275128..000000000 --- a/templates/home/openCourses.hamlet +++ /dev/null @@ -1,4 +0,0 @@ -$newline never -
-

_{MsgHomeOpenCourses} - ^{courseTable} diff --git a/templates/i18n/unauth-home/de.hamlet b/templates/i18n/unauth-home/de.hamlet new file mode 100644 index 000000000..66f7fe4c5 --- /dev/null +++ b/templates/i18n/unauth-home/de.hamlet @@ -0,0 +1,5 @@ +

+ Wilkommen zu Uni2work! +

+ Nach dem Login erscheinen hier Ihre aktuellen Termine, wie z.B. bevorstehende + Klausuren und aktive Übungsblätter.