feat(home): clean up homepage

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}

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)
+anyFilter :: Foldable f
-  => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool))
+          => f (t -> cs -> E.SqlExpr (E.Value Bool))
-  -> t
+          -> (t -> cs -> E.SqlExpr (E.Value Bool))
-  -> Set.Set Text
-  -> 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)
+allFilter :: Foldable f
-  => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool))
+          => f (t -> cs -> E.SqlExpr (E.Value Bool))
-  -> t
+          -> (t -> cs -> E.SqlExpr (E.Value Bool))
-  -> Set.Set Text
-  -> E.SqlExpr (E.Value Bool)
 allFilter fltrs needle criterias = F.foldr aux true fltrs
   where
     aux fltr acc = fltr needle criterias E.&&. acc

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
       }

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{..}
 

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)

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
+    case muid of
-    maybe mempty homeUpcomingSheets muid
+      Just uid -> do
-    homeOpenAllocations
+        homeUpcomingExams uid
-    homeOpenCourses
+        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 -> Widget
-homeUpcomingExams :: UserId -> DB 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")
 
 

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' $ views query (`E.sqlProject` AllocationShorthand) :: t -> Set (CI Text) -> E.SqlExpr (E.Value Bool)
-  , mkContainsFilterWith (unSqlProject' . CI.mk) $ views query (`E.sqlProject` AllocationName)
+  , 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 --
 -------------------------

templates/home/openCourses.hamlet

@@ -1,4 +0,0 @@
-$newline never
-<section>
-  <h2>_{MsgHomeOpenCourses}
-  ^{courseTable}

templates/i18n/unauth-home/de.hamlet

@@ -0,0 +1,5 @@
+<p>
+  Wilkommen zu Uni2work!
+<p>
+  Nach dem Login erscheinen hier Ihre aktuellen Termine, wie z.B. bevorstehende
+  Klausuren und aktive Übungsblätter.