diff --git a/messages/de.msg b/messages/de.msg index 07b667282..9d74e3e10 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -1,3 +1,12 @@ +BtnSubmit: Senden +BtnAbort: Abbrechen +BtnDelete: Löschen +BtnRegister: Anmelden +BtnDeregister: Abmelden + +RegisterFrom: Anmeldungen von +RegisterTo: Anmeldungen bis + SummerTerm year@Integer: Sommersemester #{tshow year} WinterTerm year@Integer: Wintersemester #{tshow year}/#{tshow $ succ year} PSLimitNonPositive: “pagesize” muss größer als null sein @@ -10,6 +19,7 @@ TermPlaceholder: W/S + vierstellige Jahreszahl TermEditHeading: Semester editieren/anlegen Course: Kurs +CourseSecret: Zugangspasswort CourseNewOk tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} wurde erfolgreich erstellt. CourseEditOk tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} wurde erfolgreich geändert. CourseNewDupShort tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester. @@ -43,6 +53,7 @@ UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung ein UnauthorizedSheetCorrector: Sie sind nicht als Korrektor für dieses Übungsblatt eingetragen. UnauthorizedCorrectorAny: Sie sind nicht als Korrektor für eine Veranstaltung eingetragen. UnauthorizedParticipant: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert. +UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen. UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben. UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt. UnauthorizedSubmissionCorrector: Sie sind nicht der Korrektor für diese Abgabe. @@ -51,6 +62,7 @@ DeprecatedRoute: Diese Ansicht ist obsolet und könnte in Zukunft entfallen. UnfreeMaterials: Die Materialien für diese Veranstaltung sind nicht allgemein freigegeben. UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung + SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt. SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt. SubmissionTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen diff --git a/models b/models index ad99eabd2..6cefc3f8e 100644 --- a/models +++ b/models @@ -60,7 +60,7 @@ Course term TermId school SchoolId capacity Int Maybe - hasRegistration Bool -- canRegisterNow = hasRegistration && maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo + -- canRegisterNow = maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo registerFrom UTCTime Maybe registerTo UTCTime Maybe deregisterUntil UTCTime Maybe diff --git a/routes b/routes index bcb457149..6867160e2 100644 --- a/routes +++ b/routes @@ -33,6 +33,7 @@ / HomeR GET !free /users UsersR GET -- no tags, i.e. admins only /admin/test AdminTestR GET POST +/admin/user/#CryptoUUIDUser AdminUserR GET /profile ProfileR GET POST !free !free /profile/data ProfileDataR GET !free !free @@ -47,7 +48,8 @@ /course/ CourseListR GET !free !/course/new CourseNewR GET POST !lecturer /course/#TermId/#Text CourseR !lecturer: - /show CShowR GET POST !free + /show CShowR GET !free + /register CRegisterR POST !time /edit CEditR GET POST /ex SheetListR GET !registered !materials !/ex/new SheetNewR GET POST diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 7019689ea..6b69e0d5f 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -53,6 +53,7 @@ instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where -- Generates CryptoUUID... and CryptoFileName... Datatypes decCryptoIDs [ ''SubmissionId , ''FileId + , ''UserId ] {- TODO: Do we need/want CryptoUUIDs for Sheet numbers? -} diff --git a/src/Foundation.hs b/src/Foundation.hs index 8a45bed2c..89e96385b 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -278,20 +278,28 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req return Authorized ) ,("time", APDB $ \case - CSheetR tid csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do - Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh - Entity sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn - cTime <- liftIO getCurrentTime - let started = sheetActiveFrom <= cTime || NTop sheetVisibleFrom <= (NTop $ Just cTime) - case subRoute of - SFileR SheetExercise _ -> guard started - SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom - SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom - SFileR SheetMarking _ -> mzero -- only for correctors and lecturers - SubmissionNewR -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo - _ -> guard started - return Authorized - r -> do + CSheetR tid csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do + Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh + Entity sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn + cTime <- liftIO getCurrentTime + let started = sheetActiveFrom <= cTime || NTop sheetVisibleFrom <= (NTop $ Just cTime) + case subRoute of + SFileR SheetExercise _ -> guard started + SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom + SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom + SFileR SheetMarking _ -> mzero -- only for correctors and lecturers + SubmissionNewR -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo + _ -> guard started + return Authorized + + CourseR tid csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do + Entity cid Course{..} <- MaybeT . getBy $ CourseTermShort tid csh + cTime <- (NTop . Just) <$> liftIO getCurrentTime + guard $ NTop courseRegisterFrom <= cTime + && NTop courseRegisterTo >= cTime + return Authorized + + r -> do $logErrorS "AccessControl" $ "'!time' used on route that doesn't support it: " <> tshow r unauthorizedI MsgUnauthorized ) @@ -420,8 +428,7 @@ instance Yesod UniWorX where lift $ mapM_ delete oldFavs _other -> return () - res <- defaultYesodMiddleware handler -- handler is executed before Favourites are update - return res + defaultYesodMiddleware handler -- handler is executed afterwards, so Favourites are updated immediately defaultLayout widget = do master <- getYesod diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index cafd75dbe..1fc340912 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -58,3 +58,14 @@ postAdminTestR = do _other -> return () getAdminTestR + +getAdminUserR :: CryptoUUIDUser -> Handler Html +getAdminUserR uuid = do + uid <- decrypt uuid + User{..} <- runDB $ get404 uid + defaultLayout $ + [whamlet| +

