diff --git a/ghci.sh b/ghci.sh index 825a936f0..76b9b6e9b 100755 --- a/ghci.sh +++ b/ghci.sh @@ -7,11 +7,11 @@ export DUMMY_LOGIN=true move-back() { mv -v .stack-work .stack-work-ghci - [[ -d .stack-work-run ]] && mv -v .stack-work-run .stack-work + [[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work } if [[ -d .stack-work-ghci ]]; then - [[ -d .stack-work ]] && mv -v .stack-work .stack-work-run + [[ -d .stack-work ]] && mv -v .stack-work .stack-work-build mv -v .stack-work-ghci .stack-work trap move-back EXIT fi diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 5c7b3cfe6..85936833b 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -146,6 +146,7 @@ CorrectorsHead sheetName@SheetName: Korrektoren für #{sheetName} Unauthorized: Sie haben hierfür keine explizite Berechtigung. UnauthorizedAnd l@Text r@Text: (#{l} UND #{r}) UnauthorizedOr l@Text r@Text: (#{l} ODER #{r}) +UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator. 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. @@ -167,7 +168,9 @@ MaterialFree: Kursmaterialien ohne Anmeldung zugänglich UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung UnauthorizedSystemMessageTime: Diese Systemnachricht ist noch nicht oder nicht mehr einsehbar. UnauthorizedSystemMessageAuth: Diese Systemnachricht ist nur für angemeldete Benutzer einsehbar. -UnsupportedAuthPredicate tag@String shownRoute@String: "!#{tag}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute} +UnsupportedAuthPredicate tag@String shownRoute@String: "#{tag}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute} +UnauthorizedDisabledTag authTag@AuthTag: Authorisierungsprädikat "#{toPathPiece authTag}" ist für Ihre Sitzung nicht aktiv +UnknownAuthPredicate tag@String: Authorisierungsprädikat "#{tag}" ist dem System nicht bekannt EMail: E-Mail EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer. @@ -299,6 +302,8 @@ DownloadFiles: Dateien automatisch herunterladen DownloadFilesTip: Wenn gesetzt werden Dateien von Abgaben und Übungsblättern automatisch als Download behandelt, ansonsten ist das Verhalten browserabhängig (es können z.B. PDFs im Browser geöffnet werden). NotificationSettings: Erwünschte Benachrichtigungen +ActiveAuthTags: Aktivierte Authorisierungsprädikate + InvalidDateTimeFormat: Ungültiges Datums- und Zeitformat, JJJJ-MM-TTTHH:MM[:SS] Format erwartet AmbiguousUTCTime: Der angegebene Zeitpunkt lässt sich nicht eindeutig zu UTC konvertieren IllDefinedUTCTime: Der angegebene Zeitpunkt lässt sich nicht zu UTC konvertieren @@ -516,3 +521,23 @@ MenuSheetEdit: Übungsblatt editieren MenuCorrectionsUpload: Korrekturen hochladen MenuCorrectionsCreate: Abgaben registrieren MenuCorrectionsGrade: Abgaben bewerten + +AuthPredsActive: Aktive Authorisierungsprädikate +AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert +AuthTagFree: Seite ist generell zugänglich +AuthTagAdmin: Nutzer ist Administrator +AuthTagDeprecated: Seite ist nicht überholt +AuthTagDevelopment: Seite ist nicht in Entwicklung +AuthTagLecturer: Nutzer ist Dozent +AuthTagCorrector: Nutzer ist Korrektor +AuthTagTime: Zeitliche Einschränkungen sind erfüllt +AuthTagRegistered: Nutzer ist Kursteilnehmer +AuthTagCapacity: Kapazität ist ausreichend +AuthTagMaterials: Kursmaterialien sind freigegeben +AuthTagOwner: Nutzer ist Besitzer +AuthTagRated: Korrektur ist bewertet +AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer +AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren +AuthTagAuthentication: Authentifizierung erfüllt Anforderungen +AuthTagIsRead: Zugriff ist nur lesend +AuthTagIsWrite: Zugriff ist i.A. schreibend \ No newline at end of file diff --git a/package.yaml b/package.yaml index c9fdbb55a..20a50b6c5 100644 --- a/package.yaml +++ b/package.yaml @@ -107,6 +107,7 @@ dependencies: - word24 - mmorph - clientsession + - monad-memo other-extensions: - GeneralizedNewtypeDeriving diff --git a/routes b/routes index 399f3bf72..06768ea3e 100644 --- a/routes +++ b/routes @@ -40,8 +40,10 @@ /info VersionR GET !free /help HelpR GET POST !free -/profile ProfileR GET POST !free !free -/profile/data ProfileDataR GET POST !free !free +/profile ProfileR GET POST !free +/profile/data ProfileDataR GET POST !free + +/authpreds AuthPredsR GET POST !free /term TermShowR GET !free /term/current TermCurrentR GET !free diff --git a/src/Foundation.hs b/src/Foundation.hs index a2d0f20ac..431c51717 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -40,7 +40,6 @@ import qualified Data.ByteString.Lazy as Lazy.ByteString import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -import Data.List (foldr1) import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map, (!?)) @@ -58,12 +57,14 @@ import qualified Database.Esqueleto as E import Control.Monad.Except (MonadError(..), runExceptT) import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.Reader (runReader, mapReaderT) -import Control.Monad.Trans.Writer (WriterT(..)) +import Control.Monad.Trans.Writer (WriterT(..), runWriterT) import Control.Monad.Writer.Class (MonadWriter(..)) +import Control.Monad.Memo (MemoT, startEvalMemoT, MonadMemo(..)) import qualified Control.Monad.Catch as C import Handler.Utils.StudyFeatures -import Control.Lens +import Handler.Utils.Templates +import Utils.Lens import Utils.Form import Utils.SystemMessage @@ -200,6 +201,7 @@ embedRenderMessage ''UniWorX ''SheetFileType id embedRenderMessage ''UniWorX ''CorrectorState id embedRenderMessage ''UniWorX ''RatingException id embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>) +embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel newtype SheetTypeHeader = SheetTypeHeader SheetType embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>) @@ -300,264 +302,298 @@ data AccessPredicate | APHandler (Route UniWorX -> Bool -> Handler AuthResult) | APDB (Route UniWorX -> Bool -> DB AuthResult) -orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult +class (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where + evalAccessPred :: AccessPredicate -> Route UniWorX -> Bool -> m AuthResult + +instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where + evalAccessPred aPred r w = liftHandlerT $ case aPred of + (APPure p) -> runReader (p r w) <$> getMsgRenderer + (APHandler p) -> p r w + (APDB p) -> runDB $ p r w + +instance (MonadHandler m, HandlerSite m ~ UniWorX, backend ~ YesodPersistBackend UniWorX) => MonadAP (ReaderT backend m) where + evalAccessPred aPred r w = mapReaderT liftHandlerT $ case aPred of + (APPure p) -> lift $ runReader (p r w) <$> getMsgRenderer + (APHandler p) -> lift $ p r w + (APDB p) -> p r w + + +orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult orAR _ Authorized _ = Authorized orAR _ _ Authorized = Authorized orAR _ AuthenticationRequired _ = AuthenticationRequired orAR _ _ AuthenticationRequired = AuthenticationRequired -orAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedOr x y +orAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedOr x y -- and -andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y +andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y andAR _ reason@(Unauthorized _) _ = reason andAR _ _ reason@(Unauthorized _) = reason andAR _ Authorized other = other andAR _ AuthenticationRequired _ = AuthenticationRequired -orAP,andAP :: AccessPredicate -> AccessPredicate -> AccessPredicate -orAP = liftAR orAR (== Authorized) -andAP = liftAR andAR (const False) +trueAR, falseAR :: MsgRendererS UniWorX -> AuthResult +trueAR = const Authorized +falseAR = Unauthorized . ($ MsgUnauthorized) . render -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 ops sc (APPure f) (APPure g) = APPure $ \r w -> shortCircuitM sc (f r w) (g r w) . ops =<< ask -liftAR ops sc (APHandler f) (APHandler g) = APHandler $ \r w -> shortCircuitM sc (f r w) (g r w) . ops =<< getMsgRenderer -liftAR ops sc (APDB f) (APDB g) = APDB $ \r w -> shortCircuitM sc (f r w) (g r w) . ops =<< getMsgRenderer -liftAR ops sc (APPure f) apg = liftAR ops sc (APHandler $ \r w -> runReader (f r w) <$> getMsgRenderer) apg -liftAR ops sc apf apg@(APPure _) = liftAR ops sc apg apf -liftAR ops sc (APHandler f) apdb = liftAR ops sc (APDB $ \r w -> lift $ f r w) apdb -liftAR ops sc apdb apg@(APHandler _) = liftAR ops sc apg apdb +trueAP, falseAP :: AccessPredicate +trueAP = APPure . const . const $ trueAR <$> ask +falseAP = APPure . const . const $ falseAR <$> ask -- included for completeness -trueAP,falseAP :: AccessPredicate -trueAP = APPure . const . const $ return Authorized -falseAP = APPure . const . const $ Unauthorized . ($ MsgUnauthorized) . render <$> ask -- always use adminAP instead - - -adminAP :: AccessPredicate -- access for admins (of appropriate school in case of course-routes) -adminAP = APDB $ \route _ -> case route of - -- Courses: access only to school admins - CourseR tid ssh csh _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId - [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do - E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool - E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - return (E.countRows :: E.SqlExpr (E.Value Int64)) - 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] [] - guardMExceptT (isJust adrights) (unauthorizedI $ MsgUnauthorized) - return Authorized - - -knownTags :: Map (CI Text) AccessPredicate -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 - allow <- appAllowDeprecated . appSettings <$> getYesod - return $ bool (Unauthorized "Deprecated Route") Authorized allow - ) - ,("development", APHandler $ \r _ -> do - $logWarnS "AccessControl" ("route in development: " <> tshow r) +tagAccessPredicate :: AuthTag -> AccessPredicate +tagAccessPredicate AuthFree = trueAP +tagAccessPredicate AuthAdmin = APDB $ \route _ -> case route of + -- Courses: access only to school admins + CourseR tid ssh csh _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId + [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do + E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool + E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + return (E.countRows :: E.SqlExpr (E.Value Int64)) + 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] [] + guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin) + return Authorized +tagAccessPredicate AuthDeprecated = APHandler $ \r _ -> do + $logWarnS "AccessControl" ("deprecated route: " <> tshow r) + addMessageI Error MsgDeprecatedRoute + allow <- appAllowDeprecated . appSettings <$> getYesod + return $ bool (Unauthorized "Deprecated Route") Authorized allow +tagAccessPredicate AuthDevelopment = APHandler $ \r _ -> do + $logWarnS "AccessControl" ("route in development: " <> tshow r) #ifdef DEVELOPMENT - return Authorized + return Authorized #else - return $ Unauthorized "Route under development" + return $ Unauthorized "Route under development" #endif - ) - ,("lecturer", APDB $ \route _ -> case route of - CourseR tid ssh csh _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId - [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do - E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse - E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - return (E.countRows :: E.SqlExpr (E.Value Int64)) - guardMExceptT (c>0) (unauthorizedI MsgUnauthorizedLecturer) - return Authorized - _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId - void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] [] - return Authorized - ) - ,("corrector", APDB $ \route _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId - resList <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do - E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId - E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId - E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId - return (course E.^. CourseId, sheet E.^. SheetId) - let - resMap :: Map CourseId (Set SheetId) - resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ] - case route of - CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do - sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID - Submission{..} <- MaybeT . lift $ get sid - guard $ maybe False (== authId) submissionRatingBy - return Authorized - CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do - Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh - Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn - guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid) - return Authorized - CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do - Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh - guard $ cid `Set.member` Map.keysSet resMap - return Authorized - _ -> do - guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny) - return Authorized - ) - ,("time", APDB $ \route _ -> case route of - CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do - Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn - cTime <- liftIO getCurrentTime - let - visible = NTop sheetVisibleFrom <= NTop (Just cTime) - active = sheetActiveFrom <= cTime && cTime <= sheetActiveTo +tagAccessPredicate AuthLecturer = APDB $ \route _ -> case route of + CourseR tid ssh csh _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId + [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do + E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse + E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + return (E.countRows :: E.SqlExpr (E.Value Int64)) + guardMExceptT (c>0) (unauthorizedI MsgUnauthorizedLecturer) + return Authorized + _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId + void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] [] + return Authorized +tagAccessPredicate AuthCorrector = APDB $ \route _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId + resList <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do + E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId + E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId + return (course E.^. CourseId, sheet E.^. SheetId) + let + resMap :: Map CourseId (Set SheetId) + resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ] + case route of + CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do + sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID + Submission{..} <- MaybeT . lift $ get sid + guard $ maybe False (== authId) submissionRatingBy + return Authorized + CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do + Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh + Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn + guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid) + return Authorized + CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do + Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh + guard $ cid `Set.member` Map.keysSet resMap + return Authorized + _ -> do + guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny) + return Authorized +tagAccessPredicate AuthTime = APDB $ \route _ -> case route of + CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do + Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn + cTime <- liftIO getCurrentTime + let + visible = NTop sheetVisibleFrom <= NTop (Just cTime) + active = sheetActiveFrom <= cTime && cTime <= sheetActiveTo - guard visible + guard visible - case subRoute of - SFileR SheetExercise _ -> guard $ sheetActiveFrom <= cTime - SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom - SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom - SubmissionNewR -> guard active - SubmissionR _ _ -> guard active - _ -> return () + case subRoute of + SFileR SheetExercise _ -> guard $ sheetActiveFrom <= cTime + SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom + SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom + SubmissionNewR -> guard active + SubmissionR _ _ -> guard active + _ -> return () - return Authorized + return Authorized - CourseR tid ssh csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do - Entity _ Course{courseRegisterFrom, courseRegisterTo} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - cTime <- (NTop . Just) <$> liftIO getCurrentTime - guard $ NTop courseRegisterFrom <= cTime - && NTop courseRegisterTo >= cTime - return Authorized + CourseR tid ssh csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do + Entity _ Course{courseRegisterFrom, courseRegisterTo} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + cTime <- (NTop . Just) <$> liftIO getCurrentTime + guard $ NTop courseRegisterFrom <= cTime + && NTop courseRegisterTo >= cTime + return Authorized - MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do - smId <- decrypt cID - SystemMessage{systemMessageFrom, systemMessageTo} <- MaybeT $ get smId - cTime <- (NTop . Just) <$> liftIO getCurrentTime - guard $ NTop systemMessageFrom <= cTime - && NTop systemMessageTo >= cTime - return Authorized + MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do + smId <- decrypt cID + SystemMessage{systemMessageFrom, systemMessageTo} <- MaybeT $ get smId + cTime <- (NTop . Just) <$> liftIO getCurrentTime + guard $ NTop systemMessageFrom <= cTime + && NTop systemMessageTo >= cTime + return Authorized - r -> $unsupportedAuthPredicate "time" r - ) - ,("registered", APDB $ \route _ -> case route of - CourseR tid ssh csh _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId - [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do - E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse - E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - return (E.countRows :: E.SqlExpr (E.Value Int64)) - guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant) - return Authorized - r -> $unsupportedAuthPredicate "registered" r - ) - ,("capacity", APDB $ \route _ -> case route of - CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do - Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] - guard $ NTop courseCapacity > NTop (Just registered) - return Authorized - r -> $unsupportedAuthPredicate "capacity" r - ) - ,("materials", APDB $ \route _ -> case route of - CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do - Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - guard courseMaterialFree - return Authorized - r -> $unsupportedAuthPredicate "materials" r - ) - ,("owner", APDB $ \route _ -> case route of - CSubmissionR _ _ _ _ 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 - r -> $unsupportedAuthPredicate "owner" r - ) - ,("rated", APDB $ \route _ -> case route of - CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do - sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID - sub <- MaybeT $ get sid - guard $ submissionRatingDone sub - return Authorized - r -> $unsupportedAuthPredicate "rated" r - ) - ,("user-submissions", APDB $ \route _ -> case route of - CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do - Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn - guard $ sheetSubmissionMode == UserSubmissions - return Authorized - r -> $unsupportedAuthPredicate "user-submissions" r - ) - ,("corrector-submissions", APDB $ \route _ -> case route of - CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do - Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn - guard $ sheetSubmissionMode == CorrectorSubmissions - return Authorized - r -> $unsupportedAuthPredicate "corrector-submissions" r - ) - ,("authentication", APDB $ \route _ -> case route of - MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do - smId <- decrypt cID - SystemMessage{..} <- MaybeT $ get smId - isAuthenticated <- isJust <$> liftHandlerT maybeAuthId - guard $ not systemMessageAuthenticatedOnly || isAuthenticated - return Authorized - r -> $unsupportedAuthPredicate "authentication" r - ) - ,("isRead", APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)) - ,("isWrite", APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)) - ] + r -> $unsupportedAuthPredicate "time" r +tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of + CourseR tid ssh csh _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId + [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do + E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse + E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + return (E.countRows :: E.SqlExpr (E.Value Int64)) + guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant) + return Authorized + r -> $unsupportedAuthPredicate "registered" r +tagAccessPredicate AuthCapacity = APDB $ \route _ -> case route of + CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do + Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] + guard $ NTop courseCapacity > NTop (Just registered) + return Authorized + r -> $unsupportedAuthPredicate "capacity" r +tagAccessPredicate AuthMaterials = APDB $ \route _ -> case route of + CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do + Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + guard courseMaterialFree + return Authorized + r -> $unsupportedAuthPredicate "materials" r +tagAccessPredicate AuthOwner = APDB $ \route _ -> case route of + CSubmissionR _ _ _ _ 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 + r -> $unsupportedAuthPredicate "owner" r +tagAccessPredicate AuthRated = APDB $ \route _ -> case route of + CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do + sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID + sub <- MaybeT $ get sid + guard $ submissionRatingDone sub + return Authorized + r -> $unsupportedAuthPredicate "rated" r +tagAccessPredicate AuthUserSubmissions = APDB $ \route _ -> case route of + CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do + Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn + guard $ sheetSubmissionMode == UserSubmissions + return Authorized + r -> $unsupportedAuthPredicate "user-submissions" r +tagAccessPredicate AuthCorrectorSubmissions = APDB $ \route _ -> case route of + CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do + Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn + guard $ sheetSubmissionMode == CorrectorSubmissions + return Authorized + r -> $unsupportedAuthPredicate "corrector-submissions" r +tagAccessPredicate AuthAuthentication = APDB $ \route _ -> case route of + MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do + smId <- decrypt cID + SystemMessage{..} <- MaybeT $ get smId + isAuthenticated <- isJust <$> liftHandlerT maybeAuthId + guard $ not systemMessageAuthenticatedOnly || isAuthenticated + return Authorized + r -> $unsupportedAuthPredicate "authentication" r +tagAccessPredicate AuthIsRead = APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite) +tagAccessPredicate AuthIsWrite = APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized) -tag2ap :: Text -> AccessPredicate -tag2ap t = case Map.lookup (CI.mk t) knownTags of - (Just acp) -> acp - Nothing -> APHandler $ \_route _isWrite -> do -- Can this be pure like falseAP? GK: not if we want to log a message (which we definitely should) - $logWarnS "AccessControl" $ "'" <> t <> "' not known to access control" - unauthorizedI MsgUnauthorized +newtype InvalidAuthTag = InvalidAuthTag Text + deriving (Eq, Ord, Show, Read, Generic, Typeable) +instance Exception InvalidAuthTag -route2ap :: Route UniWorX -> AccessPredicate -route2ap r = foldr orAP adminAP attrsAND -- adminAP causes all to be in DB!!! GK: Due to shortCircuitM this (while still true) is no longer costly (we do a `runDB` but then only actually send off queries, if needed) +type DNF a = Set (NonNull (Set a)) + +data SessionAuthTags = SessionActiveAuthTags | SessionInactiveAuthTags + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) +instance Universe SessionAuthTags +instance Finite SessionAuthTags +$(return []) +instance PathPiece SessionAuthTags where + toPathPiece = $(nullaryToPathPiece ''SessionAuthTags [intercalate "-" . map toLower . splitCamel]) + fromPathPiece = finiteFromPathPiece + +routeAuthTags :: Route UniWorX -> Either InvalidAuthTag (NonNull (DNF AuthTag)) +-- ^ DNF up to entailment: +-- +-- > (A_1 && A_2 && ...) OR' B OR' ... +-- +-- > A OR' B := ((A |- B) ==> A) && (A || B) +routeAuthTags = fmap (impureNonNull . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.singleton $ Set.singleton AuthAdmin) . routeAttrs where - attrsAND = map splitAND $ Set.toList $ routeAttrs r - splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND" + partition' :: Set (Set AuthTag) -> Text -> Either InvalidAuthTag (Set (Set AuthTag)) + partition' prev t + | Just (Set.fromList . toNullable -> authTags) <- fromNullable =<< mapM fromPathPiece (Text.splitOn "AND" t) + = if + | oany (authTags `Set.isSubsetOf`) prev + -> Right prev + | otherwise + -> Right $ Set.insert authTags prev + | otherwise + = Left $ InvalidAuthTag t -evalAccessDB :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise -evalAccessDB r w = mapReaderT liftHandlerT $ case route2ap r of - (APPure p) -> lift $ runReader (p r w) <$> getMsgRenderer - (APHandler p) -> lift $ p r w - (APDB p) -> p r w +evalAuthTags :: forall m. (MonadAP m, MonadLogger m) => AuthTagActive -> NonNull (DNF AuthTag) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult +-- ^ `tell`s disabled predicates, identified as pivots +evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . toNullable -> authDNF) route isWrite + = startEvalMemoT $ do + mr <- lift getMsgRenderer + let + authTagIsInactive = not . authTagIsActive + + evalAuthTag :: AuthTag -> MemoT AuthTag AuthResult (WriterT (Set AuthTag) m) AuthResult + evalAuthTag = memo $ \authTag -> lift . lift $ evalAccessPred (tagAccessPredicate authTag) route isWrite -evalAccess :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult -evalAccess r w = liftHandlerT $ case route2ap r of - (APPure p) -> runReader (p r w) <$> getMsgRenderer - (APHandler p) -> p r w - (APDB p) -> runDB $ p r w + orAR', andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult + orAR' = shortCircuitM (is _Authorized) (orAR mr) + andAR' = shortCircuitM (is _Unauthorized) (andAR mr) + evalDNF :: [[AuthTag]] -> MemoT AuthTag AuthResult (WriterT (Set AuthTag) m) AuthResult + evalDNF = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthTag aTag) (return $ trueAR mr) ats) (return $ falseAR mr) + + lift . $logDebugS "evalAuthTags" . tshow . (route, isWrite, )$ map (map $ id &&& authTagIsActive) authDNF + + result <- evalDNF $ filter (all authTagIsActive) authDNF + + unless (is _Authorized result) . forM_ (filter (any authTagIsInactive) authDNF) $ \conj -> + whenM (allM conj (\aTag -> (return . not $ authTagIsActive aTag) `or2M` (not . is _Unauthorized <$> evalAuthTag aTag))) $ do + let pivots = filter authTagIsInactive conj + whenM (allM pivots $ fmap (is _Authorized) . evalAuthTag) $ do + lift $ $logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots}|] + lift . tell $ Set.fromList pivots + + return result + +evalAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult +evalAccess route isWrite = do + tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags + dnf <- either throwM return $ routeAuthTags route + (result, (Set.toList -> deactivated)) <- runWriterT $ evalAuthTags tagActive dnf route isWrite + result <$ tellSessionJson SessionInactiveAuthTags deactivated + +evalAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult +evalAccessDB = evalAccess -- Please see the documentation for the Yesod typeclass. There are a number @@ -726,12 +762,6 @@ siteLayout headingOverride widget = do isModal <- isJust <$> siteModalId - mmsgs <- if - | isModal -> return [] - | otherwise -> do - applySystemMessages - getMessages - mcurrentRoute <- getCurrentRoute -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance. @@ -767,6 +797,14 @@ siteLayout headingOverride widget = do items' <- forM items $ \i -> (i, ) <$> toTextUrl i return (c, courseRoute, items') + mmsgs <- if + | isModal -> return [] + | otherwise -> do + applySystemMessages + authTagPivots <- fromMaybe Set.empty <$> getSessionJson SessionInactiveAuthTags + forM_ authTagPivots $ \authTag -> addMessageWidget Info $ modal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left AuthPredsR) + getMessages + let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority highlight = let crumbs = mcons mcurrentRoute $ fst <$> reverse parents navItems = map snd3 favourites ++ map (urlRoute . menuItemRoute . view _1) menuTypes @@ -777,14 +815,12 @@ siteLayout headingOverride widget = do favouriteTerm :: TermIdentifier -> [(Course, Route UniWorX, [(MenuItem, Text)])] favouriteTerm tid = filter (\(Course{..}, _, _) -> unTermKey courseTerm == tid) favourites - -- 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. + -- 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 diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index e80ff8b64..96e782067 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -295,3 +295,23 @@ postHelpR = do $(widgetFile "help") +getAuthPredsR, postAuthPredsR :: Handler Html +getAuthPredsR = postAuthPredsR +postAuthPredsR = do + AuthTagActive{..} <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags + + let taForm authTag = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagIsActive authTag) + + ((authActiveRes, authActiveWidget), authActiveEnctype) <- runFormPost . renderAForm FormStandard + $ AuthTagActive + <$> funcForm taForm (fslI MsgActiveAuthTags) True + <* submitButton + + formResult authActiveRes $ \authTagActive -> do + setSessionJson SessionActiveAuthTags authTagActive + addMessageI Success MsgAuthPredsActiveChanged + redirect AuthPredsR + + defaultLayout $ do + setTitleI MsgAuthPredsActive + $(widgetFile "authpreds") diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index fbbdff58f..4e1f7abe1 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -10,8 +10,6 @@ import Utils.Lens -- import Yesod.Colonnade import Data.Monoid (Any(..)) import qualified Data.Map as Map -import Data.Map ((!)) -import qualified Data.Set as Set -- import qualified Data.Set as Set import qualified Database.Esqueleto as E -- import Database.Esqueleto ((^.)) @@ -42,25 +40,11 @@ makeSettingForm template = identForm FIDsettings $ \html -> do <*> areq checkBoxField (fslI MsgDownloadFiles & setTooltip MsgDownloadFilesTip ) (stgDownloadFiles <$> template) - <*> formToAForm (nsFieldView =<< renderAForm FormStandard nsForm mempty) + <*> (NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True) <* submitButton return (result, widget) -- no validation required here where - nsForm = fmap (\m -> NotificationSettings $ \nt -> m ! nt) . sequenceA . flip Map.fromSet (Set.fromList universeF) $ \nt -> - areq checkBoxField (fslI nt) (flip notificationAllowed nt . stgNotificationSettings <$> template) - nsFieldView :: (FormResult NotificationSettings, Widget) -> MForm Handler (FormResult NotificationSettings, [FieldView UniWorX]) - nsFieldView (res, fvInput) = do - mr <- getMessageRender - let fvLabel = toHtml $ mr MsgNotificationSettings - fvTooltip = mempty - fvRequired = True - fvErrors - | FormFailure (err:_) <- res = Just $ toHtml err - | otherwise = Nothing - fvId <- newIdent - return (res, pure FieldView{..}) - -- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template) - + nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt . stgNotificationSettings <$> template) getProfileR, postProfileR :: Handler Html diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index e4a32bb81..ce9aeec62 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -30,8 +30,9 @@ import qualified Data.Conduit.List as C import qualified Database.Esqueleto as E import Data.Set (Set) +import qualified Data.Set as Set -import Data.Map (Map) +import Data.Map (Map, (!)) import qualified Data.Map as Map import Control.Monad.Writer.Class @@ -488,6 +489,32 @@ langField False = checkBool (all ((&&) <$> not . null <*> T.all Char.isAlpha) . langField True = selectField . optionsPairs . map (MsgLanguage &&& id) $ toList appLanguages +funcForm :: forall k v m. + ( Finite k, Ord k + , MonadHandler m + , HandlerSite m ~ UniWorX + ) + => (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v) +funcForm mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAForm $ funcFieldView =<< renderAForm FormStandard funcForm' mempty + where + funcForm' :: AForm m (k -> v) + funcForm' = fmap (\m x -> m ! x) . sequenceA . Map.fromSet mkForm $ Set.fromList universeF + funcFieldView :: (FormResult (k -> v), Widget) -> MForm m (FormResult (k -> v), [FieldView UniWorX]) + funcFieldView (res, fvInput) = do + mr <- getMessageRender + let fvLabel = toHtml $ mr fsLabel + fvTooltip = fmap (toHtml . mr) fsTooltip + fvRequired = isRequired + fvErrors + | FormFailure (err:_) <- res = Just $ toHtml err + | otherwise = Nothing + fvId <- maybe newIdent return fsId + return (res, pure FieldView{..}) + -- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template) + + + + fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -- DEPRECATED fsm = bfs -- TODO: get rid of Bootstrap diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 49255b941..94c8ffbd2 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -3,7 +3,7 @@ module Import.NoFoundation , MForm ) where -import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy) +import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM) import Model as Import import Model.Types.JSON as Import import Model.Migration as Import diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 396c26bbb..6872daf9c 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -564,6 +564,8 @@ instance ToBackendKey SqlBackend record => Hashable (Key record) where derivePersistFieldJSON ''MailLanguages +type PseudonymWord = CI Text + newtype Pseudonym = Pseudonym Word24 deriving (Eq, Ord, Read, Show, Generic, Data) deriving newtype (Bounded, Enum, Integral, Num, Real, Bits, FiniteBits, Ix) @@ -642,9 +644,68 @@ pseudonymText = iso tFromWords tToWords . pseudonymWords tToWords = Text.unwords . map CI.original --- Type synonyms +data AuthTag + = AuthFree + | AuthAdmin + | AuthDeprecated + | AuthDevelopment + | AuthLecturer + | AuthCorrector + | AuthTime + | AuthRegistered + | AuthCapacity + | AuthMaterials + | AuthOwner + | AuthRated + | AuthUserSubmissions + | AuthCorrectorSubmissions + | AuthAuthentication + | AuthIsRead + | AuthIsWrite + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) -type PseudonymWord = CI Text +instance Universe AuthTag +instance Finite AuthTag +instance Hashable AuthTag + +deriveJSON defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel + } ''AuthTag + +instance PathPiece AuthTag where + toPathPiece = $(nullaryToPathPiece ''AuthTag [Text.intercalate "-" . map toLower . drop 1 . splitCamel]) + fromPathPiece = finiteFromPathPiece + +instance ToJSONKey AuthTag where + toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t + +instance FromJSONKey AuthTag where + fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String + + +newtype AuthTagActive = AuthTagActive { authTagIsActive :: AuthTag -> Bool } + deriving (Read, Show, Generic) + deriving newtype (Eq, Ord) + +instance Default AuthTagActive where + def = AuthTagActive $ \case + AuthAdmin -> False + _ -> True + +instance ToJSON AuthTagActive where + toJSON v = toJSON . HashMap.fromList $ map (id &&& authTagIsActive v) universeF + +instance FromJSON AuthTagActive where + parseJSON = withObject "AuthTagActive" $ \o -> do + o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap AuthTag Bool) + return . AuthTagActive $ \n -> case HashMap.lookup n o' of + Nothing -> authTagIsActive def n + Just b -> b + +derivePersistFieldJSON ''AuthTagActive + + +-- Type synonyms type Email = Text diff --git a/src/Utils.hs b/src/Utils.hs index 23dc860ff..2b138f36e 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -4,10 +4,11 @@ module Utils ( module Utils ) where -import ClassyPrelude.Yesod +import ClassyPrelude.Yesod hiding (foldlM) -- import Data.Double.Conversion.Text -- faster implementation for textPercent? -import Data.Foldable as Fold hiding (length) +import qualified Data.Foldable as Fold +import Data.Foldable as Utils (foldlM, foldrM) import Data.Monoid (Sum(..)) import Data.CaseInsensitive (CI) @@ -200,7 +201,6 @@ stepTextCounter text -- Data.Text.groupBy ((==) `on` isDigit) $ Data.Text.pack "12.ProMo Ue3bung00322 34 (H)" -- ["12",".ProMo Ue","3","bung","00322"," ","34"," (H)"] - ------------ -- Tuples -- ------------ @@ -395,12 +395,12 @@ catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err) -- Monads -- ------------ -shortCircuitM :: Monad m => (a -> Bool) -> m a -> m a -> (a -> a -> a) -> m a -shortCircuitM sc mx my bop = do +shortCircuitM :: Monad m => (a -> Bool) -> (a -> a -> a) -> m a -> m a -> m a +shortCircuitM sc binOp mx my = do x <- mx if | sc x -> return x - | otherwise -> bop <$> pure x <*> my + | otherwise -> binOp <$> pure x <*> my guardM :: MonadPlus m => m Bool -> m () @@ -423,26 +423,24 @@ ifM c m m' = ifNotM :: Monad m => m Bool -> m a -> m a -> m a ifNotM c = flip $ ifM c --- | Lazy monadic conjunction. -and2M :: Monad m => m Bool -> m Bool -> m Bool +and2M, or2M :: Monad m => m Bool -> m Bool -> m Bool and2M ma mb = ifM ma mb (return False) - -andM :: (Foldable f, Monad m) => f (m Bool) -> m Bool -andM = Fold.foldr and2M (return True) - -allM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool -allM xs f = andM $ fmap f xs - --- | Lazy monadic disjunction. -or2M :: Monad m => m Bool -> m Bool -> m Bool or2M ma = ifM ma (return True) -orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool +andM, orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool +andM = Fold.foldr and2M (return True) orM = Fold.foldr or2M (return False) -anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool +allM, anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool +allM xs f = andM $ fmap f xs anyM xs f = orM $ fmap f xs +ofoldr1M, ofoldl1M :: (MonoFoldable mono, Monad m) => (Element mono -> Element mono -> m (Element mono)) -> NonNull mono -> m (Element mono) +ofoldr1M f (otoList -> x:xs) = foldrM f x xs +ofoldr1M _ _ = error "otoList of NonNull is empty" +ofoldl1M f (otoList -> x:xs) = foldlM f x xs +ofoldl1M _ _ = error "otoList of NonNull is empty" + -------------- -- Sessions -- -------------- @@ -452,3 +450,13 @@ setSessionJson (toPathPiece -> key) (LBS.toStrict . Aeson.encode -> val) = setSe lookupSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v) lookupSessionJson (toPathPiece -> key) = (Aeson.decode' . LBS.fromStrict =<<) <$> lookupSessionBS key + +modifySessionJson :: (PathPiece k, FromJSON v, ToJSON v, MonadHandler m) => k -> (Maybe v -> Maybe v) -> m () +modifySessionJson (toPathPiece -> key) f = lookupSessionJson key >>= maybe (deleteSession key) (setSessionJson key) . f + +tellSessionJson :: (PathPiece k, FromJSON v, ToJSON v, MonadHandler m, Monoid v) => k -> v -> m () +tellSessionJson key val = modifySessionJson key $ Just . (`mappend` val) . fromMaybe mempty + +getSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v) +-- ^ `lookupSessionJson` followed by `deleteSession` +getSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key) diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 46a2a5344..7d7df4350 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -2,6 +2,7 @@ module Utils.Lens ( module Utils.Lens ) where import Import.NoFoundation import Control.Lens as Utils.Lens +import Control.Lens.Extras as Utils.Lens (is) import Utils.Lens.TH as Utils.Lens (makeLenses_) import qualified Database.Esqueleto as E (Value(..),InnerJoin(..)) @@ -28,6 +29,8 @@ makeLenses_ ''SheetGrading makeLenses_ ''SheetType +makePrisms ''AuthResult + -- makeClassy_ ''Load diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index 62e337328..62226de75 100644 --- a/src/Utils/Message.hs +++ b/src/Utils/Message.hs @@ -1,6 +1,6 @@ module Utils.Message ( MessageClass(..) - , addMessage, addMessageI, addMessageIHamlet, addMessageFile + , addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget ) where @@ -53,3 +53,13 @@ addMessageIHamlet mc iHamlet = do addMessageFile :: MessageClass -> FilePath -> ExpQ addMessageFile mc tPath = [e|addMessageIHamlet mc $(ihamletFile tPath)|] + +addMessageWidget :: forall m site. + ( MonadHandler m + , HandlerSite m ~ site + , Yesod site + ) => MessageClass -> WidgetT site IO () -> m () +-- ^ _Note_: `addMessageWidget` ignores `pageTitle` and `pageHead` +addMessageWidget mc wgt = do + PageContent{pageBody} <- liftHandlerT $ widgetToPageContent wgt + addMessageIHamlet mc (const pageBody :: HtmlUrlI18n (SomeMessage site) (Route site)) diff --git a/src/Yesod/Core/Instances.hs b/src/Yesod/Core/Instances.hs index 85579cc5e..0b0f139c4 100644 --- a/src/Yesod/Core/Instances.hs +++ b/src/Yesod/Core/Instances.hs @@ -12,6 +12,8 @@ import Control.Lens import Data.ByteString.Builder (toLazyByteString) import System.FilePath (()) + +import Data.Aeson instance (RenderRoute site, ParseRoute site) => PathPiece (Route site) where @@ -32,3 +34,8 @@ instance (RenderRoute site, ParseRoute site) => PathPiece (Route site) where . over (_2.traverse._2) (assertM' $ not . null) . renderRoute +instance (RenderRoute site, ParseRoute site) => FromJSON (Route site) where + parseJSON = withText "Route" $ maybe (fail "Could not parse route") return . fromPathPiece + +instance (RenderRoute site, ParseRoute site) => ToJSON (Route site) where + toJSON = String . toPathPiece diff --git a/start.sh b/start.sh index 67d80033a..24abcd36c 100755 --- a/start.sh +++ b/start.sh @@ -10,11 +10,11 @@ export PWFILE=users.yml move-back() { mv -v .stack-work .stack-work-run - [[ -d .stack-work-ghci ]] && mv -v .stack-work-ghci .stack-work + [[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work } if [[ -d .stack-work-run ]]; then - [[ -d .stack-work ]] && mv -v .stack-work .stack-work-ghci + [[ -d .stack-work ]] && mv -v .stack-work .stack-work-build mv -v .stack-work-run .stack-work trap move-back EXIT fi diff --git a/templates/authpreds.hamlet b/templates/authpreds.hamlet new file mode 100644 index 000000000..4f04f04b7 --- /dev/null +++ b/templates/authpreds.hamlet @@ -0,0 +1,2 @@ +
+ ^{authActiveWidget} diff --git a/test.sh b/test.sh index 26f865cb1..dd625c99c 100755 --- a/test.sh +++ b/test.sh @@ -2,11 +2,11 @@ move-back() { mv -v .stack-work .stack-work-test - [[ -d .stack-work-run ]] && mv -v .stack-work-run .stack-work + [[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work } if [[ -d .stack-work-test ]]; then - [[ -d .stack-work ]] && mv -v .stack-work .stack-work-run + [[ -d .stack-work ]] && mv -v .stack-work .stack-work-build mv -v .stack-work-test .stack-work trap move-back EXIT fi