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/fill-db.hs b/fill-db.hs index 12301d0d8..725718792 100755 --- a/fill-db.hs +++ b/fill-db.hs @@ -25,6 +25,7 @@ main = db $ do , userEmail = "G.Kleen@campus.lmu.de" , userDisplayName = "Gregor Kleen" , userMaxFavourites = 6 + , userTheme = AberdeenReds } fhamann <- insert User { userPlugin = "LDAP" @@ -33,6 +34,7 @@ main = db $ do , userEmail = "felix.hamann@campus.lmu.de" , userDisplayName = "Felix Hamann" , userMaxFavourites = defaultFavourites + , userTheme = Default } jost <- insert User { userPlugin = "LDAP" @@ -41,6 +43,7 @@ main = db $ do , userEmail = "jost@tcs.ifi.lmu.de" , userDisplayName = "Steffen Jost" , userMaxFavourites = 14 + , userTheme = MintGreen } void . insert $ Term { termName = summer2017 diff --git a/messages/de.msg b/messages/de.msg index 95cb620f1..51152d5b2 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 @@ -5,13 +14,23 @@ Page n@Int64: #{tshow n} TermEdited tid@TermIdentifier: Semester #{termToText tid} erfolgreich editiert. TermNewTitle: Semester editiere/anlegen. InvalidInput: Eingaben bitte korrigieren. +Term: Semester +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. CourseEditDupShort tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester. FFSheetName: Name +TermCourseListHeading tid@TermIdentifier: Kursübersicht #{termToText tid} +TermCourseListTitle tid@TermIdentifier: Kurse #{termToText tid} +CourseEditHeading: Kurs editieren/anlegen +CourseEditTitle: Kurs editieren/anlegen +Sheet: Blatt SheetNewOk tid@TermIdentifier courseShortHand@Text sheetName@Text: Neues Übungsblatt #{sheetName} wurde im Kurs #{termToText tid}-#{courseShortHand} erfolgreich erstellt. SheetTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand} #{sheetName} SheetTitleNew tid@TermIdentifier courseShortHand@Text : #{termToText tid}-#{courseShortHand}: Neues Übungsblatt @@ -21,9 +40,12 @@ SheetDelTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: Übun SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{show submissionNo} Abgaben. SheetDelOk tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht. +Deadline: Abgabe +Done: Eingereicht + Unauthorized: Sie haben hierfür keine explizite Berechtigung. -UnauthorizedAnd l@Text r@Text: "#{l}" und "#{r}" -UnauthorizedOr l@Text r@Text: "#{l}" oder "#{r}" +UnauthorizedAnd l@Text r@Text: #{l} UND #{r} +UnauthorizedOr l@Text r@Text: #{l} ODER #{r} UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen. UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen. UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen. @@ -31,12 +53,15 @@ 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. OnlyUploadOneFile: Bitte nur eine Datei hochladen. 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. @@ -44,8 +69,9 @@ SubmissionTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termTo SubmissionMember g@Int: Mitabgebende(r) ##{tshow g} SubmissionArchive: Zip-Archiv der Abgabedatei(en) SubmissionFile: Datei zur Abgabe -SubmissionAlreadyExistsFor user@Text: #{user} hat bereits eine Abgabe zu diesem Übungsblatt. +SubmissionAlreadyExistsFor user@Text: #{user} hat bereits eine Abgabe zu diesem bÜbungsblatt. +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. @@ -60,4 +86,29 @@ CorProportion: Anteil DeleteRow: Zeile entfernen ProportionNegative: Anteile dürfen nicht negativ sein CorrectorsUpdated: Korrektoren erfolgreich aktualisiert -CorrectorsPlaceholder: Korrektoren... \ No newline at end of file +CorrectorsPlaceholder: Korrektoren... + +HomeHeading: Aktuelle Termine +ProfileHeading: Benutzerprofil und Einstellungen +ProfileDataHeading: Gespeicherte Benutzerdaten +TermsHeading: Semesterübersicht + +NumCourses n@Int64: #{tshow n} Kurse +CloseAlert: Schliessen + +Name: Name +MatrikelNr: Matrikelnummer +Theme: Oberflächen Design +Favoriten: Anzahl gespeicherter Favoriten +Plugin: Plugin +Ident: Identifizierung +Settings: Individuelle Benutzereinstellungen +SettingsUpdate: Einstellungen wurden gespeichert. + +SheetExercise: Aufgabenstellung +SheetHint: Hinweise +SheetSolution: Lösung +SheetMarking: Korrekturhinweise + +MultiFileUploadInfo: (Mehrere Dateien mit Shift oder Strg auswählen) +NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein! diff --git a/models b/models index 4ebb5d3a0..070bc1a17 100644 --- a/models +++ b/models @@ -4,7 +4,8 @@ User matrikelnummer Text Maybe email Text displayName Text - maxFavourites Int default=12 + maxFavourites Int default=12 + theme Theme default='default' UniqueAuthentication plugin ident UniqueEmail email UserAdmin @@ -59,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 57f76b759..d0935a946 100644 --- a/routes +++ b/routes @@ -18,8 +18,10 @@ -- -- !materials -- only if course allows all materials to be free (no meaning outside of courses) -- !time -- access depends on time somehow +-- !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 @@ -28,38 +30,49 @@ /favicon.ico FaviconR GET !free /robots.txt RobotsR GET !free -/ HomeR GET POST !free -/profile ProfileR 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 -/term TermShowR GET !free -/term/edit TermEditR GET POST -/term/#TermId/edit TermEditExistR GET -!/term/#TermId TermCourseListR GET !free +/profile ProfileR GET POST !free !free +/profile/data ProfileDataR GET !free !free + +/terms TermShowR GET !free +/terms/current TermCurrentR GET !free +/terms/edit TermEditR GET POST +/terms/#TermId/edit TermEditExistR GET +!/terms/#TermId TermCourseListR GET !free -- For Pattern Synonyms see Foundation /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 /ex/#Text SheetR: /show SShowR GET !timeANDregistered !timeANDmaterials !corrector - /#SheetFileType/#FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector + !/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector /edit SEditR GET POST /delete SDelR GET POST - !/submission/#SubmissionMode SubmissionR GET POST !timeANDregistered !owner + !/sub/new SubmissionNewR GET POST !timeANDregistered + !/sub/own SubmissionOwnR GET !free + !/sub/#CryptoFileNameSubmission SubmissionR GET POST !owner !corrector + /correctors SCorrR GET POST -!/#UUID CryptoUUIDDispatchR GET !free -- just redirect - -- TODO below !/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !deprecated -!/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET !deprecated +!/#CryptoFileNameSubmission/*FilePath SubmissionDownloadSingleR GET !deprecated /submission SubmissionListR GET !deprecated /submission/#CryptoUUIDSubmission SubmissionDemoR GET POST !deprecated /submissions.zip SubmissionDownloadMultiArchiveR POST !deprecated +-- TODO above + +!/#UUID CryptoUUIDDispatchR GET !free -- just redirect +!/*{CI FilePath} CryptoFileNameDispatchR GET !free diff --git a/src/Application.hs b/src/Application.hs index 33a3fd07b..a671b5296 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -43,6 +43,7 @@ import Handler.Common import Handler.Home import Handler.Profile import Handler.Users +import Handler.Admin import Handler.Term import Handler.Course import Handler.Sheet diff --git a/src/CryptoID.hs b/src/CryptoID.hs index d13e98425..28fb616d1 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -24,6 +24,8 @@ import Data.CryptoID.Poly.ImplicitNamespace import Data.UUID.Cryptographic.ImplicitNamespace import System.FilePath.Cryptographic.ImplicitNamespace +import qualified Data.Text as Text + import Data.UUID.Types import Web.PathPieces @@ -35,11 +37,21 @@ instance PathPiece UUID where fromPathPiece = fromString . unpack toPathPiece = pack . toString +instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where + fromPathPiece = fmap CI.mk . fromPathPiece + toPathPiece = toPathPiece . CI.foldedCase --- Generates CryptoUUID... Datatypes +instance {-# OVERLAPS #-} PathMultiPiece FilePath where + fromPathMultiPiece = Just . unpack . intercalate "/" + toPathMultiPiece = Text.splitOn "/" . pack + +instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where + fromPathMultiPiece = fmap CI.mk . fromPathMultiPiece + toPathMultiPiece = toPathMultiPiece . CI.foldedCase + + +-- Generates CryptoUUID... and CryptoFileName... Datatypes decCryptoIDs [ ''SubmissionId - , ''CourseId - , ''SheetId , ''FileId , ''UserId ] @@ -47,12 +59,12 @@ decCryptoIDs [ ''SubmissionId -newtype SubmissionMode = SubmissionMode (Maybe CryptoUUIDSubmission) +newtype SubmissionMode = SubmissionMode (Maybe CryptoFileNameSubmission) deriving (Show, Read, Eq) pattern NewSubmission :: SubmissionMode pattern NewSubmission = SubmissionMode Nothing -pattern ExistingSubmission :: CryptoUUIDSubmission -> SubmissionMode +pattern ExistingSubmission :: CryptoFileNameSubmission -> SubmissionMode pattern ExistingSubmission cID = SubmissionMode (Just cID) instance PathPiece SubmissionMode where @@ -62,6 +74,7 @@ instance PathPiece SubmissionMode where toPathPiece (SubmissionMode Nothing) = "new" toPathPiece (SubmissionMode (Just x)) = toPathPiece x + newtype ZIPArchiveName objID = ZIPArchiveName (CryptoID (CI FilePath) objID) deriving (Show, Read, Eq) diff --git a/src/Foundation.hs b/src/Foundation.hs index af80704a9..686efb4d2 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1,7 +1,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -49,6 +48,7 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.List (foldr1) +import qualified Data.List as List import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map, (!?)) @@ -68,9 +68,17 @@ import System.FilePath import Handler.Utils.Templates import Handler.Utils.StudyFeatures +import Handler.Utils.DateTime import Control.Lens import Utils.Lens +-- -- TODO: Move me to appropriate Place +instance DisplayAble TermId where + display = termToText . unTermKey + +instance DisplayAble UTCTime where + display = pack . formatTimeGerDT2 -- default Time Format to be used: 00.00.00 00:00 + -- infixl 9 :$: -- pattern a :$: b = a b @@ -110,7 +118,6 @@ type MsgRenderer = MsgRendererS UniWorX -- see Utils pattern CSheetR tid csh shn ptn = CourseR tid csh (SheetR shn ptn) - -- Menus and Favourites data MenuItem = MenuItem { menuItemLabel :: Text @@ -146,6 +153,13 @@ instance RenderMessage UniWorX TermIdentifier where Winter -> renderMessage' $ MsgWinterTerm year where renderMessage' = renderMessage foundation ls +instance RenderMessage UniWorX SheetFileType where + renderMessage foundation ls = \case + SheetExercise -> renderMessage' MsgSheetExercise + SheetHint -> renderMessage' MsgSheetHint + SheetSolution -> renderMessage' MsgSheetSolution + SheetMarking -> renderMessage' MsgSheetMarking + where renderMessage' = renderMessage foundation ls -- Access Control data AccessPredicate @@ -159,14 +173,12 @@ orAR _ _ Authorized = Authorized orAR _ AuthenticationRequired _ = AuthenticationRequired orAR _ _ AuthenticationRequired = AuthenticationRequired orAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedOr x y -andAR _ Authorized Authorized = Authorized -andAR _ Authorized other = other -andAR _ other Authorized = other -andAR _ AuthenticationRequired other = other -andAR _ other AuthenticationRequired = other +-- and andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y - - +andAR _ reason@(Unauthorized x) _ = reason +andAR _ _ reason@(Unauthorized x) = reason +andAR _ Authorized other = other +andAR _ AuthenticationRequired _ = AuthenticationRequired orAP,andAP :: AccessPredicate -> AccessPredicate -> AccessPredicate orAP = liftAR orAR (== Authorized) @@ -176,22 +188,23 @@ liftAR :: (MsgRenderer -> AuthResult -> AuthResult -> AuthResult) -> (AuthResult -> Bool) -- ^ Predicate to Short-Circuit on first argument -> AccessPredicate -> AccessPredicate -> AccessPredicate -- Ensure to first evaluate Pure conditions, then Handler before DB -liftAR op sc (APPure f) (APPure g) = APPure $ \r -> shortCircuitM sc (f r) (g r) . op =<< ask -liftAR op sc (APHandler f) (APHandler g) = APHandler $ \r -> shortCircuitM sc (f r) (g r) . op =<< getMsgRenderer -liftAR op sc (APDB f) (APDB g) = APDB $ \r -> shortCircuitM sc (f r) (g r) . op =<< getMsgRenderer -liftAR op sc (APPure f) apg = liftAR op sc (APHandler $ \r -> runReader (f r) <$> getMsgRenderer) apg -liftAR op sc apf apg@(APPure _) = liftAR op sc apg apf -liftAR op sc (APHandler f) apdb = liftAR op sc (APDB $ lift . f) apdb -liftAR op sc apdb apg@(APHandler _) = liftAR op sc apg apdb +liftAR ops sc (APPure f) (APPure g) = APPure $ \r -> shortCircuitM sc (f r) (g r) . ops =<< ask +liftAR ops sc (APHandler f) (APHandler g) = APHandler $ \r -> shortCircuitM sc (f r) (g r) . ops =<< getMsgRenderer +liftAR ops sc (APDB f) (APDB g) = APDB $ \r -> shortCircuitM sc (f r) (g r) . ops =<< getMsgRenderer +liftAR ops sc (APPure f) apg = liftAR ops sc (APHandler $ \r -> runReader (f r) <$> getMsgRenderer) apg +liftAR ops sc apf apg@(APPure _) = liftAR ops sc apg apf +liftAR ops sc (APHandler f) apdb = liftAR ops sc (APDB $ lift . f) apdb +liftAR ops sc apdb apg@(APHandler _) = liftAR ops sc apg apdb trueAP,falseAP :: AccessPredicate trueAP = APPure . const $ return Authorized -falseAP = APPure . const $ Unauthorized . ($ MsgUnauthorized) . render <$> ask --- TODO: I believe falseAP := adminAP +falseAP = APPure . const $ Unauthorized . ($ MsgUnauthorized) . render <$> ask -- always use adminAP instead -adminAP :: AccessPredicate + +adminAP :: AccessPredicate -- access for admins (of appropriate school in case of course-routes) adminAP = APDB $ \case + -- Courses: access only to school admins CourseR tid csh _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do @@ -200,23 +213,24 @@ adminAP = APDB $ \case E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseShorthand E.==. E.val csh return (E.countRows :: E.SqlExpr (E.Value Int64)) - guardMExceptT (unauthorizedI MsgUnauthorizedSchoolAdmin) (c > 0) + guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedSchoolAdmin) return Authorized - + -- other routes: access to any admin is granted here _other -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId adrights <- lift $ selectFirst [UserAdminUser ==. authId] [] - case adrights of - (Just _) -> return Authorized - Nothing -> lift $ unauthorizedI $ MsgUnauthorized + guardMExceptT (isJust adrights) (unauthorizedI $ MsgUnauthorized) + return Authorized + 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 @@ -227,7 +241,7 @@ knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseShorthand E.==. E.val csh return (E.countRows :: E.SqlExpr (E.Value Int64)) - guardMExceptT (unauthorizedI MsgUnauthorizedLecturer) (c > 0) + guardMExceptT (c>0) (unauthorizedI MsgUnauthorizedLecturer) return Authorized _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId @@ -245,7 +259,7 @@ knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId resMap :: Map CourseId (Set SheetId) resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ] case route of - CSheetR _ _ _ (SubmissionR (ExistingSubmission cID)) -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do + CSheetR _ _ _ (SubmissionR cID) -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID Submission{..} <- MaybeT . lift $ get sid guard $ maybe False (== authId) submissionRatingBy @@ -260,21 +274,32 @@ knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId guard $ cid `Set.member` Map.keysSet resMap return Authorized _ -> do - guardMExceptT (unauthorizedI MsgUnauthorizedCorrectorAny) . not $ Map.null resMap + guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny) 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 - case subRoute of - SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom - SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom - SubmissionR NewSubmission -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo - _ -> guard $ maybe False (<= cTime) sheetVisibleFrom - 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 ) @@ -287,7 +312,7 @@ knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseShorthand E.==. E.val csh return (E.countRows :: E.SqlExpr (E.Value Int64)) - guardMExceptT (unauthorizedI MsgUnauthorizedParticipant) (c > 0) + guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant) return Authorized r -> do $logErrorS "AccessControl" $ "'!registered' used on route that doesn't support it: " <> tshow r @@ -303,16 +328,27 @@ knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId unauthorizedI MsgUnauthorized ) ,("owner", APDB $ \case - CSheetR _ _ _ (SubmissionR (ExistingSubmission cID)) -> exceptT return return $ do + CSheetR _ _ _ (SubmissionR cID) -> exceptT return return $ do sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid return Authorized - CSheetR _ _ _ (SubmissionR NewSubmission) -> unauthorizedI MsgUnauthorizedSubmissionOwner + CSheetR _ _ _ SubmissionNewR -> unauthorizedI MsgUnauthorizedSubmissionOwner r -> do $logErrorS "AccessControl" $ "'!owner' used on route that doesn't support it: " <> tshow r unauthorizedI MsgUnauthorized ) + ,("isRead", APHandler $ \route -> + bool <$> return Authorized + <*> unauthorizedI MsgUnauthorizedWrite + <*> isWriteRequest route + ) + ,("isWrite", APHandler $ \route -> do + write <- isWriteRequest route + if write + then return Authorized + else unauthorizedI MsgUnauthorized + ) ] @@ -341,9 +377,6 @@ evalAccess r = case route2ap r of (APHandler p) -> p r (APDB p) -> runDB $ p r --- TODO: isAuthorized = evalAccess' - - -- Please see the documentation for the Yesod typeclass. There are a number @@ -370,9 +403,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 @@ -392,52 +425,67 @@ instance Yesod UniWorX where [ Desc CourseFavouriteTime , OffsetBy $ userMaxFavourites user ] - lift $ mapM delete oldFavs + lift $ mapM_ delete oldFavs _other -> return () - return res + defaultYesodMiddleware handler -- handler is executed afterwards, so Favourites are updated immediately defaultLayout widget = do master <- getYesod mmsgs <- getMessages + messageRender <- getMessageRender -- needed, since there is no i18n interpolation in Julius mcurrentRoute <- getCurrentRoute -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance. (title, parents) <- breadcrumbs +-- let isParent :: Route UniWorX -> Bool +-- isParent r = r == (fst parents) + + let menu = defaultLinks ++ maybe [] pageActions mcurrentRoute menuTypes <- filterM (menuItemAccessCallback . menuItem) menu - -- Lookup Favourites if possible - favourites' <- do - muid <- maybeAuthId + -- Lookup Favourites & Theme if possible -- TODO: cache this info in a cookie?! + (favourites',show -> currentTheme) <- do + muid <- maybeAuthPair case muid of - Nothing -> return [] - (Just uid) -> runDB . E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do - E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse) - E.where_ (courseFavourite E.^. CourseFavouriteUser E.==. E.val uid) - E.orderBy [ E.asc $ course E.^. CourseShorthand ] - return course - + Nothing -> return ([],Default) + (Just (uid,user)) -> do + favs <- runDB $ E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do + E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse) + E.where_ (courseFavourite E.^. CourseFavouriteUser E.==. E.val uid) + E.orderBy [ E.asc $ course E.^. CourseShorthand ] + return course + return (favs, userTheme user) favourites <- forM favourites' $ \(Entity _ c@Course{..}) -> let courseRoute = CourseR courseTerm courseShorthand CShowR in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute) + let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority + highlight = let crumbs = mcons mcurrentRoute $ fst <$> parents + actFav = List.intersect (snd3 <$> favourites) crumbs + highRs = if null actFav then crumbs else actFav + in \r -> r `elem` highRs + -- We break up the default layout into two components: -- default-layout is the contents of the body tag, and -- default-layout-wrapper is the entire page. Since the final -- value passed to hamletToRepHtml cannot be a widget, this allows -- you to use normal widget features in default-layout. + let navbar :: Widget navbar = $(widgetFile "widgets/navbar") asidenav :: Widget asidenav = $(widgetFile "widgets/asidenav") + contentHeadline :: Maybe Widget + contentHeadline = pageHeading =<< mcurrentRoute breadcrumbs :: Widget breadcrumbs = $(widgetFile "widgets/breadcrumbs") pageactionprime :: Widget @@ -450,21 +498,28 @@ instance Yesod UniWorX where hasPageActions = any isPageActionPrime menuTypes pc <- widgetToPageContent $ do - addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900" + addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900|Roboto:300,400,600" addScript $ StaticR js_zepto_js addScript $ StaticR js_fetchPolyfill_js addScript $ StaticR js_urlPolyfill_js addScript $ StaticR js_featureChecker_js + addScript $ StaticR js_flatpickr_js addScript $ StaticR js_tabber_js + addStylesheet $ StaticR css_flatpickr_css addStylesheet $ StaticR css_tabber_css addStylesheet $ StaticR css_fonts_css addStylesheet $ StaticR css_icons_css + addStylesheet $ StaticR css_fontawesome_css $(widgetFile "default-layout") $(widgetFile "standalone/modal") $(widgetFile "standalone/showHide") $(widgetFile "standalone/inputs") + $(widgetFile "standalone/tooltip") + $(widgetFile "standalone/tabber") + $(widgetFile "standalone/alerts") + $(widgetFile "standalone/datepicker") withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") - + -- The page to be redirected to when authentication is required. authRoute _ = Just $ AuthR LoginR @@ -510,97 +565,6 @@ instance Yesod UniWorX where makeLogger = return . appLogger -{- ALL DEPRECATED and will be deleted, once knownTags is completed - -isAuthorizedDB :: Route UniWorX -> Bool -> YesodDB UniWorX AuthResult -isAuthorizedDB route@(routeAttrs -> attrs) writeable - | "adminAny" `member` attrs = adminAccess Nothing - | "lecturerAny" `member` attrs = lecturerAccess Nothing - -isAuthorizedDB UsersR _ = adminAccess Nothing -isAuthorizedDB (SubmissionDemoR cID) _ = return Authorized -- submissionAccess $ Right cID -isAuthorizedDB (SubmissionDownloadSingleR cID _) _ = submissionAccess $ Right cID -isAuthorizedDB (SubmissionDownloadArchiveR (ZIPArchiveName cID)) _ = submissionAccess $ Left cID -isAuthorizedDB TermEditR _ = adminAccess Nothing -isAuthorizedDB (TermEditExistR _) _ = adminAccess Nothing -isAuthorizedDB CourseNewR _ = lecturerAccess Nothing -isAuthorizedDB (CourseR t c CEditR) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) -isAuthorizedDB (CourseR t c (SheetR SheetListR)) False = return Authorized -- -isAuthorizedDB (CourseR t c (SheetR SheetListR)) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) -isAuthorizedDB (CourseR t c (SheetR (SShowR s))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor -isAuthorizedDB (CourseR t c (SheetR (SheetFileR s _ _))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor -isAuthorizedDB (CourseR t c (SheetR SheetNewR)) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) -isAuthorizedDB (CourseR t c (SheetR (SEditR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) -isAuthorizedDB (CourseR t c (SheetR (SDelR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) -isAuthorizedDB (CourseR t c (SheetR (SubmissionR s m))) _ = return Authorized -- TODO -- submissionAccess $ Right cID -isAuthorizedDB (CourseR t c (SheetR (SheetCorrectorsR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) -isAuthorizedDB (CourseEditIDR cID) _ = do - courseId <- decrypt cID - courseLecturerAccess courseId -isAuthorizedDB _route _isWrite = return $ Unauthorized "No access to this route." -- Calling isAuthorized here creates infinite loop! - -submissionAccess :: Either CryptoFileNameSubmission CryptoUUIDSubmission -> YesodDB UniWorX AuthResult -submissionAccess cID = do - authId <- lift requireAuthId - submissionId <- either decrypt decrypt cID - Submission{..} <- get404 submissionId - submissionUsers <- map (submissionUserUser . entityVal) <$> selectList [SubmissionUserSubmission ==. submissionId] [] - let auth = authId `elem` submissionUsers || Just authId == submissionRatingBy - return $ case auth of - True -> Authorized - False -> Unauthorized "No access to this submission" - -adminAccess :: Maybe SchoolId -- ^ If @Just@, matched exactly against 'userAdminSchool' - -> YesodDB UniWorX AuthResult -adminAccess school = do - authId <- lift requireAuthId - adrights <- selectList ((UserAdminUser ==. authId) : maybe [] (\s -> [UserAdminSchool ==. s]) school) [] - return $ if (not $ null adrights) - then Authorized - else Unauthorized "No admin access" -- TODO internationalize - -lecturerAccess :: Maybe SchoolId - -> YesodDB UniWorX AuthResult -lecturerAccess school = do - authId <- lift requireAuthId - lecrights <- selectList ((UserLecturerUser ==. authId) : maybe [] (\s -> [UserLecturerSchool ==. s]) school) [] - return $ if (not $ null lecrights) - then Authorized - else Unauthorized "No lecturer access" -- TODO internationalize - -lecturerAccess' :: SchoolId -> YesodDB UniWorX AuthResult -lecturerAccess' = authorizedFor UniqueSchoolLecturer MsgUnauthorizedSchoolLecturer - -courseLecturerAccess :: CourseId -> YesodDB UniWorX AuthResult -courseLecturerAccess = authorizedFor UniqueLecturer MsgUnauthorizedLecturer - ---courseCorrectorAccess :: CourseId -> YesodDB UniWorX AuthResult ---courseCorrectorAccess = authorizedFor UniqueCorrector MsgUnauthorizedCorrector --- TODO: Correctors are no longer unit, could be ByTutorial and also by ByProportion - -courseParticipantAccess :: CourseId -> YesodDB UniWorX AuthResult -courseParticipantAccess = authorizedFor UniqueParticipant MsgUnauthorizedParticipant - -authorizedFor :: ( PersistEntityBackend record ~ BaseBackend backend - , PersistEntity record, PersistUniqueRead backend - , YesodAuth master, RenderMessage master msg - ) - => (AuthId master -> t -> Unique record) -> msg -> t -> ReaderT backend (HandlerT master IO) AuthResult -authorizedFor authType msg courseId = do - authId <- lift requireAuthId - access <- getBy $ authType authId courseId - case access of - (Just _) -> return Authorized - Nothing -> unauthorizedI msg - -isAuthorizedDB' :: Route UniWorX -> Bool -> YesodDB UniWorX Bool -isAuthorizedDB' route isWrite = (== Authorized) <$> isAuthorizedDB route isWrite - -isAuthorized' :: Route UniWorX -> Bool -> Handler Bool -isAuthorized' route isWrite = runDB $ isAuthorizedDB' route isWrite --} - - -- Define breadcrumbs. instance YesodBreadcrumbs UniWorX where breadcrumb TermShowR = return ("Semester", Just HomeR) @@ -611,7 +575,7 @@ 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) @@ -624,29 +588,46 @@ instance YesodBreadcrumbs UniWorX where 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 - { menuItemLabel = "Neues Übungsblatt" + { menuItemLabel = "Neues Übungsblatt anlegen" , menuItemIcon = Nothing , menuItemRoute = CourseR tid csh SheetNewR , menuItemAccessCallback' = return True @@ -654,10 +635,16 @@ pageActions (CourseR tid csh SheetListR) = ] pageActions (CSheetR tid csh shn SShowR) = [ PageActionPrime $ MenuItem - { menuItemLabel = "Abgabe" + { menuItemLabel = "Abgabe anlegen" , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid csh shn (SubmissionR NewSubmission) - , menuItemAccessCallback' = return True + , menuItemRoute = CSheetR tid csh shn SubmissionNewR + , menuItemAccessCallback' = return True -- TODO: check that no submission already exists + } + , PageActionPrime $ MenuItem + { 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" @@ -668,7 +655,7 @@ pageActions (CSheetR tid csh shn SShowR) = ] pageActions TermShowR = [ PageActionPrime $ MenuItem - { menuItemLabel = "Neues Semester" + { menuItemLabel = "Neues Semester anlegen" , menuItemIcon = Nothing , menuItemRoute = TermEditR , menuItemAccessCallback' = return True @@ -676,15 +663,67 @@ pageActions TermShowR = ] pageActions (TermCourseListR _) = [ PageActionPrime $ MenuItem - { menuItemLabel = "Neuer Kurs" + { menuItemLabel = "Neuen Kurs anlegen" , menuItemIcon = Just "book" , menuItemRoute = CourseNewR , menuItemAccessCallback' = return True } ] +pageActions (ProfileR) = + [ PageActionPrime $ MenuItem + { menuItemLabel = "Gespeicherte Daten anzeigen" + , menuItemIcon = Just "book" + , menuItemRoute = ProfileDataR + , menuItemAccessCallback' = return True + } + ] +pageActions (HomeR) = + [ +-- NavbarAside $ MenuItem +-- { menuItemLabel = "Benutzer" +-- , menuItemIcon = Just "users" +-- , menuItemRoute = UsersR +-- , menuItemAccessCallback' = return True +-- } +-- , + NavbarAside $ MenuItem + { menuItemLabel = "AdminDemo" + , menuItemIcon = Nothing + , menuItemRoute = AdminTestR + , menuItemAccessCallback' = return True + } + ] pageActions _ = [] +i18nHeading :: (MonadWidget m, RenderMessage site msg, HandlerSite m ~ site) => msg -> m () +i18nHeading msg = liftWidgetT $ toWidget =<< getMessageRender <*> pure msg + +pageHeading :: Route UniWorX -> Maybe Widget +pageHeading HomeR + = Just $ i18nHeading MsgHomeHeading +pageHeading (AdminTestR) + = Just $ [whamlet|Internal Code Demonstration Page|] +pageHeading ProfileR + = Just $ i18nHeading MsgProfileHeading +pageHeading ProfileDataR + = Just $ i18nHeading MsgProfileDataHeading +pageHeading TermShowR + = Just $ i18nHeading MsgTermsHeading +pageHeading TermEditR + = Just $ i18nHeading MsgTermEditHeading +pageHeading (TermCourseListR tid) + = Just . i18nHeading . MsgTermCourseListHeading $ unTermKey tid +pageHeading CourseNewR + = Just $ i18nHeading MsgCourseEditHeading +pageHeading (CourseR tid csh CShowR) + = Just $ do + Entity _ Course{..} <- handlerToWidget . runDB . getBy404 $ CourseTermShort tid csh + toWidget courseName +-- TODO: add headings for more single course- and single term-pages +pageHeading _ + = Nothing + defaultLinks :: [MenuTypes] defaultLinks = -- Define the menu items of the header. [ NavbarRight $ MenuItem @@ -712,26 +751,20 @@ defaultLinks = -- Define the menu items of the header. , menuItemAccessCallback' = isJust <$> maybeAuthPair } , NavbarAside $ MenuItem - { menuItemLabel = "Aktuelle Veranstaltungen" - , menuItemIcon = Just "book" + { menuItemLabel = "Kurse" + , menuItemIcon = Just "calendar-alt" , menuItemRoute = CourseListR -- should be CourseListActiveR or similar in the future , menuItemAccessCallback' = return True } , NavbarAside $ MenuItem - { menuItemLabel = "Alte Veranstaltungen" - , menuItemIcon = Just "book" - , menuItemRoute = CourseListR -- should be CourseListInactiveR or similar in the future - , menuItemAccessCallback' = return True - } - , NavbarAside $ MenuItem - { menuItemLabel = "Veranstaltungen" - , menuItemIcon = Just "book" - , menuItemRoute = CourseListR + { menuItemLabel = "Semester" + , menuItemIcon = Just "graduation-cap" + , menuItemRoute = TermShowR , menuItemAccessCallback' = return True } , NavbarAside $ MenuItem { menuItemLabel = "Benutzer" - , menuItemIcon = Just "user" + , menuItemIcon = Just "users" , menuItemRoute = UsersR , menuItemAccessCallback' = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False } @@ -779,6 +812,7 @@ instance YesodAuth UniWorX where let userMaxFavourites = 12 -- TODO: appDefaultFavourites appSettings + userTheme = Default -- TODO: appDefaultFavourites appSettings newUser = User{..} userUpdate = [ UserMatrikelnummer =. userMatrikelnummer , UserDisplayName =. userDisplayName diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs new file mode 100644 index 000000000..1fc340912 --- /dev/null +++ b/src/Handler/Admin.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +module Handler.Admin where + +import Import +import Handler.Utils + +-- import Data.Time +-- import qualified Data.Text as T +-- import Data.Function ((&)) +-- import Yesod.Form.Bootstrap3 + +import Web.PathPieces (showToPathPiece, readFromPathPiece) + +-- import Colonnade hiding (fromMaybe) +-- import Yesod.Colonnade + +-- import qualified Data.UUID.Cryptographic as UUID + +-- BEGIN - Buttons needed only here +data CreateButton = CreateMath | CreateInf -- Dummy for Example + deriving (Enum, Eq, Ord, Bounded, Read, Show) + +instance PathPiece CreateButton where -- for displaying the button only, not really for paths + toPathPiece = showToPathPiece + fromPathPiece = readFromPathPiece + +instance Button CreateButton where + label CreateMath = [whamlet|Mathematik|] + label CreateInf = "Informatik" + + cssClass CreateMath = BCInfo + cssClass CreateInf = BCPrimary +-- END Button needed here + + +getAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden! +getAdminTestR = do + (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form CreateButton) + defaultLayout $ do + -- setTitle "UniWorkY Admin Testpage" + $(widgetFile "adminTest") + +postAdminTestR :: Handler Html +postAdminTestR = do + ((btnResult,_), _) <- runFormPost $ buttonForm + case btnResult of + (FormSuccess CreateInf) -> setMessage "Informatik-Knopf gedrückt" + (FormSuccess CreateMath) -> addMessage "warning" "Knopf Mathematik erkannt" + _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 555104172..a8728f2c9 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -1,6 +1,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -15,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 @@ -26,6 +27,13 @@ import qualified Data.UUID.Cryptographic as UUID getCourseListR :: Handler TypedContent getCourseListR = redirect TermShowR +getTermCurrentR :: Handler Html +getTermCurrentR = do + termIds <- runDB $ selectKeysList [TermActive ==. True] [] -- [Desc TermName] does not work, since database representation has wrong ordering + case fromNullable termIds of + Nothing -> notFound + (Just (maximum -> tid)) -> getTermCourseListR tid + getTermCourseListR :: TermId -> Handler Html getTermCourseListR tidini = do (term,courses) <- runDB $ (,) @@ -65,13 +73,13 @@ getTermCourseListR tidini = do ] let coursesTable = encodeWidgetTable tableSortable colonnadeTerms courses defaultLayout $ do - setTitle "Semesterkurse" + setTitleI . MsgTermCourseListTitle $ unTermKey tidini $(widgetFile "courses") 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 @@ -83,60 +91,63 @@ 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 -- TODO: Defaults für Semester hier ermitteln und übergeben - courseEditHandler Nothing + courseEditHandler True Nothing postCourseNewR :: Handler Html -postCourseNewR = courseEditHandler Nothing +postCourseNewR = courseEditHandler False Nothing getCEditR :: TermId -> Text -> Handler Html getCEditR tid csh = do course <- runDB $ getBy $ CourseTermShort tid csh - courseEditHandler course + courseEditHandler True course postCEditR :: TermId -> Text -> Handler Html -postCEditR = getCEditR - -getCourseEditIDR :: CryptoUUIDCourse -> Handler Html -getCourseEditIDR cID = do - cIDKey <- getsYesod appCryptoIDKey - courseID <- UUID.decrypt cIDKey cID - courseEditHandler =<< runDB (getEntity courseID) +postCEditR tid csh = do + course <- runDB $ getBy $ CourseTermShort tid csh + courseEditHandler False course courseDeleteHandler :: Handler Html -- not called anywhere yet @@ -150,8 +161,8 @@ courseDeleteHandler = undefined redirect $ TermCourseListR $ cfTerm res -} -courseEditHandler :: Maybe (Entity Course) -> Handler Html -courseEditHandler course = do +courseEditHandler :: Bool -> Maybe (Entity Course) -> Handler Html +courseEditHandler isGet course = do aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!! ((result, formWidget), formEnctype) <- runFormPost $ newCourseForm $ courseToForm <$> course case result of @@ -170,11 +181,10 @@ courseEditHandler 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 @@ -226,27 +236,26 @@ courseEditHandler 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 } ) insert_ $ CourseEdit aid now cid -- if (isNothing updOkay) -- then do - addMessageI "info" $ MsgCourseEditOk tident csh + addMessageI "success" $ MsgCourseEditOk tident csh -- redirect $ TermCourseListR tid -- else addMessageI "danger" $ MsgCourseEditDupShort tident csh (FormFailure _) -> addMessageI "warning" MsgInvalidInput + (FormMissing) | isGet -> return () other -> addMessage "error" $ [shamlet| Error: #{show other}|] - let formTitle = "Kurs editieren/anlegen" :: Text actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute defaultLayout $ do - setTitle [shamlet| #{formTitle} |] + setTitleI MsgCourseEditTitle $(widgetFile "formPage") @@ -259,7 +268,7 @@ data CourseForm = CourseForm , cfTerm :: TermId , cfSchool :: SchoolId , cfCapacity :: Maybe Int - , cfHasReg :: Bool + , cfSecret :: Maybe Text , cfRegFrom :: Maybe UTCTime , cfRegTo :: Maybe UTCTime } @@ -278,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 } @@ -305,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 @@ -316,10 +331,11 @@ newCourseForm template = identForm FIDcourse $ \html -> do (FormFailure errorMsgs, [whamlet|
-

Fehler: -