TODO +

Admin Page for User #{display userDisplayName} + |] + diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 6e942e0be..4d40bf2c7 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -16,9 +16,9 @@ import Handler.Utils -- import Data.Time import qualified Data.Text as T import Data.Function ((&)) -import Yesod.Form.Bootstrap3 +-- import Yesod.Form.Bootstrap3 -import Colonnade hiding (fromMaybe) +import Colonnade hiding (fromMaybe,bool) import Yesod.Colonnade import qualified Data.UUID.Cryptographic as UUID @@ -79,7 +79,7 @@ getTermCourseListR tidini = do getCShowR :: TermId -> Text -> Handler Html getCShowR tid csh = do mbAid <- maybeAuthId - (courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do + (courseEnt,(schoolMB,participants,registered)) <- runDB $ do courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort tid csh dependent <- (,,) <$> get (courseSchool course) -- join @@ -91,26 +91,33 @@ getCShowR tid csh = do return $ isJust regL) return $ (courseEnt,dependent) let course = entityVal courseEnt - (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerButton $ mbRegistered + (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course + registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid csh CRegisterR) True defaultLayout $ do setTitle $ [shamlet| #{toPathPiece tid} - #{csh}|] $(widgetFile "course") -registerButton :: Bool -> Form () -registerButton registered = renderAForm FormStandard $ - pure () <* bootstrapSubmit regMsg - where - msg = if registered then "Abmelden" else "Anmelden" - regMsg = msg :: BootstrapSubmit Text -postCShowR :: TermId -> Text -> Handler Html -postCShowR tid csh = do +registerForm :: Bool -> Maybe Text -> Form Bool +registerForm registered msecret extra = do + (msecretRes', msecretView) <- case msecret of + Nothing -> return (Nothing,Nothing) + (Just _) -> bimap Just Just <$> (mreq textField (fslpI MsgCourseSecret "Code") Nothing) + (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing + let widget = $(widgetFile "widgets/registerForm") + let msecretRes | Just res <- msecretRes' = Just <$> res + | otherwise = FormSuccess Nothing + return (btnRes *> ((==msecret) <$> msecretRes), widget) -- checks that correct button was pressed, and ignores result of btnRes + + +postCRegisterR :: TermId -> Text -> Handler Html +postCRegisterR tid csh = do aid <- requireAuthId - (cid, registered) <- runDB $ do - (Entity cid _) <- getBy404 $ CourseTermShort tid csh + (cid, course, registered) <- runDB $ do + (Entity cid course) <- getBy404 $ CourseTermShort tid csh registered <- isJust <$> (getBy $ UniqueParticipant aid cid) - return (cid, registered) - ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerButton registered + return (cid, course, registered) + ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course case regResult of (FormSuccess _) | registered -> do @@ -121,8 +128,7 @@ postCShowR tid csh = do regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime when (isJust regOk) $ addMessage "success" "Erfolgreich angemeldet!" (_other) -> return () -- TODO check this! - -- redirect or not?! I guess not, since we want GET now - getCShowR tid csh + redirect $ CourseR tid csh CShowR getCourseNewR :: Handler Html getCourseNewR = do @@ -174,11 +180,10 @@ courseEditHandler isGet course = do , courseTerm = cfTerm res , courseSchool = cfSchool res , courseCapacity = cfCapacity res - , courseHasRegistration = cfHasReg res + , courseRegisterSecret = cfSecret res , courseRegisterFrom = cfRegFrom res , courseRegisterTo = cfRegTo res , courseDeregisterUntil = Nothing -- TODO - , courseRegisterSecret = Nothing -- TODO , courseMaterialFree = True -- TODO } case insertOkay of @@ -230,11 +235,10 @@ courseEditHandler isGet course = do , courseTerm = cfTerm res , courseSchool = cfSchool res , courseCapacity = cfCapacity res - , courseHasRegistration = cfHasReg res + , courseRegisterSecret = cfSecret res , courseRegisterFrom = cfRegFrom res , courseRegisterTo = cfRegTo res , courseDeregisterUntil = Nothing -- TODO - , courseRegisterSecret = Nothing -- TODO , courseMaterialFree = True -- TODO } ) @@ -263,7 +267,7 @@ data CourseForm = CourseForm , cfTerm :: TermId , cfSchool :: SchoolId , cfCapacity :: Maybe Int - , cfHasReg :: Bool + , cfSecret :: Maybe Text , cfRegFrom :: Maybe UTCTime , cfRegTo :: Maybe UTCTime } @@ -282,7 +286,7 @@ courseToForm cEntity = CourseForm , cfTerm = courseTerm course , cfSchool = courseSchool course , cfCapacity = courseCapacity course - , cfHasReg = courseHasRegistration course + , cfSecret = courseRegisterSecret course , cfRegFrom = courseRegisterFrom course , cfRegTo = courseRegisterTo course } @@ -309,9 +313,15 @@ newCourseForm template = identForm FIDcourse $ \html -> do <*> areq termActiveField (fsb "Semester") (cfTerm <$> template) <*> areq schoolField (fsb "Institut") (cfSchool <$> template) <*> aopt (natField "Kapazität") (fsb "Kapazität") (cfCapacity <$> template) - <*> areq checkBoxField (fsb "Anmeldung") (cfHasReg <$> template) - <*> aopt utcTimeField (fsb "Anmeldung von:") (cfRegFrom <$> template) - <*> aopt utcTimeField (fsb "Anmeldung bis:") (cfRegTo <$> template) + <*> aopt textField (fslpI MsgCourseSecret "beliebige Zeichenkette" + & setTooltip "Optional: Anmeldung zum Kurs benötigt ein Passwort") + (cfSecret <$> template) + <*> aopt utcTimeField (fslpI MsgRegisterFrom "(ohne Datum keine Anmeldung möglich)" + & setTooltip "Ohne Datum ist keine Anmeldung zu diesem Kurs möglich!") + (cfRegFrom <$> template) + <*> aopt utcTimeField (fslpI MsgRegisterTo "(ohne Datum unbegrenzte Anmeldung möglich)" + & setTooltip "Die Anmeldung darf ohne Begrenzung sein") + (cfRegTo <$> template) <* submitButton return $ case result of FormSuccess courseResult @@ -338,20 +348,12 @@ validateCourse :: CourseForm -> [Text] validateCourse (CourseForm{..}) = [ msg | (False, msg) <- [ - ( cfRegFrom <= cfRegTo + ( NTop cfRegFrom <= NTop cfRegTo , "Ende des Anmeldezeitraums muss nach dem Anfang liegen" ) - , -- No starting date is okay: effective immediately -- ( cfHasReg <= (isNothing cfRegFrom) -- , "Beginn der Anmeldung angeben oder Anmeldungen deaktivieren" -- ) -- , - ( cfHasReg == (isJust cfRegTo) - , "Ende des Anmeldezeitraums angeben oder Anmeldungen deaktivieren" - ) - , - ( isJust cfRegFrom <= cfHasReg - , "Anmeldungen aktivieren oder Anmeldezeitraum löschen" - ) ] ] diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs index 3a711ff88..b96495d78 100644 --- a/src/Handler/CryptoIDDispatch.hs +++ b/src/Handler/CryptoIDDispatch.hs @@ -54,7 +54,11 @@ instance CryptoRoute (CI FilePath) SubmissionId where Course{..} <- get404 sheetCourse return (courseTerm, courseShorthand, sheetName) return $ CSheetR tid csh shn $ SubmissionR cID - + +instance CryptoRoute UUID UserId where + cryptoIDRoute _ (CryptoID -> cID) = do + (_ :: UserId) <- decrypt cID + return $ AdminUserR cID class Dispatch ciphertext (x :: [*]) where dispatchID :: p x -> ciphertext -> Handler (Maybe (Route UniWorX)) @@ -79,6 +83,7 @@ getCryptoUUIDDispatchR :: UUID -> Handler () getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectWith found302) where p :: Proxy '[ SubmissionId + , UserId ] p = Proxy diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index c8df3f941..b1e24ca7a 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -57,10 +57,10 @@ homeAnonymous = do let tableData :: E.SqlExpr (Entity Course) -> E.SqlQuery (E.SqlExpr (Entity Course)) tableData course = do - E.where_ $ course E.^. CourseHasRegistration E.==. E.val True - 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.where_ $ (E.not_ $ E.isNothing $ course E.^. CourseRegisterFrom) + 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.limit nrSheetDeadlines E.orderBy [ E.asc $ course E.^. CourseRegisterTo , E.desc $ course E.^. CourseShorthand diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index f0ae653e4..a9d57a982 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} @@ -34,7 +35,10 @@ getUsersR = do Nothing -> "???" (Just school) -> schoolShorthand school let colonnadeUsers = mconcat $ - [ headed "User" $ text2widget.userDisplayName.entityVal.fst3 + [ headed "User" $ \u -> do + cID <- encrypt $ entityKey $ fst3 u + let name = display $ userDisplayName $ entityVal $ fst3 u + [whamlet|#{name}|] , headed "Admin for Schools" $ (\u -> text2widget $ intercalate ", " $ map (getSchoolname.userAdminSchool .entityVal) $ snd3 u) , headed "Lecturer at Schools" $ (\u -> text2widget $ intercalate ", " $ map (getSchoolname.userLecturerSchool.entityVal) $ trd3 u) ] diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 6b87666e5..cb780abe7 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -100,8 +100,8 @@ instance PathPiece BtnDelete where -- for displaying the button only, not rea fromPathPiece = readFromPathPiece instance Button BtnDelete where - label BtnDelete = "Löschen" - label BtnAbort = "Abrechen" + label BtnDelete = [whamlet|_{MsgBtnDelete}|] + label BtnAbort = [whamlet|_{MsgBtnAbort}|] cssClass BtnDelete = BCDanger cssClass BtnAbort = BCDefault @@ -115,10 +115,26 @@ instance PathPiece SubmitButton where fromPathPiece = readFromPathPiece instance Button SubmitButton where - label BtnSubmit = "Submit" + label BtnSubmit = [whamlet|_{MsgBtnSubmit}|] cssClass BtnSubmit = BCPrimary + +data RegisterButton = BtnRegister | BtnDeregister + deriving (Enum, Eq, Ord, Bounded, Read, Show) + +instance PathPiece RegisterButton where + toPathPiece = showToPathPiece + fromPathPiece = readFromPathPiece + +instance Button RegisterButton where + label BtnRegister = [whamlet|_{MsgBtnRegister}|] + label BtnDeregister = [whamlet|_{MsgBtnDeregister}|] + + cssClass BtnRegister = BCPrimary + cssClass BtnDeregister = BCDanger + + -- -- Looks like a button, but is just a link (e.g. for create course, etc.) -- data LinkButton = LinkButton (Route UniWorX) -- deriving (Enum, Eq, Ord, Bounded, Read, Show) @@ -138,7 +154,7 @@ linkButton lbl cls url = [whamlet| Route UniWorX -> Widget simpleLink lbl url = [whamlet| ^{lbl} |] -buttonField :: Button a => a -> Field Handler a +buttonField :: Button a => a -> Field Handler a -- already validates that the correct button press was received (result only neccessary for combinedButtonField) buttonField btn = Field {fieldParse, fieldView, fieldEnctype} where fieldEnctype = UrlEncoded diff --git a/templates/course.hamlet b/templates/course.hamlet index 256b74c1a..bab4e83c8 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -32,13 +32,10 @@ - $# if allowed to register -
-