From a6bf547902d0fb1bfdb96baa6bd904fe1a333b63 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 6 Jul 2018 16:31:22 +0200 Subject: [PATCH 01/13] Disable docker integration --- Dockerfile | 6 ------ stack.yaml | 3 --- 2 files changed, 9 deletions(-) delete mode 100644 Dockerfile 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/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 From 25112a5f67184e7e8c163fbe5bf7a42555fdef71 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 6 Jul 2018 17:24:23 +0200 Subject: [PATCH 02/13] Cleanup AdHoc-Group logic - Submitting user is no longer checked during validity checks for participants - Better error message if too many participants are submitted - Having submitted the focused submission is no longer counted as already having a submission during updates --- messages/de.msg | 1 + src/Handler/Submission.hs | 29 +++++++++++++++++++---------- 2 files changed, 20 insertions(+), 10 deletions(-) diff --git a/messages/de.msg b/messages/de.msg index 7209a88d6..9bb712c15 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -99,6 +99,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 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"] From 1787dc1dcb6867391c04f5df2a665b05cf44dd7b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 6 Jul 2018 18:08:47 +0200 Subject: [PATCH 03/13] Convert CourseListR to dbTable --- messages/de.msg | 4 ++ models | 2 +- src/Handler/Course.hs | 93 ++++++++++++++++++++++++------------------- 3 files changed, 58 insertions(+), 41 deletions(-) diff --git a/messages/de.msg b/messages/de.msg index 9bb712c15..d78acf450 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -179,3 +179,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/Handler/Course.hs b/src/Handler/Course.hs index a114a0484..bebf18334 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -7,6 +7,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedLists #-} module Handler.Course where @@ -19,7 +20,9 @@ import Data.Function ((&)) -- import Yesod.Form.Bootstrap3 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 +40,55 @@ 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 ] - let coursesTable = encodeWidgetTable tableSortable colonnadeTerms courses + , dbtSorting = [ ( "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)) + ) + ] + , dbtFilter = [] + , dbtAttrs = tableDefault + , dbtIdent = "courses" :: Text + } + defaultLayout $ do - setTitleI . MsgTermCourseListTitle $ tidini + setTitleI . MsgTermCourseListTitle $ tid $(widgetFile "courses") getCShowR :: TermId -> Text -> Handler Html @@ -129,7 +142,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 +273,7 @@ data CourseForm = CourseForm , cfShort :: Text , cfTerm :: TermId , cfSchool :: SchoolId - , cfCapacity :: Maybe Int + , cfCapacity :: Maybe Int64 , cfSecret :: Maybe Text , cfMatFree :: Bool , cfRegFrom :: Maybe UTCTime From 4911cdb29b178a77e1d541b6c1c5b7c5a76b0ee0 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 6 Jul 2018 18:33:33 +0200 Subject: [PATCH 04/13] Fix dbTable - Row numbering now works as expected - Default sorting & filtering now actually gets applied --- src/Handler/Utils/Table/Pagination.hs | 72 ++++++++++++++++++--------- 1 file changed, 49 insertions(+), 23 deletions(-) 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 From 143b4d6116cfec0ddd6f49e410c69aa7168fed45 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 6 Jul 2018 18:43:58 +0200 Subject: [PATCH 05/13] Fix deployment build --- src/Handler/Course.hs | 36 +++++++++++++++++++----------------- 1 file changed, 19 insertions(+), 17 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index bebf18334..b9c3446e5 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -7,7 +7,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedLists #-} module Handler.Course where @@ -19,6 +18,8 @@ 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 @@ -67,22 +68,23 @@ getTermCourseListR tid = do Nothing -> MsgCourseMembersCount num Just max -> MsgCourseMembersCountLimited num max ] - , dbtSorting = [ ( "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)) - ) - ] - , dbtFilter = [] + , 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)) + ) + ] + , dbtFilter = mempty , dbtAttrs = tableDefault , dbtIdent = "courses" :: Text } From 5101cf9c1e6c21e57358b694f768ad09c614872a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 6 Jul 2018 18:54:04 +0200 Subject: [PATCH 06/13] Partially revert "no empty tables on profile page and spacing for containers" This partially reverts commit c114e294372e1991e5e64de7b0f6e9898b7f91c7. Handling of empty tables was broken (see /terms with no terms in database) --- templates/table/layout.hamlet | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) 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