diff --git a/Dockerfile b/Dockerfile deleted file mode 100644 index 310b609cc..000000000 --- a/Dockerfile +++ /dev/null @@ -1,6 +0,0 @@ -FROM fpco/stack-build:lts-9.3 - -ENV DEBIAN_FRONTEND noninteractive - -RUN apt-get update -RUN apt-get install libldap2-dev libsasl2-dev \ No newline at end of file diff --git a/fill-db.hs b/db.hs similarity index 85% rename from fill-db.hs rename to db.hs index 0465dc665..a0f980180 100755 --- a/fill-db.hs +++ b/db.hs @@ -4,14 +4,49 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} -import "uniworx" Import -import "uniworx" Application (db) +import "uniworx" Import hiding (Option(..)) +import "uniworx" Application (db, getAppDevSettings) + +import Database.Persist.Postgresql +import Database.Persist.Sql +import Control.Monad.Logger + +import System.Console.GetOpt +import System.Exit (exitWith, ExitCode(..)) +import System.IO (hPutStrLn, stderr) import Data.Time + +data DBAction = DBClear + | DBFill + +argsDescr :: [OptDescr DBAction] +argsDescr = + [ Option ['c'] ["clear"] (NoArg DBClear) "Delete everything accessable by the current database user" + , Option ['f'] ["fill"] (NoArg DBFill) "Fill database with example data" + ] + + main :: IO () -main = db $ do +main = do + args <- map unpack <$> getArgs + case getOpt Permute argsDescr args of + (acts@(_:_), [], []) -> forM_ acts $ \case + DBClear -> runStderrLoggingT $ do -- We don't use `db` here, since we do /not/ want any migrations to run, yet + settings <- liftIO getAppDevSettings + withPostgresqlConn (pgConnStr $ appDatabaseConf settings) . runSqlConn $ do + rawExecute "drop owned by current_user;" [] + DBFill -> db $ fillDb + (_, _, errs) -> do + forM_ errs $ hPutStrLn stderr + hPutStrLn stderr $ usageInfo "db.hs" argsDescr + exitWith $ ExitFailure 2 + +fillDb :: DB () +fillDb = do defaultFavourites <- getsYesod $ appDefaultFavourites . appSettings now <- liftIO getCurrentTime let diff --git a/messages/de.msg b/messages/de.msg index 7209a88d6..1d542a5ff 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -10,6 +10,8 @@ DeRegUntil: Abmeldungen bis SummerTerm year@Integer: Sommersemester #{display year} WinterTerm year@Integer: Wintersemester #{display year}/#{display $ succ year} +SummerTermShort year@Integer: SoSe #{display year} +WinterTermShort year@Integer: WiSe #{display year}/#{display $ succ year} PSLimitNonPositive: “pagesize” muss größer als null sein Page n@Int64: #{display n} @@ -99,6 +101,7 @@ UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung EMail: E-Mail EMailUnknown email@Text: E-Mail #{email} gehört zu keinem bekannten Benutzer. NotAParticipant user@Text tid@TermId csh@Text: #{user} ist nicht im Kurs #{display tid}-#{csh} angemeldet. +TooManyParticipants: Es wurden zu viele Mitabgebende angegeben AddCorrector: Zusätzlicher Korrektor CorrectorExists user@Text: #{user} ist bereits als Korrektor eingetragen @@ -178,3 +181,7 @@ FileCorrectedDeleted: Korrigiert (gelöscht) RatingUpdated: Korrektur gespeichert RatingDeleted: Korrektur zurückgesetzt RatingFilesUpdated: Korrigierte Dateien überschrieben + +CourseMembers: Teilnehmer +CourseMembersCount num@Int64: #{display num} +CourseMembersCountLimited num@Int64 max@Int64: #{display num}/#{display max} \ No newline at end of file diff --git a/models b/models index 68d38cb4a..90b554663 100644 --- a/models +++ b/models @@ -60,7 +60,7 @@ Course shorthand Text term TermId school SchoolId - capacity Int Maybe + capacity Int64 Maybe -- canRegisterNow = maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo registerFrom UTCTime Maybe registerTo UTCTime Maybe diff --git a/src/Application.hs b/src/Application.hs index 159fb2655..4d9e54e11 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -7,7 +7,7 @@ {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Application - ( getApplicationDev + ( getApplicationDev, getAppDevSettings , appMain , develMain , makeFoundation diff --git a/src/Foundation.hs b/src/Foundation.hs index 3aed4a208..1544e03cb 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -487,6 +487,10 @@ instance Yesod UniWorX where actFav = List.intersect (snd3 <$> favourites) crumbs highRs = if null actFav then crumbs else actFav in \r -> r `elem` highRs + favouriteTerms :: [TermIdentifier] + favouriteTerms = Set.toDescList $ foldMap (\(Course{..}, _, _) -> Set.singleton $ unTermKey courseTerm) favourites + favouriteTerm :: TermIdentifier -> [(Course, Route UniWorX, [MenuTypes])] + favouriteTerm tid = filter (\(Course{..}, _, _) -> unTermKey courseTerm == tid) favourites -- We break up the default layout into two components: -- default-layout is the contents of the body tag, and diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index a114a0484..b9c3446e5 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -18,8 +18,12 @@ import qualified Data.Text as T import Data.Function ((&)) -- import Yesod.Form.Bootstrap3 +import qualified Data.Map as Map + import Colonnade hiding (fromMaybe,bool) -import Yesod.Colonnade +-- import Yesod.Colonnade + +import qualified Database.Esqueleto as E import qualified Data.UUID.Cryptographic as UUID @@ -37,45 +41,56 @@ getTermCurrentR = do getTermCourseListR :: TermId -> Handler Html -getTermCourseListR tidini = do - (term,courses) <- runDB $ (,) - <$> get tidini - <*> selectList [CourseTerm ==. tidini] [Asc CourseShorthand] - when (isNothing term) $ do - addMessage "warning" [shamlet| Semester #{toPathPiece tidini} nicht gefunden. |] - redirect TermShowR - -- TODO: several runDBs per TableRow are probably too inefficient! - let colonnadeTerms = mconcat - [ headed "Kürzel" $ (\ckv -> - let c = entityVal ckv - shd = courseShorthand c - tid = courseTerm c - in [whamlet| #{shd} |] ) --- , headed "Institut" $ [shamlet| #{course} |] - , headed "Beginn Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterFrom.entityVal - , headed "Ende Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterTo.entityVal - , headed "Teilnehmer" $ (\ckv -> do - let cid = entityKey ckv - partiNum <- handlerToWidget $ runDB $ count [CourseParticipantCourse ==. cid] - [whamlet| #{show partiNum} |] - ) - , headed " " $ (\ckv -> - let c = entityVal ckv - shd = courseShorthand c - tid = courseTerm c - in do - adminLink <- handlerToWidget $ isAuthorized (CourseR tid shd CEditR) False - -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CEditR tid shd) else "" - [whamlet| - $if adminLink == Authorized - - editieren - |] +getTermCourseListR tid = do + void . runDB $ get404 tid -- Just ensure the term exists + + let + tableData :: E.SqlExpr (Entity Course) -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (E.Value Int64)) + tableData course = do + E.where_ $ course E.^. CourseTerm E.==. E.val tid + let + participants = E.sub_select . E.from $ \courseParticipant -> do + E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId + return (E.countRows :: E.SqlExpr (E.Value Int64)) + return (course, participants) + psValidator = def + & defaultSorting [("shorthand", SortAsc)] + + coursesTable <- dbTable psValidator $ DBTable + { dbtSQLQuery = tableData + , dbtColonnade = widgetColonnade $ mconcat + [ sortable (Just "shorthand") (textCell MsgCourse) $ anchorCell' + (\(Entity _ Course{..}, _) -> CourseR courseTerm courseShorthand CShowR) + (\(Entity _ Course{..}, _) -> toWidget courseShorthand) + , sortable (Just "register-from") (textCell MsgRegisterFrom) $ \(Entity _ Course{..}, _) -> textCell $ display courseRegisterFrom + , sortable (Just "register-to") (textCell MsgRegisterTo) $ \(Entity _ Course{..}, _) -> textCell $ display courseRegisterTo + , sortable (Just "members") (textCell MsgCourseMembers) $ \(Entity _ Course{..}, E.Value num) -> textCell $ case courseCapacity of + Nothing -> MsgCourseMembersCount num + Just max -> MsgCourseMembersCountLimited num max + ] + , dbtSorting = Map.fromList + [ ( "shorthand" + , SortColumn $ \course -> course E.^. CourseShorthand + ) + , ( "register-from" + , SortColumn $ \course -> course E.^. CourseRegisterFrom + ) + , ( "register-to" + , SortColumn $ \course -> course E.^. CourseRegisterTo + ) + , ( "members" + , SortColumn $ \course -> E.sub_select . E.from $ \courseParticipant -> do + E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId + return (E.countRows :: E.SqlExpr (E.Value Int64)) ) ] - let coursesTable = encodeWidgetTable tableSortable colonnadeTerms courses + , dbtFilter = mempty + , dbtAttrs = tableDefault + , dbtIdent = "courses" :: Text + } + defaultLayout $ do - setTitleI . MsgTermCourseListTitle $ tidini + setTitleI . MsgTermCourseListTitle $ tid $(widgetFile "courses") getCShowR :: TermId -> Text -> Handler Html @@ -129,7 +144,7 @@ postCRegisterR tid csh = do actTime <- liftIO $ getCurrentTime regOk <- runDB $ do reg <- count [CourseParticipantCourse ==. cid] - if NTop (Just reg) < NTop (courseCapacity course) + if NTop (Just $ fromIntegral reg) < NTop (courseCapacity course) then -- current capacity has room insertUnique $ CourseParticipant cid aid actTime else do -- no space left @@ -260,7 +275,7 @@ data CourseForm = CourseForm , cfShort :: Text , cfTerm :: TermId , cfSchool :: SchoolId - , cfCapacity :: Maybe Int + , cfCapacity :: Maybe Int64 , cfSecret :: Maybe Text , cfMatFree :: Bool , cfRegFrom :: Maybe UTCTime diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 5a73ced6a..aa574d5d6 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -170,11 +170,11 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do (FormFailure failmsgs) -> return $ FormFailure failmsgs (FormSuccess (mFiles,[])) -> return $ FormSuccess (mFiles,[]) -- Type change (FormSuccess (mFiles, (map CI.mk -> gEMails@(_:_)))) -- Validate AdHoc Group Members - | (Arbitrary {..}) <- sheetGrouping - , length gEMails < maxParticipants -> do -- < since submitting user is already accounted for + | (Arbitrary {..}) <- sheetGrouping -> do + -- , length gEMails < maxParticipants -> do -- < since submitting user is already accounted for let gemails = map CI.foldedCase gEMails prep :: [(E.Value Text, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map (CI Text) (Maybe (UserId, Bool, Bool)) - prep ps = Map.fromList $ map (, Nothing) gEMails ++ [(CI.mk m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps] + prep ps = Map.filter (maybe True $ \(i,_,_) -> i /= uid) . Map.fromList $ map (, Nothing) gEMails ++ [(CI.mk m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps] participants <- fmap prep . E.select . E.from $ \user -> do E.where_ $ (E.lower_ $ user E.^. UserEmail) `E.in_` E.valList gemails let @@ -186,20 +186,29 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId E.&&. submission E.^. SubmissionSheet E.==. E.val shid + case msmid of -- Multiple `E.where_`-Statements are merged with `&&` in esqueleto 2.5.3 + Nothing -> return () + Just smid -> E.where_ $ submission E.^. SubmissionId E.!=. E.val smid return $ E.countRows E.>. E.val (0 :: Int64) return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted)) - $logDebugS "SUBMISSION.AdHocGroupValidation" $ tshow participants - mr <- getMessageRender - let failmsgs = flip Map.foldMapWithKey participants $ \email -> \case - Nothing -> [mr $ MsgEMailUnknown $ CI.original email] - (Just (_,False,_)) -> [mr $ MsgNotAParticipant (CI.original email) tid csh] - (Just (_,_, True)) -> [mr $ MsgSubmissionAlreadyExistsFor (CI.original email)] + $logDebugS "SUBMISSION.AdHocGroupValidation" $ tshow participants + + mr <- getMessageRender + let + failmsgs = (concat :: [[Text]] -> [Text]) + [ flip Map.foldMapWithKey participants $ \email -> \case + Nothing -> pure . mr $ MsgEMailUnknown $ CI.original email + (Just (_,False,_)) -> pure . mr $ MsgNotAParticipant (CI.original email) tid csh + (Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor (CI.original email) _other -> mempty + , case length participants `compare` maxParticipants of + LT -> mempty + _ -> pure $ mr MsgTooManyParticipants + ] return $ if null failmsgs then FormSuccess (mFiles, foldMap (\(Just (i,_,_)) -> [i]) participants) else FormFailure failmsgs - | otherwise -> return $ FormFailure ["Mismatching number of group participants"] diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index aeedaea1f..e7d47b10e 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -22,7 +22,7 @@ module Handler.Utils.Table.Pagination , FilterColumn(..), IsFilterColumn , DBRow(..), DBOutput , DBTable(..), IsDBTable(..) - , PaginationSettings(..) + , PaginationSettings(..), PaginationInput(..), piIsUnset , PSValidator(..) , defaultFilter, defaultSorting , restrictFilter, restrictSorting @@ -160,16 +160,41 @@ instance Default PaginationSettings where , psShortcircuit = False } -newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) } +data PaginationInput = PaginationInput + { piSorting :: Maybe [(CI Text, SortDirection)] + , piFilter :: Maybe (Map (CI Text) [Text]) + , piLimit :: Maybe Int64 + , piPage :: Maybe Int64 + , piShortcircuit :: Bool + } + +piIsUnset :: PaginationInput -> Bool +piIsUnset PaginationInput{..} = and + [ isNothing piSorting + , isNothing piFilter + , isNothing piLimit + , isNothing piPage + , not piShortcircuit + ] + +newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationInput -> ([SomeMessage UniWorX], PaginationSettings) } instance Default (PSValidator m x) where def = PSValidator $ \DBTable{..} -> \case Nothing -> def - Just ps -> swap . (\act -> execRWS act () ps) $ do - l <- gets psLimit - when (l <= 0) $ do - modify $ \ps -> ps { psLimit = psLimit def } - tell . pure $ SomeMessage MsgPSLimitNonPositive + Just pi -> swap . (\act -> execRWS act pi def) $ do + asks piSorting >>= maybe (return ()) (\s -> modify $ \ps -> ps { psSorting = s }) + asks piFilter >>= maybe (return ()) (\f -> modify $ \ps -> ps { psFilter = f }) + + l <- asks piLimit + case l of + Just l' + | l' >= 0 -> tell . pure $ SomeMessage MsgPSLimitNonPositive + | otherwise -> modify $ \ps -> ps { psLimit = l' } + Nothing -> return () + + asks piPage >>= maybe (return ()) (\p -> modify $ \ps -> ps { psPage = p }) + asks piShortcircuit >>= (\s -> modify $ \ps -> ps { psShortcircuit = s }) defaultFilter :: Map (CI Text) [Text] -> PSValidator m x -> PSValidator m x defaultFilter psFilter (runPSValidator -> f) = PSValidator g @@ -281,24 +306,25 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), , 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 $ CI.foldedCase k) dbtFilter) - <*> (fromMaybe (psLimit defPS) <$> iopt intField (wIdent "pagesize")) - <*> (fromMaybe (psPage defPS) <$> iopt intField (wIdent "page")) + psResult <- runInputGetResult $ PaginationInput + <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting") + <*> ((\m -> m <$ guard (not $ Map.null m)) . Map.mapMaybe ((\args -> args <$ guard (not $ null args)) =<<) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter) + <*> iopt intField (wIdent "pagesize") + <*> iopt intField (wIdent "page") <*> ireq checkBoxField (wIdent "table-only") - $(logDebug) . tshow $ (,,,,) <$> (length . psSorting <$> psResult) - <*> (Map.keys . psFilter <$> psResult) - <*> (psLimit <$> psResult) - <*> (psPage <$> psResult) - <*> (psShortcircuit <$> psResult) + $(logDebug) . tshow $ (,,,,) <$> (piSorting <$> psResult) + <*> (piFilter <$> psResult) + <*> (piLimit <$> psResult) + <*> (piPage <$> psResult) + <*> (piShortcircuit <$> psResult) let (errs, PaginationSettings{..}) = case psResult of - FormSuccess ps -> runPSValidator dbtable $ Just ps - FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator dbtable Nothing - FormMissing -> runPSValidator dbtable Nothing + FormSuccess pi + | not (piIsUnset pi) -> runPSValidator dbtable $ Just pi + FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator dbtable Nothing + _ -> runPSValidator dbtable Nothing psSorting' = map (first (dbtSorting !)) psSorting sqlQuery' = E.from $ \t -> dbtSQLQuery t <* E.orderBy (map (sqlSortDirection t) psSorting') @@ -308,13 +334,13 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), mapM_ (addMessageI "warning") errs - rows' <- runDB . E.select $ (,) <$> pure (E.unsafeSqlValue "row_number() OVER ()" :: E.SqlExpr (E.Value Int64), E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64)) <*> sqlQuery' + rows' <- runDB . E.select $ (,) <$> pure (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64)) <*> sqlQuery' let rowCount - | ((_, E.Value n), _):_ <- rows' = n + | (E.Value n, _):_ <- rows' = n | otherwise = 0 - rows = map (\((E.Value dbrIndex, E.Value dbrCount), dbrOutput) -> DBRow{..}) rows' + rows = map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows' table' :: WriterT x m Widget table' = do diff --git a/stack.yaml b/stack.yaml index 180aa43b0..4be603f4c 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,8 +1,5 @@ flags: {} -docker: - enable: false - image: uniworx nix: packages: [] pure: false diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index 3abf26a8f..6939d7616 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -49,11 +49,11 @@ body { --color-lmu-box-border: var(--color-lightwhite); &.theme--lavender { - --color-primary: #4C7A9C; - --color-light: #598EB5; - --color-lighter: #5F98C2; - --color-dark: #425d79; - --color-darker: #274a65; + --color-primary: #4c569c; + --color-light: #5969b5; + --color-lighter: #5f7dc2; + --color-dark: #4c4279; + --color-darker: #273765; --color-link: var(--color-dark); --color-link-hover: var(--color-darker); } @@ -435,22 +435,26 @@ input[type="button"].btn-info:hover, .deflist__dt { font-weight: 600; - font-size: 20px; - - /* bad. avoid this. */ - > a { - font-size: 16px; - } } .deflist__dd { - margin-bottom: 4px; + font-size: 18px; + margin-bottom: 10px; } @media (min-width: 768px) { .deflist { - grid-template-columns: max-content auto; + grid-template-columns: max-content minmax(auto, max-content); + + .deflist { + margin-top: -10px; + margin-right: -15px; + + .deflist__dd { + padding-right: 15px; + } + } } .deflist__dt, @@ -458,6 +462,7 @@ input[type="button"].btn-info:hover, border-bottom: 1px solid #d3d3d3; padding: 12px 0; margin: 0; + font-size: 16px; &:last-of-type { border: 0; @@ -465,7 +470,10 @@ input[type="button"].btn-info:hover, } .deflist__dt { - padding-right: 24px; - font-size: 16px; + padding-right: 50px; + } + + .deflist__dd { + padding-right: 15px; } } diff --git a/templates/table/layout.hamlet b/templates/table/layout.hamlet index ce079c6dc..a6578422c 100644 --- a/templates/table/layout.hamlet +++ b/templates/table/layout.hamlet @@ -1,10 +1,7 @@ $newline never
- $if null wRows - Keine anstehenden Übungsblätter. - $else - ^{table} + ^{table} $if pageCount > 1