diff --git a/messages/de.msg b/messages/de.msg index 1d542a5ff..ea407972e 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -3,6 +3,7 @@ BtnAbort: Abbrechen BtnDelete: Löschen BtnRegister: Anmelden BtnDeregister: Abmelden +BtnHijack: Sitzung übernehmen RegisterFrom: Anmeldungen von RegisterTo: Anmeldungen bis @@ -29,6 +30,9 @@ LectureStart: Beginn Vorlesungen Course: Kurs CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei. +CourseRegisterOk: Sie wurden angemeldet +CourseDeregisterOk: Sie wurden abgemeldet +CourseSecretWrong: Falsches Kennwort CourseSecret: Zugangspasswort CourseNewOk tid@TermId courseShortHand@Text: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich erstellt. CourseEditOk tid@TermId courseShortHand@Text: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich geändert. @@ -184,4 +188,11 @@ 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 +CourseMembersCountLimited num@Int64 max@Int64: #{display num}/#{display max} + +NoTableContent: Kein Tabelleninhalt +NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter + +AdminFor: Administrator +LecturerFor: Dozent +UserListTitle: Komprehensive Benutzerliste \ No newline at end of file diff --git a/routes b/routes index 74b845e0c..778805719 100644 --- a/routes +++ b/routes @@ -15,6 +15,7 @@ -- !corrector -- corrector for this sheet (or the submission, if route is connected to a submission, or the course, if route is not connected to a sheet, or any course, if route is not connected to a course) -- !registered -- participant for this course (no effect outside of courses) -- !owner -- part of the group of owners of this submission +-- !capacity -- course this route is associated with has at least one unit of participant capacity -- -- !materials -- only if course allows all materials to be free (no meaning outside of courses) -- !time -- access depends on time somehow @@ -34,6 +35,7 @@ /users UsersR GET -- no tags, i.e. admins only /admin/test AdminTestR GET POST /admin/user/#CryptoUUIDUser AdminUserR GET +/admin/user/#CryptoUUIDUser/hijack AdminHijackUserR POST /info VersionR GET !free /profile ProfileR GET POST !free !free @@ -50,7 +52,7 @@ !/course/new CourseNewR GET POST !lecturer /course/#TermId/#Text CourseR !lecturer: / CShowR GET !free - /register CRegisterR POST !time + /register CRegisterR POST !timeANDcapacity /edit CEditR GET POST /subs CCorrectionsR GET POST /ex SheetListR GET !registered !materials diff --git a/src/Foundation.hs b/src/Foundation.hs index 1544e03cb..8f56b2117 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -342,6 +342,16 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req $logErrorS "AccessControl" $ "'!registered' used on route that doesn't support it: " <> tshow r unauthorizedI MsgUnauthorized ) + ,("capacity", APDB $ \route _ -> case route of + CourseR tid csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do + Entity cid Course{..} <- MaybeT . getBy $ CourseTermShort tid csh + registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] + guard $ NTop courseCapacity > NTop (Just registered) + return Authorized + r -> do + $logErrorS "AccessControl" $ "'!capacity' used on route that doesn't support it: " <> tshow r + unauthorizedI MsgUnauthorized + ) ,("materials", APDB $ \route _ -> case route of CourseR tid csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do Entity _ Course{..} <- MaybeT . getBy $ CourseTermShort tid csh diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 360ceba5a..0fc43773d 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -170,7 +170,7 @@ makeCorrectionsTable whereClause colChoices psValidator = do E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False) ) ] - , dbtAttrs = tableDefault + , dbtStyle = def , dbtIdent = "corrections" :: Text } diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index b9c3446e5..d4e2c529b 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -85,7 +85,7 @@ getTermCourseListR tid = do ) ] , dbtFilter = mempty - , dbtAttrs = tableDefault + , dbtStyle = def , dbtIdent = "courses" :: Text } @@ -139,19 +139,12 @@ postCRegisterR tid csh = do (FormSuccess codeOk) | registered -> do runDB $ deleteBy $ UniqueParticipant aid cid - addMessage "info" "Sie wurden abgemeldet." + addMessageI "info" MsgCourseDeregisterOk | codeOk -> do actTime <- liftIO $ getCurrentTime - regOk <- runDB $ do - reg <- count [CourseParticipantCourse ==. cid] - if NTop (Just $ fromIntegral reg) < NTop (courseCapacity course) - then -- current capacity has room - insertUnique $ CourseParticipant cid aid actTime - else do -- no space left - addMessageI "danger" MsgCourseNoCapacity - return Nothing - when (isJust regOk) $ addMessage "success" "Erfolgreich angemeldet!" - | otherwise -> addMessage "danger" "Falsches Kennwort!" + regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime + when (isJust regOk) $ addMessageI "success" MsgCourseRegisterOk + | otherwise -> addMessageI "danger" MsgCourseSecretWrong (_other) -> return () -- TODO check this! redirect $ CourseR tid csh CShowR diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index dfb28c82b..b5e0b7412 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -99,7 +99,7 @@ homeAnonymous = do | otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids) ) ] -} - , dbtAttrs = tableDefault + , dbtStyle = def , dbtIdent = "upcomingdeadlines" :: Text } let features = $(widgetFile "featureList") @@ -188,7 +188,7 @@ homeUser uid = do | otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids) ) ] -} - , dbtAttrs = tableDefault + , dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines } , dbtIdent = "upcomingdeadlines" :: Text } defaultLayout $ do diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index d9207f0ce..1ddbd051c 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -227,7 +227,7 @@ getSShowR tid csh shn = do fileTable <- dbTable def $ DBTable { dbtSQLQuery = fileData , dbtColonnade = colonnadeFiles - , dbtAttrs = tableDefault + , dbtStyle = def , dbtFilter = Map.empty , dbtIdent = "files" :: Text -- TODO: Add column for and visibility date diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index aa574d5d6..5ff6058a1 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -288,7 +288,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do smid2ArchiveTable (smid,cid) = DBTable { dbtSQLQuery = submissionFiles smid , dbtColonnade = colonnadeFiles cid - , dbtAttrs = tableDefault + , dbtStyle = def , dbtIdent = "files" :: Text , dbtSorting = [ ( "path" , SortColumn $ \((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) -> E.coalesce [f1 E.?. FileTitle, f2 E.?. FileTitle] diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index b3a6a3f5a..22782165f 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -99,7 +99,7 @@ getTermShowR = do E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs ) ] - , dbtAttrs = tableDefault + , dbtStyle = def , dbtIdent = "terms" :: Text } defaultLayout $ do diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 17aadafb9..ba2ad0022 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -4,6 +4,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RecordWildCards #-} module Handler.Users where @@ -11,39 +12,91 @@ import Import -- import Data.Text import Handler.Utils -import Colonnade hiding (fromMaybe) -import Yesod.Colonnade +import qualified Data.Map as Map --- import qualified Database.Esqueleto as E --- import Database.Esqueleto ((^.)) +import qualified Database.Esqueleto as E +hijackUserForm :: UserId -> Form UserId +hijackUserForm uid csrf = do + cID <- encrypt uid + (uidResult, uidView) <- mforced hiddenField "" (cID :: CryptoUUIDUser) + (btnResult, btnView) <- mreq (buttonField BtnHijack) "" Nothing + + return (uid <$ uidResult <* btnResult, mconcat [toWidget csrf, fvInput uidView, fvInput btnView]) + getUsersR :: Handler Html getUsersR = do - -- TODO: Esqueleto, combine the two queries into one - (users,schools) <- runDB $ (,) - <$> (selectList [] [Asc UserDisplayName] - >>= mapM (\usr -> (,,) - <$> pure usr - <*> selectList [UserAdminUser ==. entityKey usr] [Asc UserAdminSchool] - <*> selectList [UserLecturerUser ==. entityKey usr] [Asc UserLecturerSchool] - )) - <*> selectList [] [Asc SchoolShorthand] - let schoolnames = entities2map schools - let getSchoolname = \sid -> - case lookup sid schoolnames of - Nothing -> "???" - (Just school) -> schoolShorthand school - let colonnadeUsers = mconcat $ - [ headed "User" $ \u -> do - cID <- encrypt $ entityKey $ fst3 u - let name = display $ userDisplayName $ entityVal $ fst3 u - [whamlet|#{name}|] - , headed "Admin" $ (\u -> text2widget $ intercalate ", " $ map (getSchoolname.userAdminSchool .entityVal) $ snd3 u) - , headed "Lecturer" $ (\u -> text2widget $ intercalate ", " $ map (getSchoolname.userLecturerSchool.entityVal) $ trd3 u) + let + colonnadeUsers = dbColonnade . mconcat $ + [ dbRow + , sortable (Just "display-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM + (AdminUserR <$> encrypt uid) + (toWidget . display $ userDisplayName) + , sortable Nothing (i18nCell MsgAdminFor) $ \DBRow{ dbrOutput = Entity uid _ } -> mempty + { dbCellContents = do + schools <- E.select . E.from $ \(school `E.InnerJoin` userAdmin) -> do + E.on $ school E.^. SchoolId E.==. userAdmin E.^. UserAdminSchool + E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid + E.orderBy [E.asc $ school E.^. SchoolShorthand] + return $ school E.^. SchoolShorthand + return [whamlet| +