diff --git a/messages/de.msg b/messages/de.msg index 6537db277..fec6874c8 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -50,3 +50,7 @@ SubmissionAlreadyExistsFor user@Text: #{user} hat bereits eine Abgabe zu diesem EMailUnknown email@Text: E-Mail #{email} gehört zu keinem bekannten Benutzer. NotAParticipant user@Text tid@TermIdentifier csh@Text: #{user} ist nicht im Kurs #{termToText tid}-#{csh} angemeldet. +HomeHeading: Startseite +TermsHeading: Semesterübersicht + +NumCourses n@Int64: #{tshow n} Kurse \ No newline at end of file diff --git a/src/Foundation.hs b/src/Foundation.hs index 7990cbf5a..9d0f3e441 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1,7 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -445,11 +445,14 @@ instance Yesod UniWorX where -- value passed to hamletToRepHtml cannot be a widget, this allows -- you to use normal widget features in default-layout. + let navbar :: Widget navbar = $(widgetFile "widgets/navbar") asidenav :: Widget asidenav = $(widgetFile "widgets/asidenav") + contentHeadline :: Maybe Widget + contentHeadline = pageHeading =<< mcurrentRoute breadcrumbs :: Widget breadcrumbs = $(widgetFile "widgets/breadcrumbs") pageactionprime :: Widget @@ -476,7 +479,7 @@ instance Yesod UniWorX where $(widgetFile "standalone/showHide") $(widgetFile "standalone/inputs") withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") - + -- The page to be redirected to when authentication is required. authRoute _ = Just $ AuthR LoginR @@ -606,6 +609,14 @@ pageActions (TermCourseListR _) = pageActions _ = [] +pageHeading :: Route UniWorX -> Maybe Widget +pageHeading HomeR + = Just [whamlet|_{MsgHomeHeading}|] +pageHeading TermShowR + = Just [whamlet|_{MsgTermsHeading}|] +pageHeading _ + = Nothing + defaultLinks :: [MenuTypes] defaultLinks = -- Define the menu items of the header. [ NavbarRight $ MenuItem @@ -633,21 +644,15 @@ defaultLinks = -- Define the menu items of the header. , menuItemAccessCallback' = isJust <$> maybeAuthPair } , NavbarAside $ MenuItem - { menuItemLabel = "Aktuelle Veranstaltungen" + { menuItemLabel = "Veranstaltungen" , menuItemIcon = Just "book" , menuItemRoute = CourseListR -- should be CourseListActiveR or similar in the future , menuItemAccessCallback' = return True } , NavbarAside $ MenuItem - { menuItemLabel = "Alte Veranstaltungen" - , menuItemIcon = Just "book" - , menuItemRoute = CourseListR -- should be CourseListInactiveR or similar in the future - , menuItemAccessCallback' = return True - } - , NavbarAside $ MenuItem - { menuItemLabel = "Veranstaltungen" - , menuItemIcon = Just "book" - , menuItemRoute = CourseListR + { menuItemLabel = "Semester" + , menuItemIcon = Nothing + , menuItemRoute = CourseListR -- should be TermListR ,,, , menuItemAccessCallback' = return True } , NavbarAside $ MenuItem diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 1defbcce5..57e1caa16 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -8,6 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} module Handler.Sheet where @@ -154,7 +155,7 @@ getSheetList courseEnt = do rated <- count $ (SubmissionRatingTime !=. Nothing):sheetsub return (sid, sheet, (submissions, rated)) let colBase = mconcat - [ headed "Blatt" $ \(sid,sheet,_) -> linkButton (toWgt $ sheetName sheet) BCLink $ CSheetR tid csh (sheetName sheet) SShowR + [ headed "Blatt" $ \(sid,sheet,_) -> simpleLink (toWgt $ sheetName sheet) $ CSheetR tid csh (sheetName sheet) SShowR , headed "Abgabe ab" $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3 , headed "Abgabe bis" $ toWgt . formatTimeGerWD . sheetActiveTo . snd3 , headed "Bewertung" $ toWgt . show . sheetType . snd3 @@ -162,8 +163,8 @@ getSheetList courseEnt = do let colAdmin = mconcat -- only show edit button for allowed course assistants [ headed "Korrigiert" $ toWgt . snd . trd3 , headed "Eingereicht" $ toWgt . fst . trd3 - , headed "" $ \s -> linkButton "Edit" BCLink $ CSheetR tid csh (sheetName $ snd3 s) SEditR - , headed "" $ \s -> linkButton "Delete" BCLink $ CSheetR tid csh (sheetName $ snd3 s) SDelR + , headed "" $ \s -> simpleLink "Edit" $ CSheetR tid csh (sheetName $ snd3 s) SEditR + , headed "" $ \s -> simpleLink "Delete" $ CSheetR tid csh (sheetName $ snd3 s) SDelR ] showAdmin <- case sheets of ((_,firstSheet,_):_) -> do @@ -209,10 +210,10 @@ getSShowR tid csh shn = do -- return desired columns return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) let colonnadeFiles = mconcat - [ sortable (Just "type") "Typ" $ \(_, (_,_, E.Value ftype)) -> textCell $ toPathPiece ftype - , sortable (Just "path") "Dateiname" $ anchorCell (\(_, (E.Value fName,_,E.Value fType)) -> CSheetR tid csh shn (SFileR fType fName)) - (\(_, (E.Value fName,_,_)) -> str2widget fName) - , sortable (Just "time") "Modifikation" $ \(_, (_,E.Value modified,_)) -> stringCell $ formatTimeGerWDT modified + [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype + , sortable (Just "path") "Dateiname" $ anchorCell (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh shn (SFileR fType fName)) + (\(E.Value fName,_,_) -> str2widget fName) + , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> stringCell $ formatTimeGerWDT (modified :: UTCTime) ] fileTable <- dbTable def $ DBTable { dbtSQLQuery = fileData diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 528e9b966..3d738fe32 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -238,9 +238,9 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do -- Maybe construct a table to display uploaded archive files let colonnadeFiles cid = mconcat -- [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype - [ sortable (Just "path") "Dateiname" $ anchorCell (\(_, (Entity _ File{..})) -> SubmissionDownloadSingleR cid fileTitle) - (\(_, (Entity _ File{..})) -> str2widget fileTitle) - , sortable (Just "time") "Modifikation" $ \(_, (Entity _ File{..})) -> stringCell $ formatTimeGerWDT fileModified + [ sortable (Just "path") "Dateiname" $ anchorCell (\(Entity _ File{..}) -> SubmissionDownloadSingleR cid fileTitle) + (\(Entity _ File{..}) -> str2widget fileTitle) + , sortable (Just "time") "Modifikation" $ \(Entity _ File{..}) -> stringCell $ formatTimeGerWDT fileModified ] smid2ArchiveTable (smid,cid) = DBTable { dbtSQLQuery = submissionFileQuery smid @@ -254,6 +254,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do , SortColumn $ \(sf `E.InnerJoin` f) -> f E.^. FileModified ) ] + , dbtFilter = [] } mFileTable <- traverse (dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 95ea678f4..a6942d85f 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -31,10 +31,10 @@ getTermShowR = do -- return term -- let + termData :: E.SqlExpr (Entity Term) -> E.SqlQuery (E.SqlExpr (Entity Term), E.SqlExpr (E.Value Int64)) termData term = do -- E.orderBy [E.desc $ term E.^. TermStart ] - let courseCount :: E.SqlExpr (E.Value Int) - courseCount = E.sub_select . E.from $ \course -> do + let courseCount = E.sub_select . E.from $ \course -> do E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm return E.countRows return (term, courseCount) @@ -42,7 +42,7 @@ getTermShowR = do provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData) provideRep $ do let colonnadeTerms = mconcat - [ sortable Nothing "Kürzel" $ \(_, (Entity tid Term{..},_)) -> cell $ do + [ sortable Nothing "Kürzel" $ \(Entity tid Term{..},_) -> cell $ do -- Scrap this if to slow, create term edit page instead adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False [whamlet| @@ -52,22 +52,20 @@ getTermShowR = do $else #{termToText termName} |] - , sortable (Just "lecture-start") "Beginn Vorlesungen" $ \(_, (Entity _ Term{..},_)) -> + , sortable (Just "lecture-start") "Beginn Vorlesungen" $ \(Entity _ Term{..},_) -> stringCell $ formatTimeGerWD termLectureStart - , sortable (Just "lecture-end") "Ende Vorlesungen" $ \(_, (Entity _ Term{..},_)) -> + , sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) -> stringCell $ formatTimeGerWD termLectureEnd - , sortable Nothing "Aktiv" $ \(_, (Entity _ Term{..},_)) -> + , sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) -> textCell $ bool "" tickmark termActive - , sortable Nothing "Kursliste" $ \(_, (Entity tid Term{..}, E.Value numCourses)) -> - cell [whamlet| - - #{show numCourses} Kurse - |] - , sortable (Just "start") "Semesteranfang" $ \(_, (Entity _ Term{..},_)) -> + , sortable Nothing "Kursliste" $ anchorCell + (\(Entity tid _, _) -> TermCourseListR tid) + (\(_, E.Value numCourses) -> [whamlet|_{MsgNumCourses numCourses}|]) + , sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) -> stringCell $ formatTimeGerWD termStart - , sortable (Just "end") "Semesterende" $ \(_, (Entity _ Term{..},_)) -> + , sortable (Just "end") "Semesterende" $ \(Entity _ Term{..},_) -> stringCell $ formatTimeGerWD termEnd - , sortable Nothing "Feiertage im Semester" $ \(_, (Entity _ Term{..},_)) -> + , sortable Nothing "Feiertage im Semester" $ \(Entity _ Term{..},_) -> stringCell $ (intercalate ", ") $ map formatTimeGerWD termHolidays ] table <- dbTable def $ DBTable @@ -86,6 +84,10 @@ getTermShowR = do , SortColumn $ \term -> term E.^. TermLectureEnd ) ] + , dbtFilter = [ ( "active" + , FilterColumn $ \term -> (term E.^. TermActive :: E.SqlExpr (E.Value Bool)) + ) + ] , dbtAttrs = tableDefault , dbtIdent = "terms" :: Text } diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index b01b8376a..c4ab73a96 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -135,6 +135,8 @@ linkButton lbl cls url = [whamlet| +simpleLink :: Widget -> Route UniWorX -> Widget +simpleLink lbl url = [whamlet| ^{lbl} |] buttonField :: Button a => a -> Field Handler a buttonField btn = Field {fieldParse, fieldView, fieldEnctype} diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index b1f1bcb58..0625975b2 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -7,10 +7,15 @@ , LambdaCase , ViewPatterns , FlexibleContexts + , FlexibleInstances + , MultiParamTypeClasses + , TypeFamilies #-} module Handler.Utils.Table.Pagination ( SortColumn(..), SortDirection(..) + , FilterColumn(..), IsFilterColumn + , DBRow(..), DBOutput , DBTable(..) , PaginationSettings(..) , PSValidator(..) @@ -36,11 +41,14 @@ import qualified Network.Wai as Wai import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI -import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_) +import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_, forM_) import Data.Map (Map, (!)) +import qualified Data.Map as Map -import Colonnade hiding (bool, fromMaybe) +import Data.Profunctor (lmap) + +import Colonnade hiding (bool, fromMaybe, singleton) import Colonnade.Encode import Yesod.Colonnade @@ -64,22 +72,65 @@ instance PathPiece SortDirection where sqlSortDirection :: t -> (SortColumn t, SortDirection) -> E.SqlExpr E.OrderBy sqlSortDirection t (SortColumn e, SortAsc ) = E.asc $ e t sqlSortDirection t (SortColumn e, SortDesc) = E.desc $ e t - -data DBTable = forall a r h i t. - ( ToSortable h - , E.SqlSelect a r + + +data FilterColumn t = forall a. IsFilterColumn t a => FilterColumn a + +filterColumn :: FilterColumn t -> [Text] -> t -> E.SqlExpr (E.Value Bool) +filterColumn (FilterColumn f) = filterColumn' f + +class IsFilterColumn t a where + filterColumn' :: a -> [Text] -> t -> E.SqlExpr (E.Value Bool) + +instance IsFilterColumn t (E.SqlExpr (E.Value Bool)) where + filterColumn' fin _ _ = fin + +instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where + filterColumn' cont is t = filterColumn' (cont t) is t + +instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where + filterColumn' cont is t = filterColumn' (cont input) is' t + where + (input, ($ []) -> is') = go (mempty, id) is + go acc [] = acc + go (acc, is') (i:is) + | Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is') is + | otherwise = go (acc, is' . (i:)) is + + +data DBRow r = DBRow + { dbrIndex, dbrCount :: Int64 + , dbrOutput :: r + } + +class DBOutput r r' where + dbProj :: r -> r' + +instance DBOutput r r where + dbProj = id +instance DBOutput (DBRow r) r where + dbProj = dbrOutput +instance DBOutput (DBRow r) (Int64, r) where + dbProj = (,) <$> dbrIndex <*> dbrOutput + + +data DBTable = forall a r r' h i t. + ( ToSortable h, Functor h + , E.SqlSelect a r, DBOutput (DBRow r) r' , PathPiece i , E.From E.SqlQuery E.SqlExpr E.SqlBackend t ) => DBTable { dbtSQLQuery :: t -> E.SqlQuery a - , dbtColonnade :: Colonnade h (Int64, r) (Cell UniWorX) + , dbtColonnade :: Colonnade h r' (Cell UniWorX) , dbtSorting :: Map Text (SortColumn t) + , dbtFilter :: Map Text (FilterColumn t) , dbtAttrs :: Attribute , dbtIdent :: i } data PaginationSettings = PaginationSettings { psSorting :: [(Text, SortDirection)] + , psFilter :: Map Text [Text] , psLimit :: Int64 , psPage :: Int64 , psShortcircuit :: Bool @@ -88,15 +139,16 @@ data PaginationSettings = PaginationSettings instance Default PaginationSettings where def = PaginationSettings { psSorting = [] + , psFilter = Map.empty , psLimit = 50 , psPage = 0 , psShortcircuit = False } -newtype PSValidator = PSValidator { runPSValidator :: Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) } +newtype PSValidator = PSValidator { runPSValidator :: DBTable -> Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) } instance Default PSValidator where - def = PSValidator $ \case + def = PSValidator $ \DBTable{..} -> \case Nothing -> def Just ps -> swap . (\act -> execRWS act () ps) $ do l <- gets psLimit @@ -106,7 +158,7 @@ instance Default PSValidator where dbTable :: PSValidator -> DBTable -> Handler Widget -dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do +dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtColonnade = (lmap dbProj -> dbtColonnade), .. }) = do let sortingOptions = mkOptionList [ Option t' (t, d) t' @@ -114,35 +166,43 @@ dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do , d <- [SortAsc, SortDesc] , let t' = t <> "-" <> toPathPiece d ] - (_, defPS) = runPSValidator Nothing + (_, defPS) = runPSValidator dbtable Nothing wIdent n | not $ null dbtIdent = dbtIdent <> "-" <> n | otherwise = n dbtAttrs' | not $ null dbtIdent = Html5.id (fromString $ unpack dbtIdent) <> dbtAttrs | otherwise = dbtAttrs + multiTextField = Field + { fieldParse = \ts _ -> return . Right $ Just ts + , fieldView = undefined + , fieldEnctype = UrlEncoded + } psResult <- runInputGetResult $ PaginationSettings <$> (fromMaybe [] <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")) + <*> (Map.mapMaybe ((\args -> args <$ guard (not $ null args)) =<<) <$> Map.traverseWithKey (\k _ -> iopt multiTextField (wIdent $ "filter." <> k)) dbtFilter) <*> (fromMaybe (psLimit defPS) <$> iopt intField (wIdent "pagesize")) <*> (fromMaybe (psPage defPS) <$> iopt intField (wIdent "page")) <*> ireq checkBoxField (wIdent "table-only") - $(logDebug) . tshow $ (,,,) <$> (length . psSorting <$> psResult) - <*> (psLimit <$> psResult) - <*> (psPage <$> psResult) - <*> (psShortcircuit <$> psResult) + $(logDebug) . tshow $ (,,,,) <$> (length . psSorting <$> psResult) + <*> (Map.keys . psFilter <$> psResult) + <*> (psLimit <$> psResult) + <*> (psPage <$> psResult) + <*> (psShortcircuit <$> psResult) let (errs, PaginationSettings{..}) = case psResult of - FormSuccess ps -> runPSValidator $ Just ps - FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator Nothing - FormMissing -> runPSValidator Nothing + FormSuccess ps -> runPSValidator dbtable $ Just ps + FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator dbtable Nothing + FormMissing -> runPSValidator dbtable Nothing psSorting' = map (first (dbtSorting !)) psSorting sqlQuery' = E.from $ \t -> dbtSQLQuery t <* E.orderBy (map (sqlSortDirection t) psSorting') <* E.limit psLimit <* E.offset (psPage * psLimit) + <* E.where_ (Map.foldrWithKey (\key args expr -> filterColumn (dbtFilter ! key) args t E.&&. expr) (E.val True) psFilter) mapM_ (addMessageI "warning") errs @@ -152,7 +212,7 @@ dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do rowCount | ((_, E.Value n), _):_ <- rows' = n | otherwise = 0 - rows = map (\((E.Value i, _), r) -> (i, r)) rows' + rows = map (\((E.Value i, E.Value n), r) -> DBRow i n r) rows' bool return (sendResponse <=< tblLayout) psShortcircuit $ do getParams <- handlerToWidget $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest diff --git a/src/Handler/Utils/Table/Pagination/Types.hs b/src/Handler/Utils/Table/Pagination/Types.hs index c2038c4d0..1c0c883d6 100644 --- a/src/Handler/Utils/Table/Pagination/Types.hs +++ b/src/Handler/Utils/Table/Pagination/Types.hs @@ -12,7 +12,7 @@ import Colonnade import Colonnade.Encode data Sortable a = Sortable - { sortableKey :: (Maybe Text) + { sortableKey :: Maybe Text , sortableContent :: a } @@ -23,6 +23,9 @@ instance Headedness Sortable where headednessPure = Sortable Nothing headednessExtract = Just $ \(Sortable _ x) -> x headednessExtractForall = Just $ ExtractForall (\(Sortable _ x) -> x) + +instance Functor Sortable where + fmap f Sortable{..} = Sortable { sortableContent = f sortableContent, .. } newtype SortableP s = SortableP { toSortable :: forall a. s a -> Sortable a} diff --git a/static/css/icons.css b/static/css/icons.css index b836de6e3..e5fdd191d 100644 --- a/static/css/icons.css +++ b/static/css/icons.css @@ -32,3 +32,6 @@ .glyphicon--logout::before { content: '\e163'; } +.glyphicon--none::before { + content: ''; +} diff --git a/static/css/tabber.css b/static/css/tabber.css index f768f6f24..6f823b410 100644 --- a/static/css/tabber.css +++ b/static/css/tabber.css @@ -1,8 +1,6 @@ .tab-group { - /* box-shadow: 0 0 0 18px white, 0 0 0 20px #b3b7c1; */ border-top: 2px solid #dcdcdc; padding-top: 30px; - margin-top: 40px; } .tab-group-openers { diff --git a/templates/course.hamlet b/templates/course.hamlet index 958e4024a..f652a33b5 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -30,9 +30,13 @@ $maybe regTo <- courseRegisterTo course \ bis #{formatTimeGerWD regTo} + + + $# if allowed to register -
- Anmelden +
+