diff --git a/config/settings.yml b/config/settings.yml index 735afe776..51966ee5d 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -19,6 +19,7 @@ should-log-all: "_env:LOG_ALL:false" # mutable-static: false # skip-combining: false auth-dummy-login: "_env:DUMMY_LOGIN:false" +allow-deprecated: "_env:ALLOW_DEPRECATED:false" # NB: If you need a numeric value (e.g. 123) to parse as a String, wrap it in single quotes (e.g. "_env:PGPASS:'123'") # See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings diff --git a/messages/de.msg b/messages/de.msg index 6dd0a5196..d7eb1b787 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 @@ -12,6 +21,7 @@ TermEditHeading: Semester editieren/anlegen LectureStart: Beginn Vorlesungen 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. @@ -44,6 +54,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. @@ -53,6 +64,7 @@ UnfreeMaterials: Die Materialien für diese Veranstaltung sind nicht allgemein f UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung Submission: Abgabenummer + 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 @@ -63,12 +75,25 @@ SubmissionAlreadyExistsFor user@Text: #{user} hat bereits eine Abgabe zu diesem CorrectionsTitle: Zugewiesene Korrekturen CourseCorrectionsTitle: Korrekturen für diesen Kurs -Corrector: Korrektor EMail: E-Mail 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. +AddCorrector: Zusätzlicher Korrektor +CorrectorExists user@Text: #{user} ist bereits als Korrektor eingetragen +SheetCorrectorsTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: Korrektoren für #{termToText tid}-#{courseShortHand} #{sheetName} +CountTutProp: Tutorien zählen gegen Proportion +Corrector: Korrektor +Correctors: Korrektoren +CorByTut: Nach Tutorium +CorProportion: Anteil +DeleteRow: Zeile entfernen +ProportionNegative: Anteile dürfen nicht negativ sein +CorrectorsUpdated: Korrektoren erfolgreich aktualisiert +CorrectorsPlaceholder: Korrektoren... +CorrectorsDefaulted: Korrektoren-Liste wurde aus bisherigen Übungsblättern diesen Kurses generiert. Es sind keine Daten gespeichert. + HomeHeading: Aktuelle Termine ProfileHeading: Benutzerprofil und Einstellungen ProfileDataHeading: Gespeicherte Benutzerdaten @@ -97,4 +122,5 @@ NrColumn: Nr SelectColumn: Auswahl CorrDownload: Herunterladen -CorrSetCorrector: Korrektor zuweisen \ No newline at end of file +CorrSetCorrector: Korrektor zuweisen +NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein! diff --git a/models b/models index ad99eabd2..070bc1a17 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 @@ -119,6 +119,7 @@ SheetCorrector sheet SheetId load Load UniqueSheetCorrector user sheet + deriving Show Eq Ord SheetFile sheet SheetId file FileId diff --git a/package.yaml b/package.yaml index bb217ec2b..ccfb37678 100644 --- a/package.yaml +++ b/package.yaml @@ -81,6 +81,7 @@ dependencies: - exceptions - lens - MonadRandom +- email-validate # The library contains all of our application code. The executable # defined below is just a thin wrapper. diff --git a/routes b/routes index 016e15340..bc7a61877 100644 --- a/routes +++ b/routes @@ -21,7 +21,7 @@ -- !isRead -- only if it is read-only access (i.e. GET but not POST) -- !isWrite -- only if it is write access (i.e. POST only) why needed??? -- --- !deprecated -- like free, but logs and gives a warning +-- !deprecated -- like free, but logs and gives a warning; entirely disabled in production -- /static StaticR Static appStatic !free @@ -30,9 +30,10 @@ /favicon.ico FaviconR GET !free /robots.txt RobotsR GET !free -/ HomeR GET !free -/users UsersR GET -- no tags, i.e. admins only +/ 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 /corrections CourseCorrectionsR GET POST /ex SheetListR GET !registered !materials @@ -60,9 +62,11 @@ !/sub/new SubmissionNewR GET POST !timeANDregistered !/sub/own SubmissionOwnR GET !free !/sub/#CryptoFileNameSubmission SubmissionR GET POST !owner !corrector + /correctors SCorrR GET POST /corrections CorrectionsR GET POST !free + -- TODO below !/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !deprecated !/#CryptoFileNameSubmission/*FilePath SubmissionDownloadSingleR GET !deprecated diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 7019689ea..28fb616d1 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -39,7 +39,7 @@ instance PathPiece UUID where instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where fromPathPiece = fmap CI.mk . fromPathPiece - toPathPiece = toPathPiece . CI.original + toPathPiece = toPathPiece . CI.foldedCase instance {-# OVERLAPS #-} PathMultiPiece FilePath where fromPathMultiPiece = Just . unpack . intercalate "/" @@ -47,12 +47,13 @@ instance {-# OVERLAPS #-} PathMultiPiece FilePath where instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where fromPathMultiPiece = fmap CI.mk . fromPathMultiPiece - toPathMultiPiece = toPathMultiPiece . CI.original + toPathMultiPiece = toPathMultiPiece . CI.foldedCase -- 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 28ae4faa4..c4e22c72e 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1,6 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE TemplateHaskell, QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} @@ -236,12 +235,13 @@ adminAP = APDB $ \case knownTags :: Map (CI Text) AccessPredicate -knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId +knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or requireAuthId [("free", trueAP) ,("deprecated", APHandler $ \r -> do $logWarnS "AccessControl" ("deprecated route: " <> tshow r) addMessageI "error" MsgDeprecatedRoute - return Authorized + allow <- appAllowDeprecated . appSettings <$> getYesod + return $ bool (Unauthorized "Deprecated Route") Authorized allow ) ,("lecturer", APDB $ \case CourseR tid csh _ -> exceptT return return $ do @@ -289,20 +289,28 @@ knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId 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 ) @@ -406,9 +414,9 @@ instance Yesod UniWorX where -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package. yesodMiddleware handler = do - res <- defaultYesodMiddleware handler void . runMaybeT $ do route <- MaybeT getCurrentRoute + guardM . lift $ (== Authorized) <$> isAuthorized route False case route of -- update Course Favourites here CourseR tid csh _ -> do uid <- MaybeT maybeAuthId @@ -431,7 +439,7 @@ instance Yesod UniWorX where lift $ mapM_ delete oldFavs _other -> return () - return res + defaultYesodMiddleware handler -- handler is executed afterwards, so Favourites are updated immediately defaultLayout widget = do master <- getYesod @@ -568,7 +576,6 @@ instance Yesod UniWorX where makeLogger = return . appLogger - -- Define breadcrumbs. instance YesodBreadcrumbs UniWorX where breadcrumb TermShowR = return ("Semester", Just HomeR) @@ -579,38 +586,55 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (TermCourseListR term) = return (toPathPiece term, Just TermShowR) breadcrumb (CourseR term course CShowR) = return (course, Just $ TermCourseListR term) breadcrumb CourseNewR = return ("Neu", Just CourseListR) - breadcrumb (CourseR _ _ CEditR) = return ("Editieren", Just CourseListR) + breadcrumb (CourseR tid csh CEditR) = return ("Editieren", Just $ CourseR tid csh CShowR) breadcrumb (CourseR tid csh SheetListR) = return ("Übungen",Just $ CourseR tid csh CShowR) breadcrumb (CourseR tid csh SheetNewR ) = return ("Neu", Just $ CourseR tid csh SheetListR) breadcrumb (CSheetR tid csh shn SShowR) = return (shn, Just $ CourseR tid csh SheetListR) breadcrumb (CSheetR tid csh shn SEditR) = return ("Edit", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid csh shn SShowR) + breadcrumb (CSheetR tid csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid csh shn (SubmissionR _)) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) breadcrumb SubmissionListR = return ("Abgaben", Just HomeR) - breadcrumb HomeR = return ("UniWorkY", Nothing) - breadcrumb (AuthR _) = return ("Login", Just HomeR) - breadcrumb ProfileR = return ("Profile", Just HomeR) + breadcrumb HomeR = return ("UniWorkY", Nothing) + breadcrumb (AuthR _) = return ("Login", Just HomeR) + breadcrumb ProfileR = return ("Profile", Just HomeR) breadcrumb ProfileDataR = return ("Data", Just ProfileR) breadcrumb _ = return ("home", Nothing) pageActions :: Route UniWorX -> [MenuTypes] pageActions (CourseR tid csh CShowR) = [ PageActionPrime $ MenuItem - { menuItemLabel = "Übungsblätter" - , menuItemIcon = Nothing - , menuItemRoute = CourseR tid csh SheetListR - , menuItemAccessCallback' = return True - } - , PageActionPrime $ MenuItem { menuItemLabel = "Kurs Editieren" , menuItemIcon = Nothing , menuItemRoute = CourseR tid csh CEditR , menuItemAccessCallback' = return True } + , PageActionPrime $ MenuItem + { menuItemLabel = "Übungsblätter" + , menuItemIcon = Nothing + , menuItemRoute = CourseR tid csh SheetListR + , menuItemAccessCallback' = do --TODO always show for lecturer + let sheetRouteAccess shn = (== Authorized) <$> (isAuthorized (CSheetR tid csh shn SShowR) False) + muid <- maybeAuthId + (sheets,lecturer) <- runDB $ do + cid <- getKeyBy404 $ CourseTermShort tid csh + sheets <- map (sheetName.entityVal) <$> selectList [SheetCourse ==. cid] [Desc SheetActiveFrom] + lecturer <- case muid of + Nothing -> return False + (Just uid) -> existsBy $ UniqueLecturer uid cid + return (sheets,lecturer) + or2M (return lecturer) $ anyM sheets sheetRouteAccess + } + , PageActionSecondary $ MenuItem + { menuItemLabel = "Neues Übungsblatt anlegen" + , menuItemIcon = Nothing + , menuItemRoute = CourseR tid csh SheetNewR + , menuItemAccessCallback' = return True + } ] pageActions (CourseR tid csh SheetListR) = [ PageActionPrime $ MenuItem @@ -628,11 +652,17 @@ pageActions (CSheetR tid csh shn SShowR) = , menuItemAccessCallback' = return True -- TODO: check that no submission already exists } , PageActionPrime $ MenuItem - { menuItemLabel = "Abgabe" + { menuItemLabel = "Abgabe ansehen" , menuItemIcon = Nothing , menuItemRoute = CSheetR tid csh shn SubmissionOwnR , menuItemAccessCallback' = return True -- TODO: check that a submission already exists } + , PageActionPrime $ MenuItem + { menuItemLabel = "Korrektoren" + , menuItemIcon = Nothing + , menuItemRoute = CSheetR tid csh shn SCorrR + , menuItemAccessCallback' = return True + } ] pageActions TermShowR = [ PageActionPrime $ MenuItem 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..a8728f2c9 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,38 +91,45 @@ 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 + (Just _) | not registered -> bimap Just Just <$> (mreq textField (fslpI MsgCourseSecret "Code") Nothing) + _ -> return (Nothing,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 _) + (FormSuccess codeOk) | registered -> do runDB $ deleteBy $ UniqueParticipant aid cid addMessage "info" "Sie wurden abgemeldet." - | otherwise -> do + | codeOk -> do actTime <- liftIO $ getCurrentTime regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime when (isJust regOk) $ addMessage "success" "Erfolgreich angemeldet!" + | otherwise -> addMessage "danger" "Falsches Kennwort!" (_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 +181,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 +236,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 +268,7 @@ data CourseForm = CourseForm , cfTerm :: TermId , cfSchool :: SchoolId , cfCapacity :: Maybe Int - , cfHasReg :: Bool + , cfSecret :: Maybe Text , cfRegFrom :: Maybe UTCTime , cfRegTo :: Maybe UTCTime } @@ -282,7 +287,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 +314,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 +349,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 3a001ce59..464b56659 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -1,7 +1,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -15,6 +14,8 @@ module Handler.Home where import Import import Handler.Utils +import qualified Data.Map as Map + import Data.Time -- import qualified Data.Text as T -- import Yesod.Form.Bootstrap3 @@ -56,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 @@ -74,13 +75,14 @@ homeAnonymous = do let tid = courseTerm course csh = courseShorthand course cell [whamlet|#{display csh}|] - , sortable (Just "deadline") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> + , sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> textCell $ display $ courseRegisterTo course ] courseTable <- dbTable def $ DBTable { dbtSQLQuery = tableData , dbtColonnade = colonnade - , dbtSorting = [ ( "term" + , dbtSorting = Map.fromList + [ ( "term" , SortColumn $ \(course) -> course E.^. CourseTerm ) , ( "course" @@ -147,7 +149,8 @@ homeUser uid = do sheetTable <- dbTable def $ DBTable { dbtSQLQuery = tableData , dbtColonnade = colonnade - , dbtSorting = [ ( "term" + , dbtSorting = Map.fromList + [ ( "term" , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ ) -> course E.^. CourseTerm ) , ( "course" diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 76fb32dfc..c21527b77 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -28,7 +28,7 @@ makeSettingForm :: Maybe SettingsForm -> Form SettingsForm makeSettingForm template = identForm FIDsettings $ \html -> do let themeList = [(display t,t) | t <- allThemes] (result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm - <$> areq (natField "Favoriten") -- TODO: natFieldI not working here + <$> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here (fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template) <*> areq (selectFieldList themeList) (fslI MsgTheme ) (stgTheme <$> template) @@ -58,8 +58,9 @@ getProfileR = do , OffsetBy $ stgMaxFavourties ] mapM_ delete oldFavs - addMessageI "info" $ MsgSettingsUpdate + redirect ProfileR -- TODO: them change does not happen without redirect + (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml _ -> return () diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index de87fad9d..94d73ea80 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -8,8 +8,12 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE MultiWayIf, LambdaCase #-} +{-# LANGUAGE TupleSections #-} module Handler.Sheet where @@ -23,9 +27,10 @@ import Handler.Utils.Zip import qualified Data.Text as T -- import Data.Function ((&)) -- -import Colonnade hiding (fromMaybe, singleton) +import Colonnade hiding (fromMaybe, singleton, bool) import qualified Yesod.Colonnade as Yesod --- +import Text.Blaze (text) +-- import qualified Data.UUID.Cryptographic as UUID import qualified Data.Conduit.List as C @@ -33,12 +38,24 @@ import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Internal.Sql as E import Control.Monad.Writer (MonadWriter(..), execWriterT) +import Control.Monad.Trans.RWS.Lazy (RWST, local) + +import qualified Text.Email.Validate as Email + +import qualified Data.List as List import Network.Mime +import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Map as Map +import Data.Map (Map, (!), (!?)) +import qualified Data.Map as Map + +import Control.Lens +import Utils.Lens + instance Eq (Unique Sheet) where (CourseSheet cid1 name1) == (CourseSheet cid2 name2) = @@ -65,7 +82,6 @@ data SheetForm = SheetForm , sfSolutionFrom :: Maybe UTCTime , sfSolutionF :: Maybe FileInfo -- Keine SheetId im Formular! - , sfCorrectors :: [(UserId,Load)] } @@ -93,7 +109,6 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do <*> fileAFormOpt (fsb "Hinweis") <*> aopt utcTimeField (fsb "Lösung ab") (sfSolutionFrom <$> template) <*> fileAFormOpt (fsb "Lösung") - <*> formToAForm (correctorForm msId (maybe [] sfCorrectors template)) <* submitButton return $ case result of FormSuccess sheetResult @@ -124,16 +139,6 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do -- TODO: continue validation here!!! ] ] -correctorForm :: Maybe SheetId -> [(UserId,Load)] -> MForm Handler (FormResult [(UserId,Load)], [FieldView UniWorX]) -correctorForm _msid templates = return mempty -- TODO deprecated - -- Datenbank UserId -> UserName - -- Eingabelist für Colonnade - -- enthält die benötigten Felder - -- FormResult konstruieren - -- Eingabebox für Korrektor hinzufügen - -- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen - - -- List Sheets getSheetListCID :: CourseId -> Handler Html getSheetListCID cid = getSheetList =<< @@ -160,7 +165,7 @@ getSheetList courseEnt = do let colBase = mconcat [ 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 "Abgabe lbis" $ toWgt . formatTimeGerWD . sheetActiveTo . snd3 , headed "Bewertung" $ toWgt . display . sheetType . snd3 ] let colAdmin = mconcat -- only show edit button for allowed course assistants @@ -178,7 +183,7 @@ getSheetList courseEnt = do then colBase `mappend` colAdmin else colBase defaultLayout $ do - setTitle $ toHtml $ T.append "Übungsblätter " csh + setTitle $ toHtml $ csh <> " Übungsblätter" if null sheets then [whamlet|Es wurden noch keine Übungsblätter angelegt.|] else Yesod.encodeWidgetTable tableDefault colSheets sheets @@ -304,7 +309,6 @@ getSEditR tid csh shn = do , sfHintF = Nothing -- TODO , sfSolutionFrom = sheetSolutionFrom , sfSolutionF = Nothing -- TODO - , sfCorrectors = [] -- TODO read correctors from list } let action newSheet = do replaceRes <- myReplaceUnique sid $ newSheet @@ -413,3 +417,201 @@ insertSheetFile' sid ftype fs = do finsert (Right file) = lift $ do fid <- insert file void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step + + +data CorrectorForm = CorrectorForm + { cfUserId :: UserId + , cfUserName :: Text + , cfResult :: FormResult Load + , cfViewByTut, cfViewProp, cfViewDel :: FieldView UniWorX + } + +type Loads = Map UserId Load + +defaultLoads :: SheetId -> DB Loads +-- ^ Generate `Loads` in such a way that minimal editing is required +-- +-- For every user, that ever was a corrector for this course, return their last `Load`. +-- "Last `Load`" is taken to mean their `Load` on the `Sheet` with the most recent creation time (first edit). +defaultLoads shid = do + cId <- sheetCourse <$> getJust shid + fmap toMap . E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> E.distinctOnOrderBy [E.asc (sheetCorrector E.^. SheetCorrectorUser)] $ do + E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet + + let creationTime = E.sub_select . E.from $ \sheetEdit -> do + E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId + return . E.min_ $ sheetEdit E.^. SheetEditTime + + E.where_ $ sheet E.^. SheetCourse E.==. E.val cId + + E.orderBy [E.desc creationTime] + + return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad) + where + toMap :: [(E.Value UserId, E.Value Load)] -> Loads + toMap = foldMap $ \(E.Value uid, E.Value load) -> Map.singleton uid load + + +correctorForm :: SheetId -> MForm Handler (FormResult (Set SheetCorrector), [FieldView UniWorX]) +correctorForm shid = do + cListIdent <- newFormIdent + let + guardNonDeleted :: UserId -> Handler (Maybe UserId) + guardNonDeleted uid = do + cID@CryptoID{..} <- encrypt uid :: Handler CryptoUUIDUser + deleted <- lookupPostParam $ tshow ciphertext <> "-" <> "del" + return $ bool Just (const Nothing) (isJust deleted) uid + formCIDs <- mapM decrypt =<< catMaybes <$> liftHandlerT (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser]) + let + currentLoads :: DB Loads + currentLoads = Map.fromList . map (\(Entity _ SheetCorrector{..}) -> (sheetCorrectorUser, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] [] + (defaultLoads', currentLoads') <- lift . runDB $ (,) <$> defaultLoads shid <*> currentLoads + loads' <- fmap (Map.fromList [(uid, mempty) | uid <- formCIDs] `Map.union`) $ if + | Map.null currentLoads' + , null formCIDs -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI "warn" MsgCorrectorsDefaulted) + | otherwise -> return $ Map.fromList (map (, mempty) formCIDs) `Map.union` currentLoads' + + deletions <- lift $ foldM (\dels uid -> maybe (Set.insert uid dels) (const dels) <$> guardNonDeleted uid) Set.empty (Map.keys loads') + + let loads'' = Map.restrictKeys loads' (Map.keysSet loads' `Set.difference` deletions) + didDelete = any (flip Set.member deletions) formCIDs + + (countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\Load{..} -> fromMaybe False byTutorial) $ Map.elems loads' + let + tutorField :: Field Handler [Text] + tutorField = multiEmailField + { fieldView = \theId name attrs val isReq -> asWidgetT $ do + listIdent <- newIdent + userId <- handlerToWidget requireAuthId + previousCorrectors <- handlerToWidget . runDB . E.select . E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserEmail ] $ do + E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet + E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId + E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId + return $ user E.^. UserEmail + [whamlet| + $newline never + + + $forall E.Value prev <- previousCorrectors +
+ ^{fvInput addTutView} +