From c68a01d7ae26bfa61306e143d663d28f641d0998 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 14 Aug 2020 17:00:35 +0200 Subject: [PATCH] refactor: split foundation & llvm BREAKING CHANGE: split foundation --- .gitlab-ci.yml | 18 +- package.yaml | 40 +- src/Database/Persist/Sql/Types/Instances.hs | 22 + src/Foundation.hs | 5291 +---------------- src/Foundation/Authorization.hs | 1475 +++++ src/Foundation/DB.hs | 46 + src/Foundation/I18n.hs | 45 +- src/Foundation/Instances.hs | 203 + src/Foundation/Navigation.hs | 2239 +++++++ src/Foundation/Routes.hs | 4 +- src/Foundation/SiteLayout.hs | 569 ++ src/Foundation/Type.hs | 7 + src/Foundation/Yesod/Auth.hs | 498 ++ src/Foundation/Yesod/ErrorHandler.hs | 90 + src/Foundation/Yesod/Middleware.hs | 251 + src/Foundation/Yesod/Persist.hs | 44 + src/Foundation/Yesod/Session.hs | 62 + src/Foundation/Yesod/StaticContent.hs | 49 + src/Handler/Admin.hs | 2 - src/Handler/Admin/Tokens.hs | 2 +- src/Handler/CryptoIDDispatch.hs | 4 +- src/Handler/Info.hs | 8 +- src/Handler/Profile.hs | 2 + src/Handler/Sheet.hs | 2 - src/Handler/Sheet/Current.hs | 1 + src/Handler/Submission.hs | 2 + src/Handler/Utils.hs | 18 + src/Handler/Utils/Form.hs | 2 - .../Utils/Form/MassInput/Liveliness.hs | 3 +- src/Handler/Utils/Invitations.hs | 10 +- src/Handler/Utils/Memcached.hs | 6 +- src/Handler/Utils/Table/Pagination.hs | 11 +- src/Handler/Utils/Users.hs | 1 + src/Handler/Utils/Widgets.hs | 6 - src/Import/NoModel.hs | 4 + src/Jobs/Handler/SynchroniseLdap.hs | 1 + src/Mail.hs | 4 +- src/Model/Types/File.hs | 2 +- src/Settings.hs | 7 + src/Settings/Cluster.hs | 4 +- src/Utils.hs | 1 - src/Utils/DB.hs | 24 +- src/Utils/Form.hs | 3 +- src/Utils/SystemMessage.hs | 6 +- src/Utils/Widgets.hs | 13 + stack.yaml | 3 + stack.yaml.lock | 7 + test/ModelSpec.hs | 2 + 48 files changed, 5740 insertions(+), 5374 deletions(-) create mode 100644 src/Database/Persist/Sql/Types/Instances.hs create mode 100644 src/Foundation/Authorization.hs create mode 100644 src/Foundation/DB.hs create mode 100644 src/Foundation/Instances.hs create mode 100644 src/Foundation/Navigation.hs create mode 100644 src/Foundation/SiteLayout.hs create mode 100644 src/Foundation/Yesod/Auth.hs create mode 100644 src/Foundation/Yesod/ErrorHandler.hs create mode 100644 src/Foundation/Yesod/Middleware.hs create mode 100644 src/Foundation/Yesod/Persist.hs create mode 100644 src/Foundation/Yesod/Session.hs create mode 100644 src/Foundation/Yesod/StaticContent.hs create mode 100644 src/Utils/Widgets.hs diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 28fe57b4c..08d737859 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -32,13 +32,13 @@ npm install: before_script: &npm - rm -rvf /etc/apt/sources.list /etc/apt/sources.list.d - install -v -T -m 0644 ${APT_SOURCES_LIST} /etc/apt/sources.list - - apt-get update -y + - apt update -y - npm install -g n - n 13.5.0 - export PATH="${N_PREFIX}/bin:$PATH" - npm install -g npm - hash -r - - apt-get -y install openssh-client exiftool + - apt -y install openssh-client exiftool - install -v -m 0700 -d ~/.ssh - install -v -T -m 0644 ${SSH_KNOWN_HOSTS} ~/.ssh/known_hosts - install -v -T -m 0400 ${SSH_DEPLOY_KEY} ~/.ssh/deploy && echo "IdentityFile ~/.ssh/deploy" >> ~/.ssh/config; @@ -93,9 +93,9 @@ yesod:build:dev: before_script: &haskell - rm -rvf /etc/apt/sources.list /etc/apt/sources.list.d - install -v -T -m 0644 ${APT_SOURCES_LIST} /etc/apt/sources.list - - apt-get update -y - - apt-get install -y --no-install-recommends locales-all - - apt-get install openssh-client -y + - curl https://apt.llvm.org/llvm-snapshot.gpg.key | apt-key add - + - apt update -y + - apt install -y --no-install-recommends locales-all openssh-client clang-9 lldb-9 lld-9 clangd-9 - install -v -m 0700 -d ~/.ssh - install -v -T -m 0644 ${SSH_KNOWN_HOSTS} ~/.ssh/known_hosts - install -v -T -m 0400 ${SSH_DEPLOY_KEY} ~/.ssh/deploy && echo "IdentityFile ~/.ssh/deploy" >> ~/.ssh/config; @@ -143,13 +143,13 @@ frontend:test: before_script: - rm -rvf /etc/apt/sources.list /etc/apt/sources.list.d - install -v -T -m 0644 ${APT_SOURCES_LIST} /etc/apt/sources.list - - apt-get update -y + - apt update -y - npm install -g n - n 13.5.0 - export PATH="${N_PREFIX}/bin:$PATH" - npm install -g npm - hash -r - - apt-get install -y --no-install-recommends chromium-browser + - apt install -y --no-install-recommends chromium-browser dependencies: - npm install retry: 2 @@ -243,8 +243,8 @@ deploy:uniworx3: before_script: - rm -rvf /etc/apt/sources.list /etc/apt/sources.list.d - install -v -T -m 0644 ${APT_SOURCES_LIST} /etc/apt/sources.list - - apt-get update -y - - apt-get install -y --no-install-recommends openssh-client + - apt update -y + - apt install -y --no-install-recommends openssh-client - install -v -m 0700 -d ~/.ssh - install -v -T -m 0644 ${SSH_KNOWN_HOSTS} ~/.ssh/known_hosts - install -v -T -m 0400 ${SSH_PRIVATE_KEY_UNIWORX3} ~/.ssh/uniworx3; echo "IdentityFile ~/.ssh/uniworx3" >> ~/.ssh/config; diff --git a/package.yaml b/package.yaml index 162fb8079..34a56b449 100644 --- a/package.yaml +++ b/package.yaml @@ -63,7 +63,6 @@ dependencies: - cryptoids-class - binary - binary-instances - - cereal - mtl - esqueleto >=3.1.0 - mime-types @@ -210,6 +209,8 @@ default-extensions: - TypeFamilyDependencies - QuantifiedConstraints - EmptyDataDeriving + - StandaloneKindSignatures + - NoStarIsType ghc-options: - -Wall @@ -229,42 +230,41 @@ when: ghc-options: - -Werror - -fwarn-tabs + - condition: flag(dev) + then: + ghc-options: + - -O0 + - -ddump-splices + - -ddump-to-file + cpp-options: -DDEVELOPMENT + ghc-prof-options: + - -fprof-auto + else: + ghc-options: + - -O -fllvm # The library contains all of our application code. The executable # defined below is just a thin wrapper. library: source-dirs: src - when: - - condition: flag(dev) - then: - ghc-options: - - -O0 - - -ddump-splices - - -ddump-to-file - cpp-options: -DDEVELOPMENT - ghc-prof-options: - - -fprof-auto - else: - ghc-options: - - -O2 # Runnable executable for our application executables: uniworx: main: main.hs source-dirs: app - ghc-options: -threaded -rtsopts "-with-rtsopts=-N -T -xn" dependencies: - uniworx when: - condition: flag(library-only) buildable: false + ghc-options: + - -threaded -rtsopts "-with-rtsopts=-N -T -xn" uniworxdb: main: Database.hs ghc-options: - -main-is Database - - -threaded - - -rtsopts "-with-rtsopts=-N -T" + - -threaded -rtsopts "-with-rtsopts=-N -T -xn" source-dirs: test dependencies: - uniworx @@ -277,8 +277,7 @@ executables: main: Load.hs ghc-options: - -main-is Load - - -threaded - - -rtsopts "-with-rtsopts=-N -T -xn" + - -threaded -rtsopts "-with-rtsopts=-N -T -xn" source-dirs: load dependencies: - uniworx @@ -312,8 +311,7 @@ tests: - yesod-persistent ghc-options: - -fno-warn-orphans - - -threaded - - -rtsopts "-with-rtsopts=-N -xn" + - -threaded -rtsopts "-with-rtsopts=-N -T -xn" hlint: main: Hlint.hs other-modules: [] diff --git a/src/Database/Persist/Sql/Types/Instances.hs b/src/Database/Persist/Sql/Types/Instances.hs new file mode 100644 index 000000000..b7c33572b --- /dev/null +++ b/src/Database/Persist/Sql/Types/Instances.hs @@ -0,0 +1,22 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Database.Persist.Sql.Types.Instances + ( + ) where + +import ClassyPrelude + +import Database.Persist.Sql + + +instance BackendCompatible SqlWriteBackend SqlWriteBackend where + projectBackend = id + +instance BackendCompatible SqlReadBackend SqlReadBackend where + projectBackend = id + +instance BackendCompatible SqlReadBackend SqlBackend where + projectBackend = SqlReadBackend + +instance BackendCompatible SqlWriteBackend SqlBackend where + projectBackend = SqlWriteBackend diff --git a/src/Foundation.hs b/src/Foundation.hs index 9a1200ab5..6a9988f6c 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedLabels #-} -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-uni-patterns -fno-warn-redundant-constraints #-} -- MonadCrypto - module Foundation ( module Foundation ) where @@ -12,5282 +6,9 @@ import Foundation.Type as Foundation import Foundation.Types as Foundation import Foundation.I18n as Foundation import Foundation.Routes as Foundation - - -import Import.NoFoundation hiding (embedFile) -import Database.Persist.Sql - ( runSqlPool, transactionUndo, SqlReadBackend(..) ) -import Text.Hamlet (hamletFile) - -import Yesod.Auth.Message -import Auth.LDAP -import Auth.PWHash -import Auth.Dummy - -import qualified Network.Wai as W -import qualified Network.HTTP.Types.Header as W -import qualified Network.Wai.Middleware.HttpAuth as W (extractBearerAuth) - -import qualified Yesod.Core.Unsafe as Unsafe -import qualified Data.CaseInsensitive as CI - -import Data.ByteArray (convert) -import Crypto.Hash (SHAKE256, SHAKE128) -import Crypto.Hash.Conduit (sinkHash) -import qualified Data.UUID as UUID -import qualified Data.Binary as Binary - -import qualified Data.ByteString.Base64.URL as Base64 (encode) - -import qualified Data.ByteString.Lazy as Lazy.ByteString -import qualified Data.ByteString as ByteString - -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text - -import qualified Data.Set as Set -import Data.Map ((!?)) -import qualified Data.Map as Map -import qualified Data.HashSet as HashSet -import qualified Data.HashMap.Strict as HashMap -import qualified Data.List.NonEmpty as NonEmpty - -import Data.List ((!!), findIndex, inits) -import qualified Data.List as List - -import Data.Conduit.List (sourceList) - -import qualified Database.Esqueleto as E -import qualified Database.Esqueleto.Utils as E - -import Control.Monad.Except (MonadError(..)) -import Control.Monad.Trans.State (execStateT) -import Control.Monad.Writer.Class (MonadWriter(..)) -import Control.Monad.Memo.Class (MonadMemo(..), for4) -import Control.Monad.Reader.Class (MonadReader(local)) -import qualified Control.Monad.Catch as C - -import Handler.Utils.StudyFeatures -import Handler.Utils.SchoolLdap -import Handler.Utils.ExamOffice.Exam -import Handler.Utils.ExamOffice.ExternalExam -import Handler.Utils.ExamOffice.Course -import Handler.Utils.Profile -import Handler.Utils.Routes -import Handler.Utils.Memcached -import Utils.Course (courseIsVisible) -import Utils.Form -import Utils.Sheet -import Utils.SystemMessage -import Utils.Metrics - -import Text.Cassius (cassiusFile) - -import qualified Yesod.Auth.Message as Auth - -import qualified Data.Conduit.List as C - -import qualified Database.Memcached.Binary.IO as Memcached -import Data.Bits (Bits(zeroBits)) - -import Network.Wai.Parse (lbsBackEnd) - -import qualified Data.Aeson as JSON -import Data.Aeson.Lens hiding (_Value, key) - -import Data.FileEmbed (embedFile) - -import qualified Ldap.Client as Ldap - -import UnliftIO.Pool - -import qualified Web.ServerSession.Core as ServerSession -import qualified Web.ServerSession.Frontend.Yesod.Jwt as JwtSession - -import Web.Cookie - -import Yesod.Core.Types (GHState(..), HandlerData(..), HandlerContents, RunHandlerEnv(rheSite, rheChild)) - -import qualified Control.Retry as Retry -import GHC.IO.Exception (IOErrorType(OtherError)) - --- | Convenient Type Synonyms: -type DB = YesodDB UniWorX -type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, Widget) -type MsgRenderer = MsgRendererS UniWorX -- see Utils -type MailM a = MailT (HandlerFor UniWorX) a - --- Requires `rendeRoute`, thus cannot currently be moved to Foundation.I18n -instance RenderMessage UniWorX (UnsupportedAuthPredicate AuthTag (Route UniWorX)) where - renderMessage f ls (UnsupportedAuthPredicate tag route) = mr . MsgUnsupportedAuthPredicate (mr tag) $ Text.intercalate "/" pieces - where - mr :: forall msg. RenderMessage UniWorX msg => msg -> Text - mr = renderMessage f ls - (pieces, _) = renderRoute route - -data NavQuickView - = NavQuickViewFavourite - | NavQuickViewPageActionSecondary - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) - deriving (Universe, Finite) - -navQuick :: NavQuickView -> (NavQuickView -> Any) -navQuick x x' = Any $ x == x' - -data NavType - = NavTypeLink - { navModal :: Bool - } - | NavTypeButton - { navMethod :: StdMethod - , navData :: [(Text, Text)] - } - deriving (Eq, Ord, Read, Show, Generic, Typeable) - deriving anyclass (Binary) - -makeLenses_ ''NavType -makePrisms ''NavType - -data NavLevel = NavLevelTop | NavLevelInner - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) - -data NavHeaderRole = NavHeaderPrimary | NavHeaderSecondary - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) - -data NavLink = forall msg route. (RenderMessage UniWorX msg, HasRoute UniWorX route, RedirectUrl UniWorX route) => NavLink - { navLabel :: msg - , navRoute :: route - , navAccess' :: Handler Bool - , navType :: NavType - , navQuick' :: NavQuickView -> Any - , navForceActive :: Bool - } - -makeLenses_ ''NavLink - -instance HasRoute UniWorX NavLink where - urlRoute NavLink{..} = urlRoute navRoute -instance RedirectUrl UniWorX NavLink where - toTextUrl NavLink{..} = toTextUrl navRoute -instance RenderMessage UniWorX NavLink where - renderMessage app ls NavLink{..} = renderMessage app ls navLabel - -data Nav - = NavHeader - { navHeaderRole :: NavHeaderRole - , navIcon :: Icon - , navLink :: NavLink - } - | NavHeaderContainer - { navHeaderRole :: NavHeaderRole - , navLabel :: SomeMessage UniWorX - , navIcon :: Icon - , navChildren :: [NavLink] - } - | NavPageActionPrimary - { navLink :: NavLink - , navChildren :: [NavLink] - } - | NavPageActionSecondary - { navLink :: NavLink - } - | NavFooter - { navLink :: NavLink - } deriving (Generic, Typeable) - -makeLenses_ ''Nav -makePrisms ''Nav - -data NavChildren -type instance Children NavChildren a = ChildrenNavChildren a -type family ChildrenNavChildren a where - ChildrenNavChildren (SomeMessage UniWorX) = '[] - - ChildrenNavChildren a = Children ChGeneric a - -navAccess :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => Nav -> MaybeT m Nav -navAccess = execStateT $ do - guardM $ preuse _navLink >>= maybe (return True) navLinkAccess - - _navChildren <~ (filterM navLinkAccess =<< use _navChildren) - whenM (hasn't _navLink <$> use id) $ - guardM $ not . null <$> use _navChildren - -navLinkAccess :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => NavLink -> m Bool -navLinkAccess NavLink{..} = handle shortCircuit $ liftHandler navAccess' `and2M` accessCheck navType navRoute - where - shortCircuit :: HandlerContents -> m Bool - shortCircuit _ = return False - - accessCheck :: HasRoute UniWorX route => NavType -> route -> m Bool - accessCheck nt (urlRoute -> route) = do - authCtx <- getAuthContext - $memcachedByHere (Just $ Right 120) (authCtx, nt, route) $ - bool hasWriteAccessTo hasReadAccessTo (is _NavTypeLink nt) route - - -getTimeLocale' :: [Lang] -> TimeLocale -getTimeLocale' = $(timeLocaleMap [("de-de", "de_DE.utf8"), ("en-GB", "en_GB.utf8")]) - -appTZ :: TZ -appTZ = $(includeSystemTZ "Europe/Berlin") - -appLanguagesOpts :: ( MonadHandler m - , HandlerSite m ~ UniWorX - ) => m (OptionList Lang) --- ^ Authoritive list of supported Languages -appLanguagesOpts = do - MsgRenderer mr <- getMsgRenderer - let mkOption l = Option - { optionDisplay = mr $ MsgLanguage l - , optionInternalValue = l - , optionExternalValue = l - } - langOptions = map mkOption $ toList appLanguages - return $ mkOptionList langOptions - -instance RenderMessage UniWorX WeekDay where - renderMessage _ ls wDay = pack . fst $ wDays (getTimeLocale' ls) !! (fromEnum wDay `mod` 7) - -newtype ShortWeekDay = ShortWeekDay { longWeekDay :: WeekDay } - -instance RenderMessage UniWorX ShortWeekDay where - renderMessage _ ls (ShortWeekDay wDay) = pack . snd $ wDays (getTimeLocale' ls) !! (fromEnum wDay `mod` 7) - -instance Default DateTimeFormatter where - def = mkDateTimeFormatter (getTimeLocale' []) def appTZ - - --- Access Control -newtype InvalidAuthTag = InvalidAuthTag Text - deriving (Eq, Ord, Show, Read, Generic, Typeable) -instance Exception InvalidAuthTag - - -data AccessPredicate - = APPure (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult) - | APHandler (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Handler AuthResult) - | APDB (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend Handler AuthResult) - -class (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where - evalAccessPred :: AccessPredicate -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult - -instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where - evalAccessPred aPred aid r w = liftHandler $ case aPred of - (APPure p) -> runReader (p aid r w) <$> getMsgRenderer - (APHandler p) -> p aid r w - (APDB p) -> runDBRead $ p aid r w - -instance (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlBackend backend) => MonadAP (ReaderT backend m) where - evalAccessPred aPred aid r w = mapReaderT liftHandler . withReaderT (SqlReadBackend . projectBackend) $ case aPred of - (APPure p) -> lift $ runReader (p aid r w) <$> getMsgRenderer - (APHandler p) -> lift $ p aid r w - (APDB p) -> p aid 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 --- and -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 - -notAR :: RenderMessage UniWorX msg => MsgRenderer -> msg -> AuthResult -> AuthResult -notAR _ _ (Unauthorized _) = Authorized -notAR _ _ AuthenticationRequired = AuthenticationRequired -notAR mr msg Authorized = Unauthorized . render mr . MsgUnauthorizedNot $ render mr msg - -trueAR, falseAR :: MsgRendererS UniWorX -> AuthResult -trueAR = const Authorized -falseAR = Unauthorized . ($ MsgUnauthorized) . render - -trueAP, falseAP :: AccessPredicate -trueAP = APPure . const . const . const $ trueAR <$> ask -falseAP = APPure . const . const . const $ falseAR <$> ask -- included for completeness - - -data AuthContext = AuthContext - { authCtxAuth :: Maybe UserId - , authCtxBearer :: Maybe (BearerToken UniWorX) - , authActiveTags :: AuthTagActive - } deriving (Eq, Read, Show, Generic, Typeable) - deriving anyclass (Hashable, Binary) - -getAuthContext :: forall m. - ( MonadHandler m - , HandlerSite m ~ UniWorX - , MonadCatch m - ) - => m AuthContext -getAuthContext = do - authCtx <- AuthContext - <$> maybeAuthId - <*> runMaybeT (exceptTMaybe askBearerUnsafe) - <*> (fromMaybe def <$> lookupSessionJson SessionActiveAuthTags) - - $logDebugS "getAuthContext" $ tshow authCtx - - return authCtx - - -askBearerUnsafe :: forall m. - ( MonadHandler m - , HandlerSite m ~ UniWorX - , MonadCatch m - ) - => ExceptT AuthResult m (BearerToken UniWorX) --- | This performs /no/ meaningful validation of the `BearerToken` --- --- Use `requireBearerToken` or `maybeBearerToken` instead -askBearerUnsafe = $cachedHere $ do - bearer <- maybeMExceptT (unauthorizedI MsgUnauthorizedNoToken) askBearer - catch (decodeBearer bearer) $ \case - BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired - BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted - other -> do - $logWarnS "AuthToken" $ tshow other - throwError =<< unauthorizedI MsgUnauthorizedTokenInvalid - -validateBearer :: Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> BearerToken UniWorX -> ReaderT SqlReadBackend Handler AuthResult -validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo validateBearer' mAuthId' route' isWrite' token' - where - validateBearer' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult (ReaderT SqlReadBackend Handler) AuthResult - validateBearer' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do - guardMExceptT (maybe True (HashSet.member route) bearerRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute) - - bearerAuthority' <- flip foldMapM bearerAuthority $ \case - Left tVal - | JSON.Success groupName <- JSON.fromJSON tVal -> maybeT (throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityGroup) . hoist lift $ do - Entity _ UserGroupMember{..} <- MaybeT . getBy $ UniquePrimaryUserGroupMember groupName Active - return $ Set.singleton userGroupMemberUser - | otherwise -> throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityValue - Right uid -> return $ Set.singleton uid - - let - -- Prevent infinite loops - noTokenAuth :: AuthDNF -> AuthDNF - noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar - - guardMExceptT (not $ Set.null bearerAuthority') $ unauthorizedI MsgUnauthorizedTokenInvalidNoAuthority - - forM_ bearerAuthority' $ \uid -> do - User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get uid - guardMExceptT (Just bearerIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired) - - authorityVal <- do - dnf <- either throwM return $ routeAuthTags route - fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) (Just uid) route isWrite - guardExceptT (is _Authorized authorityVal) authorityVal - - whenIsJust bearerAddAuth $ \addDNF -> do - $logDebugS "validateToken" $ tshow addDNF - additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth addDNF) mAuthId route isWrite - guardExceptT (is _Authorized additionalVal) additionalVal - - return Authorized - -maybeBearerToken :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => m (Maybe (BearerToken UniWorX)) -maybeBearerToken = runMaybeT $ catchIfMaybeT cPred requireBearerToken - where - cPred err = any ($ err) - [ is $ _HCError . _PermissionDenied - , is $ _HCError . _NotAuthenticated - ] - -requireBearerToken :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (BearerToken UniWorX) -requireBearerToken = liftHandler $ do - bearer <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return askBearerUnsafe - mAuthId <- maybeAuthId - currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute - isWrite <- isWriteRequest currentRoute - guardAuthResult <=< runDBRead $ validateBearer mAuthId currentRoute isWrite bearer - return bearer - -requireCurrentBearerRestrictions :: forall a m. - ( MonadHandler m - , HandlerSite m ~ UniWorX - , FromJSON a - , ToJSON a - ) - => m (Maybe a) -requireCurrentBearerRestrictions = runMaybeT $ do - bearer <- requireBearerToken - route <- MaybeT getCurrentRoute - hoistMaybe $ bearer ^? _bearerRestrictionIx route - -maybeCurrentBearerRestrictions :: forall a m. - ( MonadHandler m - , HandlerSite m ~ UniWorX - , MonadCatch m - , FromJSON a - , ToJSON a - ) - => m (Maybe a) -maybeCurrentBearerRestrictions = runMaybeT $ do - bearer <- MaybeT maybeBearerToken - route <- MaybeT getCurrentRoute - hoistMaybe $ bearer ^? _bearerRestrictionIx route - -isDryRun :: forall m. - ( MonadHandler m - , HandlerSite m ~ UniWorX - , MonadCatch m - ) - => m Bool -isDryRun = $cachedHere $ orM - [ hasGlobalPostParam PostDryRun - , hasGlobalGetParam GetDryRun - , and2M bearerDryRun bearerRequired - ] - where - bearerDryRun = has (_Just . _Object . ix "dry-run") <$> maybeCurrentBearerRestrictions @Value - bearerRequired = maybeT (return True) . catchIfMaybeT cPred . liftHandler $ do - mAuthId <- maybeAuthId - currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute - isWrite <- isWriteRequest currentRoute - - let noTokenAuth :: AuthDNF -> AuthDNF - noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar - - dnf <- either throwM return $ routeAuthTags currentRoute - guardAuthResult <=< fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) mAuthId currentRoute isWrite - - return False - - cPred err = any ($ err) - [ is $ _HCError . _PermissionDenied - , is $ _HCError . _NotAuthenticated - ] - - -tagAccessPredicate :: AuthTag -> AccessPredicate -tagAccessPredicate AuthFree = trueAP -tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of - -- Courses: access only to school admins - CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isAdmin <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` userAdmin) -> do - E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserFunctionSchool - E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val authId - E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin) - return Authorized - -- Allocations: access only to school admins - AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isAdmin <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` userAdmin) -> do - E.on $ allocation E.^. AllocationSchool E.==. userAdmin E.^. UserFunctionSchool - E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val authId - E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin - E.&&. allocation E.^. AllocationTerm E.==. E.val tid - E.&&. allocation E.^. AllocationSchool E.==. E.val ssh - E.&&. allocation E.^. AllocationShorthand E.==. E.val ash - guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin) - return Authorized - -- Schools: access only to school admins - SchoolR ssh _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isAdmin <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] - guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin) - return Authorized - -- other routes: access to any admin is granted here - _other -> $cachedHereBinary mAuthId . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] [] - guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin) - return Authorized -tagAccessPredicate AuthExamOffice = APDB $ \mAuthId route _ -> case route of - CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasUsers <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do - E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId - E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId - - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. exam E.^. ExamName E.==. E.val examn - - E.where_ $ examOfficeExamResultAuth (E.val authId) examResult - guardMExceptT hasUsers (unauthorizedI MsgUnauthorizedExamExamOffice) - return Authorized - EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasUsers <- lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamResult) -> do - E.on $ eexam E.^. ExternalExamId E.==. eexamResult E.^. ExternalExamResultExam - - E.where_ $ eexam E.^. ExternalExamTerm E.==. E.val tid - E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh - E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen - E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn - - E.where_ $ examOfficeExternalExamResultAuth (E.val authId) eexamResult - guardMExceptT hasUsers $ unauthorizedI MsgUnauthorizedExternalExamExamOffice - return Authorized - CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isExamOffice <- lift . existsBy $ UniqueUserFunction authId ssh SchoolExamOffice - guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedExamExamOffice - return Authorized - _other -> $cachedHereBinary mAuthId . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isExamOffice <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice] - guardMExceptT isExamOffice (unauthorizedI MsgUnauthorizedExamOffice) - return Authorized -tagAccessPredicate AuthEvaluation = APDB $ \mAuthId route _ -> case route of - ParticipantsR _ ssh -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation - guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation - return Authorized - CourseR _ ssh _ _ -> $cachedHereBinary(mAuthId, ssh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation - guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation - return Authorized - _other -> $cachedHereBinary mAuthId . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolEvaluation] - guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation - return Authorized -tagAccessPredicate AuthAllocationAdmin = APDB $ \mAuthId route _ -> case route of - AllocationR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation - guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin - return Authorized - CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation - guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin - return Authorized - _other -> $cachedHereBinary mAuthId . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAllocation] - guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin - return Authorized -tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $ - lift . validateBearer mAuthId route isWrite =<< askBearerUnsafe -tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of - AdminHijackUserR cID -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do - myUid <- maybeExceptT AuthenticationRequired $ return mAuthId - uid <- decrypt cID - otherSchoolsFunctions <- lift . $cachedHereBinary uid $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid] [] - mySchools <- lift . $cachedHereBinary myUid $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. myUid, UserFunctionFunction ==. SchoolAdmin] [] - guardMExceptT (otherSchoolsFunctions `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation) - return Authorized - r -> $unsupportedAuthPredicate AuthNoEscalation r -tagAccessPredicate AuthDeprecated = APHandler $ \_ r _ -> do - $logWarnS "AccessControl" ("deprecated route: " <> tshow r) - addMessageI Error MsgDeprecatedRoute - allow <- getsYesod $ view _appAllowDeprecated - return $ bool (Unauthorized "Deprecated Route") Authorized allow -tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do - $logWarnS "AccessControl" ("route in development: " <> tshow r) -#ifdef DEVELOPMENT - return Authorized -#else - return $ Unauthorized "Route under development" -#endif -tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of - CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isLecturer <- lift . E.selectExists . 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 - guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer) - return Authorized - AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isLecturer <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` allocationCourse `E.InnerJoin` course `E.InnerJoin` lecturer) -> do - E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse - E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse - E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation - E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId - E.&&. allocation E.^. AllocationTerm E.==. E.val tid - E.&&. allocation E.^. AllocationSchool E.==. E.val ssh - E.&&. allocation E.^. AllocationShorthand E.==. E.val ash - guardMExceptT isLecturer $ unauthorizedI MsgUnauthorizedAllocationLecturer - return Authorized - EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isLecturer <- lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` staff) -> do - E.on $ eexam E.^. ExternalExamId E.==. staff E.^. ExternalExamStaffExam - E.where_ $ staff E.^. ExternalExamStaffUser E.==. E.val authId - E.&&. eexam E.^. ExternalExamTerm E.==. E.val tid - E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh - E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen - E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn - guardMExceptT isLecturer $ unauthorizedI MsgUnauthorizedExternalExamLecturer - return Authorized - -- lecturer for any school will do - _ -> $cachedHereBinary mAuthId . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolLecturer] [] - return Authorized -tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - resList <- $cachedHereBinary mAuthId . 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 _ -> $cachedHereBinary (mAuthId, cID) . maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do - sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID - Submission{..} <- MaybeT . lift $ get sid - guard $ Just authId == submissionRatingBy - return Authorized - CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, 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 _ -> $cachedHereBinary (mAuthId, 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 AuthExamCorrector = APDB $ \mAuthId route _ -> case route of - CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do - E.on $ examCorrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId - E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId - E.where_ $ examCorrector E.^. ExamCorrectorUser 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 - E.&&. exam E.^. ExamName E.==. E.val examn - guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector - return Authorized - CourseR tid ssh csh _ -> $cachedHereBinary (tid, ssh, csh) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.on $ exam E.^. ExamId E.==. examCorrector E.^. ExamCorrectorExam - E.where_ $ examCorrector E.^. ExamCorrectorUser 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 - guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector - return Authorized - r -> $unsupportedAuthPredicate AuthExamCorrector r -tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - resList <- $cachedHereBinary authId . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do - E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId - E.on $ tutorial E.^. TutorialCourse E.==. course E.^. CourseId - E.where_ $ tutor E.^. TutorUser E.==. E.val authId - return (course E.^. CourseId, tutorial E.^. TutorialId) - let - resMap :: Map CourseId (Set TutorialId) - resMap = Map.fromListWith Set.union [ (cid, Set.singleton tutid) | (E.Value cid, E.Value tutid) <- resList ] - case route of - CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutor) $ do - Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh - Entity tutid _ <- $cachedHereBinary (cid, tutn) . MaybeT . lift . getBy $ UniqueTutorial cid tutn - guard $ tutid `Set.member` fromMaybe Set.empty (resMap !? cid) - return Authorized - CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCourseTutor) $ do - Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh - guard $ cid `Set.member` Map.keysSet resMap - return Authorized - _ -> do - guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor) - return Authorized -tagAccessPredicate AuthTutorControl = APDB $ \_ route _ -> case route of - CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutorControl) $ do - Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn - guard tutorialTutorControlled - return Authorized - r -> $unsupportedAuthPredicate AuthTutorControl r -tagAccessPredicate AuthSubmissionGroup = APDB $ \mAuthId route _ -> case route of - CSubmissionR tid ssh csh shn cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionSubmissionGroup) $ do - course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity _ Sheet{..} <- $cachedHereBinary (course, shn) . MaybeT . getBy $ CourseSheet course shn - smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID - groups <- $cachedHereBinary cID . lift . fmap (Set.fromList . fmap E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionUser) -> do - E.on $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. submissionUser E.^. SubmissionUserUser - E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smId - return $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup - unless (Set.null groups || isn't _RegisteredGroups sheetGrouping) $ do - uid <- hoistMaybe mAuthId - guardM . lift $ exists [SubmissionGroupUserUser ==. uid, SubmissionGroupUserSubmissionGroup <-. Set.toList groups] - return Authorized - CSheetR tid ssh csh sheetn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetSubmissionGroup) $ do - course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity _ Sheet{..} <- $cachedHereBinary (course, sheetn) . MaybeT . getBy $ CourseSheet course sheetn - when (is _RegisteredGroups sheetGrouping) $ do - uid <- hoistMaybe mAuthId - guardM . lift . E.selectExists . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do - E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId - E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val course - E.&&. submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid - - return Authorized - r -> $unsupportedAuthPredicate AuthSubmissionGroup r -tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of - CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do - course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn - cTime <- liftIO getCurrentTime - registration <- case mAuthId of - Just uid -> $cachedHereBinary (eId, uid) . lift . getBy $ UniqueExamRegistration eId uid - Nothing -> return Nothing - - let visible = NTop examVisibleFrom <= NTop (Just cTime) - - case subRoute of - EShowR -> guard visible - EUsersR -> guard $ NTop examStart <= NTop (Just cTime) - && NTop (Just cTime) <= NTop examFinished - ERegisterR - | is _Nothing registration - -> guard $ visible - && NTop examRegisterFrom <= NTop (Just cTime) - && NTop (Just cTime) <= NTop examRegisterTo - | otherwise - -> guard $ visible - && NTop (Just cTime) <= NTop examDeregisterUntil - ERegisterOccR occn -> do - occId <- hoistMaybe <=< $cachedHereBinary (eId, occn) . lift . getKeyBy $ UniqueExamOccurrence eId occn - if - | (registration >>= examRegistrationOccurrence . entityVal) == Just occId - -> guard $ visible - && NTop (Just cTime) <= NTop examDeregisterUntil - | otherwise - -> guard $ visible - && NTop examRegisterFrom <= NTop (Just cTime) - && NTop (Just cTime) <= NTop examRegisterTo - ECorrectR -> guard $ NTop (Just cTime) >= NTop examStart - && NTop (Just cTime) <= NTop examFinished - _ -> return () - - return Authorized - - CTutorialR tid ssh csh tutn TRegisterR -> maybeT (unauthorizedI MsgUnauthorizedTutorialTime) $ do - now <- liftIO getCurrentTime - course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity tutId Tutorial{..} <- $cachedHereBinary (course, tutn) . MaybeT . getBy $ UniqueTutorial course tutn - registered <- case mAuthId of - Just uid -> $cachedHereBinary (tutId, uid) . lift . existsBy $ UniqueTutorialParticipant tutId uid - Nothing -> return False - - if - | not registered - , maybe False (now >=) tutorialRegisterFrom - , maybe True (now <=) tutorialRegisterTo - -> return Authorized - | registered - , maybe True (now <=) tutorialDeregisterUntil - -> return Authorized - | otherwise - -> mzero - - CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do - cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity _sid Sheet{..} <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn - cTime <- liftIO getCurrentTime - let - visible = NTop sheetVisibleFrom <= NTop (Just cTime) - active = NTop sheetActiveFrom <= NTop (Just cTime) && NTop (Just cTime) <= NTop sheetActiveTo - marking = NTop (Just cTime) > NTop sheetActiveTo - - guard visible - - case subRoute of - -- Single Files - SFileR SheetExercise _ -> guard $ NTop sheetActiveFrom <= NTop (Just cTime) - SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom - SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom - SFileR _ _ -> mzero - -- Archives of SheetFileType - SZipR SheetExercise -> guard $ NTop sheetActiveFrom <= NTop (Just cTime) - SZipR SheetHint -> guard $ maybe False (<= cTime) sheetHintFrom - SZipR SheetSolution -> guard $ maybe False (<= cTime) sheetSolutionFrom - SZipR _ -> mzero - -- Submissions - SubmissionNewR -> guard active - SAssignR -> guard marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change; this is assumed in Corrections.assignHandler - SubmissionR _ SubAssignR -> guard marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change - SubmissionR _ _ -> guard active - _ -> return () - - return Authorized - - CourseR tid ssh csh (MaterialR mnm _) -> maybeT (unauthorizedI MsgUnauthorizedMaterialTime) $ do - cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity _mid Material{materialVisibleFrom} <- $cachedHereBinary (cid, mnm) . MaybeT . getBy $ UniqueMaterial cid mnm - cTime <- liftIO getCurrentTime - let visible = NTop materialVisibleFrom <= NTop (Just cTime) - guard visible - return Authorized - - CourseR tid ssh csh CRegisterR -> do - now <- liftIO getCurrentTime - mbc <- $cachedHereBinary (tid, ssh, csh) . getBy $ TermSchoolCourseShort tid ssh csh - registered <- case (mbc,mAuthId) of - (Just (Entity cid _), Just uid) -> $cachedHereBinary (uid, cid) $ exists [CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive] - _ -> return False - case mbc of - (Just (Entity _ Course{courseRegisterFrom, courseRegisterTo})) - | not registered - , maybe False (now >=) courseRegisterFrom -- Nothing => no registration allowed - , maybe True (now <=) courseRegisterTo -> return Authorized - (Just (Entity cid Course{courseDeregisterUntil})) - | registered - -> maybeT (unauthorizedI MsgUnauthorizedCourseRegistrationTime) $ do - guard $ maybe True (now <=) courseDeregisterUntil - forM_ mAuthId $ \uid -> do - exams <- lift . E.select . E.from $ \exam -> do - E.where_ . E.exists . E.from $ \examRegistration -> - E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId - E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid - E.where_ $ exam E.^. ExamCourse E.==. E.val cid - return $ exam E.^. ExamDeregisterUntil - forM_ exams $ \(E.Value deregUntil) -> - guard $ NTop (Just now) <= NTop deregUntil - - tutorials <- lift . E.select . E.from $ \tutorial -> do - E.where_ . E.exists . E.from $ \tutorialParticipant -> - E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId - E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid - E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid - return $ tutorial E.^. TutorialDeregisterUntil - forM_ tutorials $ \(E.Value deregUntil) -> - guard $ NTop (Just now) <= NTop deregUntil - return Authorized - _other -> unauthorizedI MsgUnauthorizedCourseRegistrationTime - - CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do - Entity course Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course - allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation - - case allocation of - Nothing -> do - cTime <- liftIO getCurrentTime - guard $ maybe False (cTime >=) courseRegisterFrom - guard $ maybe True (cTime <=) courseRegisterTo - Just Allocation{..} -> do - cTime <- liftIO getCurrentTime - guard $ NTop allocationRegisterFrom <= NTop (Just cTime) - guard $ NTop (Just cTime) <= NTop allocationRegisterTo - - return Authorized - - AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do - -- Checks `registerFrom` and `registerTo`, override as further routes become available - now <- liftIO getCurrentTime - Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash - guard $ NTop allocationRegisterFrom <= NTop (Just now) - guard $ NTop (Just now) <= NTop allocationRegisterTo - return Authorized - - MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do - smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID - SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId - cTime <- NTop . Just <$> liftIO getCurrentTime - guard $ NTop systemMessageFrom <= cTime - && NTop systemMessageTo >= cTime - return Authorized - - MessageHideR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do - smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID - SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId - cTime <- NTop . Just <$> liftIO getCurrentTime - guard $ NTop systemMessageFrom <= cTime - && NTop systemMessageTo >= cTime - return Authorized - - CNewsR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedCourseNewsTime) $ do - nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID - CourseNews{courseNewsVisibleFrom} <- $cachedHereBinary nId . MaybeT $ get nId - cTime <- NTop . Just <$> liftIO getCurrentTime - guard $ NTop courseNewsVisibleFrom <= cTime - return Authorized - - r -> $unsupportedAuthPredicate AuthTime r -tagAccessPredicate AuthStaffTime = APDB $ \_ route isWrite -> case route of - CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do - course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course - allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation - - case allocation of - Nothing -> return () - Just Allocation{..} -> do - cTime <- liftIO getCurrentTime - guard $ NTop allocationStaffAllocationFrom <= NTop (Just cTime) - when isWrite $ - guard $ NTop (Just cTime) <= NTop allocationStaffAllocationTo - - return Authorized - - AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do - -- Checks `registerFrom` and `registerTo`, override as further routes become available - now <- liftIO getCurrentTime - Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash - guard $ NTop allocationStaffAllocationFrom <= NTop (Just now) - guard $ NTop (Just now) <= NTop allocationStaffAllocationTo - return Authorized - - r -> $unsupportedAuthPredicate AuthStaffTime r -tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of - CourseR tid ssh csh CRegisterR -> do - now <- liftIO getCurrentTime - mba <- mbAllocation tid ssh csh - case mba of - Nothing -> return Authorized - Just (cid, Allocation{..}) -> do - registered <- case mAuthId of - Just uid -> $cachedHereBinary (uid, cid) . existsBy $ UniqueParticipant uid cid - _ -> return False - if - | not registered - , NTop allocationRegisterByCourse >= NTop (Just now) - -> unauthorizedI MsgUnauthorizedAllocatedCourseRegister - | registered - , NTop (Just now) >= NTop allocationOverrideDeregister - -> unauthorizedI MsgUnauthorizedAllocatedCourseDeregister - | otherwise - -> return Authorized - - CourseR tid ssh csh CAddUserR -> do - now <- liftIO getCurrentTime - mba <- mbAllocation tid ssh csh - case mba of - Just (_, Allocation{..}) - | NTop allocationRegisterByStaffTo <= NTop (Just now) - || NTop allocationRegisterByStaffFrom >= NTop (Just now) - -> unauthorizedI MsgUnauthorizedAllocatedCourseRegister - _other -> return Authorized - - CourseR tid ssh csh CDeleteR -> do - now <- liftIO getCurrentTime - mba <- mbAllocation tid ssh csh - case mba of - Just (_, Allocation{..}) - | NTop allocationRegisterByStaffTo <= NTop (Just now) - || NTop allocationRegisterByStaffFrom >= NTop (Just now) - -> unauthorizedI MsgUnauthorizedAllocatedCourseDelete - _other -> return Authorized - - r -> $unsupportedAuthPredicate AuthAllocationTime r - where - mbAllocation tid ssh csh = $cachedHereBinary (tid, ssh, csh) . runMaybeT $ do - cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity _ AllocationCourse{..} <- MaybeT . getBy $ UniqueAllocationCourse cid - (cid,) <$> MaybeT (get allocationCourseAllocation) -tagAccessPredicate AuthCourseTime = APDB $ \_mAuthId route _ -> case route of - CourseR tid ssh csh _ -> exceptT return return $ do - now <- liftIO getCurrentTime - courseVisible <- $cachedHereBinary (tid, ssh, csh) . lift . E.selectExists . E.from $ \course -> do - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. courseIsVisible now course Nothing - guardMExceptT courseVisible (unauthorizedI MsgUnauthorizedCourseTime) - return Authorized - r -> $unsupportedAuthPredicate AuthCourseTime r -tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route of - CourseR tid ssh csh _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . 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.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered) - return Authorized - r -> $unsupportedAuthPredicate AuthCourseRegistered r -tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case route of - CTutorialR tid ssh csh tutn _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isRegistered <- $cachedHereBinary (authId, tid, ssh, csh, tutn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do - E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial - E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse - E.where_ $ tutorialParticipant E.^. TutorialParticipantUser 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 - E.&&. tutorial E.^. TutorialName E.==. E.val tutn - guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered) - return Authorized - CourseR tid ssh csh _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do - E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial - E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse - E.where_ $ tutorialParticipant E.^. TutorialParticipantUser 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 - guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered) - return Authorized - r -> $unsupportedAuthPredicate AuthTutorialRegistered r -tagAccessPredicate AuthExamOccurrenceRegistration = APDB $ \_ route _ -> case route of - CExamR tid ssh csh examn _ -> exceptT return return $ do - isOccurrenceRegistration <- $cachedHereBinary (tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam) -> do - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. exam E.^. ExamName E.==. E.val examn - E.&&. exam E.^. ExamOccurrenceRule E.==. E.val ExamRoomFifo - guardMExceptT isOccurrenceRegistration (unauthorizedI MsgUnauthorizedExamOccurrenceRegistration) - return Authorized - r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistration r -tagAccessPredicate AuthExamOccurrenceRegistered = APDB $ \mAuthId route _ -> case route of - CExamR tid ssh csh examn (ERegisterOccR occn) -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn, occn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration `E.InnerJoin` examOccurrence) -> do - E.on $ E.just (examOccurrence E.^. ExamOccurrenceId) E.==. examRegistration E.^. ExamRegistrationOccurrence - E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId - E.&&. examOccurrence E.^. ExamOccurrenceName E.==. E.val occn - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. exam E.^. ExamName E.==. E.val examn - guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered) - return Authorized - CExamR tid ssh csh examn _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do - E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ examRegistration E.^. ExamRegistrationUser 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 - E.&&. exam E.^. ExamName E.==. E.val examn - E.&&. E.not_ (E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence) - guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered) - return Authorized - CourseR tid ssh csh _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do - E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ examRegistration E.^. ExamRegistrationUser 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 - E.&&. E.not_ (E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence) - guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered) - return Authorized - r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistered r -tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of - CExamR tid ssh csh examn _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do - E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ examRegistration E.^. ExamRegistrationUser 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 - E.&&. exam E.^. ExamName E.==. E.val examn - guardMExceptT hasRegistration $ unauthorizedI MsgUnauthorizedRegisteredExam - return Authorized - CSheetR tid ssh csh shn _ -> exceptT return return $ do - requiredExam' <- $cachedHereBinary (tid, ssh, csh, shn) . lift . E.selectMaybe . E.from $ \(course `E.InnerJoin` sheet) -> do - E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. sheet E.^. SheetName E.==. E.val shn - return $ sheet E.^. SheetRequireExamRegistration - requiredExam <- maybeMExceptT (unauthorizedI MsgUnauthorizedRegisteredExam) . return $ E.unValue <$> requiredExam' - whenIsJust requiredExam $ \eId -> do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isRegistered <- $cachedHereBinary (authId, eId) . lift . E.selectExists . E.from $ \examRegistration -> - E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eId - E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val authId - guardMExceptT isRegistered $ unauthorizedI MsgUnauthorizedRegisteredExam - return Authorized - CourseR tid ssh csh _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do - E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ examRegistration E.^. ExamRegistrationUser 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 - guardMExceptT hasRegistration $ unauthorizedI MsgUnauthorizedRegisteredAnyExam - return Authorized - r -> $unsupportedAuthPredicate AuthExamRegistered r -tagAccessPredicate AuthExamResult = APDB $ \mAuthId route _ -> case route of - CExamR tid ssh csh examn _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasResult <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do - E.on $ exam E.^. ExamId E.==. examResult E.^. ExamResultExam - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ examResult E.^. ExamResultUser 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 - E.&&. exam E.^. ExamName E.==. E.val examn - hasPartResult <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examPart `E.InnerJoin` examPartResult) -> do - E.on $ examPartResult E.^. ExamPartResultExamPart E.==. examPart E.^. ExamPartId - E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ examPartResult E.^. ExamPartResultUser 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 - E.&&. exam E.^. ExamName E.==. E.val examn - guardMExceptT (hasResult || hasPartResult) (unauthorizedI MsgUnauthorizedExamResult) - return Authorized - EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasResult <- $cachedHereBinary (authId, tid, ssh, coursen, examn) . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamResult) -> do - E.on $ eexam E.^. ExternalExamId E.==. eexamResult E.^. ExternalExamResultExam - E.where_ $ eexamResult E.^. ExternalExamResultUser E.==. E.val authId - E.&&. eexam E.^. ExternalExamTerm E.==. E.val tid - E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh - E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen - E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn - guardMExceptT hasResult $ unauthorizedI MsgUnauthorizedExternalExamResult - return Authorized - CourseR tid ssh csh _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasResult <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do - E.on $ exam E.^. ExamId E.==. examResult E.^. ExamResultExam - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ examResult E.^. ExamResultUser 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 - hasPartResult <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examPart `E.InnerJoin` examPartResult) -> do - E.on $ examPartResult E.^. ExamPartResultExamPart E.==. examPart E.^. ExamPartId - E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ examPartResult E.^. ExamPartResultUser 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 - guardMExceptT (hasResult || hasPartResult) (unauthorizedI MsgUnauthorizedExamResult) - return Authorized - r -> $unsupportedAuthPredicate AuthExamRegistered r -tagAccessPredicate AuthAllocationRegistered = APDB $ \mAuthId route _ -> case route of - AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegistered) $ do - uid <- hoistMaybe mAuthId - aId <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getKeyBy $ TermSchoolAllocationShort tid ssh ash - void . MaybeT . $cachedHereBinary (uid, aId) . getKeyBy $ UniqueAllocationUser aId uid - return Authorized - r -> $unsupportedAuthPredicate AuthAllocationRegistered r -tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of - CNewsR tid ssh csh cID _ -> maybeT (unauthorizedI MsgUnauthorizedParticipantSelf) $ do - nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID - CourseNews{courseNewsParticipantsOnly} <- $cachedHereBinary nId . MaybeT $ get nId - if | courseNewsParticipantsOnly -> do - uid <- hoistMaybe mAuthId - exceptT return (const mzero) . hoist lift $ isCourseParticipant tid ssh csh uid True - | otherwise - -> return Authorized - - CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do - participant <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedParticipant) (const True :: CryptoIDError -> Bool) $ decrypt cID - isCourseParticipant tid ssh csh participant False - unauthorizedI MsgUnauthorizedParticipant - - r -> $unsupportedAuthPredicate AuthParticipant r - - where - isCourseParticipant tid ssh csh participant onlyActive = do - let - authorizedIfExists :: E.From a => (a -> E.SqlQuery b) -> ExceptT AuthResult (ReaderT SqlReadBackend Handler) () - authorizedIfExists = flip whenExceptT Authorized <=< lift . E.selectExists . E.from - -- participant is currently registered - mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do - E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse - E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - when onlyActive $ - E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive - -- participant has at least one submission - unless onlyActive $ - mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do - E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission - E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet - E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse - E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - -- participant is member of a submissionGroup - unless onlyActive $ - mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do - E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup - E.on $ course E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse - E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - -- participant is a sheet corrector - mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do - E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet - E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse - E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - -- participant is a tutorial user - unless onlyActive $ - mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do - E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial - E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse - E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - -- participant is tutor for this course - mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do - E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial - E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse - E.where_ $ tutor E.^. TutorUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - -- participant is exam corrector for this course - mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do - E.on $ exam E.^. ExamId E.==. examCorrector E.^. ExamCorrectorExam - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - -- participant is lecturer for this course - mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` lecturer) -> do - E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse - E.where_ $ lecturer E.^. LecturerUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - -- participant has an exam result for this course - unless onlyActive $ - mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do - E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ examResult E.^. ExamResultUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - -- participant is registered for an exam for this course - unless onlyActive $ - mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do - E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh -tagAccessPredicate AuthApplicant = APDB $ \mAuthId route _ -> case route of - CourseR tid ssh csh (CUserR cID) -> maybeT (unauthorizedI MsgUnauthorizedApplicant) $ do - uid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID - isApplicant <- isCourseApplicant tid ssh csh uid - guard isApplicant - return Authorized - - CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedApplicantSelf) $ do - uid <- hoistMaybe mAuthId - isApplicant <- isCourseApplicant tid ssh csh uid - guard isApplicant - return Authorized - - r -> $unsupportedAuthPredicate AuthApplicant r - where - isCourseApplicant tid ssh csh uid = lift . $cachedHereBinary (uid, tid, ssh, csh) . E.selectExists . E.from $ \(course `E.InnerJoin` courseApplication) -> do - E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse - E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val uid - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh -tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of - CExamR tid ssh csh examn (ERegisterOccR occn) -> maybeT (unauthorizedI MsgExamOccurrenceNoCapacity) $ do - cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - eid <- $cachedHereBinary (cid, examn) . MaybeT . getKeyBy $ UniqueExam cid examn - Entity occId ExamOccurrence{..} <- $cachedHereBinary (eid, occn) . MaybeT . getBy $ UniqueExamOccurrence eid occn - registered <- $cachedHereBinary occId . lift $ fromIntegral <$> count [ ExamRegistrationOccurrence ==. Just occId, ExamRegistrationExam ==. eid ] - guard $ examOccurrenceCapacity > registered - return Authorized - CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgTutorialNoCapacity) $ do - cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity tutId Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn - registered <- $cachedHereBinary tutId . lift $ count [ TutorialParticipantTutorial ==. tutId ] - guard $ NTop tutorialCapacity > NTop (Just registered) - return Authorized - CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do - Entity cid Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - registered <- $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ] - guard $ NTop courseCapacity > NTop (Just registered) - return Authorized - r -> $unsupportedAuthPredicate AuthCapacity r -tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of - CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialRegisterGroup) $ do - cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn - case (tutorialRegGroup, mAuthId) of - (Nothing, _) -> return Authorized - (_, Nothing) -> return AuthenticationRequired - (Just rGroup, Just uid) -> do - hasOther <- $cachedHereBinary (uid, rGroup) . lift . E.selectExists . E.from $ \(tutorial `E.InnerJoin` participant) -> do - E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial - E.&&. tutorial E.^. TutorialCourse E.==. E.val tutorialCourse - E.&&. tutorial E.^. TutorialRegGroup E.==. E.just (E.val rGroup) - E.&&. participant E.^. TutorialParticipantUser E.==. E.val uid - guard $ not hasOther - return Authorized - r -> $unsupportedAuthPredicate AuthRegisterGroup r -tagAccessPredicate AuthEmpty = APDB $ \mAuthId route _ -> case route of - EExamListR -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - hasExternalExams <- $cachedHereBinary authId . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamStaff) -> do - E.on $ eexam E.^. ExternalExamId E.==. eexamStaff E.^. ExternalExamStaffExam - E.where_ $ eexamStaff E.^. ExternalExamStaffUser E.==. E.val authId - guardMExceptT (not hasExternalExams) $ unauthorizedI MsgUnauthorizedExternalExamListNotEmpty - return Authorized - CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do - -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - assertM_ (<= 0) . $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ] - assertM_ not . $cachedHereBinary cid . lift $ E.selectExists . E.from $ \(sheet `E.InnerJoin` submission) -> do - E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet - E.where_ $ sheet E.^. SheetCourse E.==. E.val cid - return Authorized - r -> $unsupportedAuthPredicate AuthEmpty r -tagAccessPredicate AuthMaterials = APDB $ \_ route _ -> case route of - CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do - Entity _ Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - guard courseMaterialFree - return Authorized - r -> $unsupportedAuthPredicate AuthMaterials r -tagAccessPredicate AuthOwner = APDB $ \mAuthId route _ -> case route of - CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do - sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid - return Authorized - r -> $unsupportedAuthPredicate AuthOwner r -tagAccessPredicate AuthPersonalisedSheetFiles = APDB $ \mAuthId route _ -> case route of - CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . exceptT return return $ do - Entity shId Sheet{..} <- maybeTMExceptT (unauthorizedI MsgUnauthorizedSubmissionPersonalisedSheetFiles) $ do - cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . getKeyBy $ TermSchoolCourseShort tid ssh csh - MaybeT . $cachedHereBinary (cid, shn) . getBy $ CourseSheet cid shn - if | sheetAllowNonPersonalisedSubmission -> return Authorized - | otherwise -> do - authId <- maybeExceptT AuthenticationRequired $ return mAuthId - flip guardMExceptT (unauthorizedI MsgUnauthorizedSubmissionPersonalisedSheetFiles) <=< $cachedHereBinary (shId, authId) . lift $ - E.selectExists . E.from $ \psFile -> - E.where_ $ psFile E.^. PersonalisedSheetFileSheet E.==. E.val shId - E.&&. psFile E.^. PersonalisedSheetFileUser E.==. E.val authId - E.&&. E.not_ (E.isNothing $ psFile E.^. PersonalisedSheetFileContent) -- directories don't count - return Authorized - r -> $unsupportedAuthPredicate AuthPersonalisedSheetFiles r -tagAccessPredicate AuthRated = APDB $ \_ route _ -> case route of - CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary cID . maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do - sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID - sub <- MaybeT $ get sid - guard $ submissionRatingDone sub - return Authorized - r -> $unsupportedAuthPredicate AuthRated r -tagAccessPredicate AuthUserSubmissions = APDB $ \_ route _ -> case route of - CSheetR tid ssh csh shn _ -> $cachedHereBinary (tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do - Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn - guard $ is _Just submissionModeUser - return Authorized - r -> $unsupportedAuthPredicate AuthUserSubmissions r -tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of - CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do - Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn - guard submissionModeCorrector - return Authorized - r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r -tagAccessPredicate AuthSelf = APDB $ \mAuthId route _ -> exceptT return return $ do - referencedUser' <- case route of - AdminUserR cID -> return $ Left cID - AdminUserDeleteR cID -> return $ Left cID - AdminHijackUserR cID -> return $ Left cID - UserNotificationR cID -> return $ Left cID - UserPasswordR cID -> return $ Left cID - CourseR _ _ _ (CUserR cID) -> return $ Left cID - CApplicationR _ _ _ cID _ -> do - appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID - CourseApplication{..} <- maybeMExceptT (unauthorizedI MsgUnauthorizedSelf) . $cachedHereBinary appId $ get appId - return $ Right courseApplicationUser - _other -> throwError =<< $unsupportedAuthPredicate AuthSelf route - referencedUser <- case referencedUser' of - Right uid -> return uid - Left cID -> catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID - case mAuthId of - Just uid - | uid == referencedUser -> return Authorized - Nothing -> return AuthenticationRequired - _other -> unauthorizedI MsgUnauthorizedSelf -tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do - referencedUser <- case route of - AdminUserR cID -> return cID - AdminUserDeleteR cID -> return cID - AdminHijackUserR cID -> return cID - UserNotificationR cID -> return cID - UserPasswordR cID -> return cID - CourseR _ _ _ (CUserR cID) -> return cID - _other -> throwError =<< $unsupportedAuthPredicate AuthIsLDAP route - referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser - maybeTMExceptT (unauthorizedI MsgUnauthorizedLDAP) $ do - User{..} <- MaybeT $ get referencedUser' - guard $ userAuthentication == AuthLDAP - return Authorized -tagAccessPredicate AuthIsPWHash = APDB $ \_ route _ -> exceptT return return $ do - referencedUser <- case route of - AdminUserR cID -> return cID - AdminUserDeleteR cID -> return cID - AdminHijackUserR cID -> return cID - UserNotificationR cID -> return cID - UserPasswordR cID -> return cID - CourseR _ _ _ (CUserR cID) -> return cID - _other -> throwError =<< $unsupportedAuthPredicate AuthIsPWHash route - referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser - maybeTMExceptT (unauthorizedI MsgUnauthorizedPWHash) $ do - User{..} <- MaybeT $ get referencedUser' - guard $ is _AuthPWHash userAuthentication - return Authorized -tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of - MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do - smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID - SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId - let isAuthenticated = isJust mAuthId - guard $ not systemMessageAuthenticatedOnly || isAuthenticated - return Authorized - MessageHideR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do - smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID - SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId - let isAuthenticated = isJust mAuthId - guard $ not systemMessageAuthenticatedOnly || isAuthenticated - return Authorized - r -> $unsupportedAuthPredicate AuthAuthentication r -tagAccessPredicate AuthRead = APPure $ \_ _ isWrite -> do - MsgRenderer mr <- ask - return $ bool Authorized (Unauthorized $ mr MsgUnauthorizedWrite) isWrite -tagAccessPredicate AuthWrite = APPure $ \_ _ isWrite -> do - MsgRenderer mr <- ask - return $ bool (Unauthorized $ mr MsgUnauthorized) Authorized isWrite - - -authTagSpecificity :: AuthTag -> AuthTag -> Ordering --- ^ Heuristic for which `AuthTag`s to evaluate first -authTagSpecificity = comparing $ NTop . flip findIndex eqClasses . elem - where - eqClasses :: [[AuthTag]] - -- ^ Constructors of `AuthTag` ordered (increasing) by execution order - eqClasses = - [ [ AuthFree, AuthDeprecated, AuthDevelopment ] -- Route wide - , [ AuthRead, AuthWrite, AuthToken ] -- Request wide - , [ AuthAdmin ] -- Site wide - , [ AuthLecturer, AuthCourseRegistered, AuthParticipant, AuthCourseTime, AuthTime, AuthMaterials, AuthUserSubmissions, AuthCorrectorSubmissions, AuthCapacity, AuthEmpty ] ++ [ AuthSelf, AuthNoEscalation ] ++ [ AuthAuthentication ] -- Course/User/SystemMessage wide - , [ AuthCorrector ] ++ [ AuthTutor ] ++ [ AuthTutorialRegistered, AuthRegisterGroup ] -- Tutorial/Material/Sheet wide - , [ AuthOwner, AuthRated ] -- Submission wide - ] - -defaultAuthDNF :: AuthDNF -defaultAuthDNF = PredDNF $ Set.fromList - [ impureNonNull . Set.singleton $ PLVariable AuthAdmin - , impureNonNull . Set.singleton $ PLVariable AuthToken - ] - -routeAuthTags :: Route UniWorX -> Either InvalidAuthTag AuthDNF --- ^ DNF up to entailment: --- --- > (A_1 && A_2 && ...) OR' B OR' ... --- --- > A OR' B := ((A |- B) ==> A) && (A || B) -routeAuthTags = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.mapMonotonic toNullable $ dnfTerms defaultAuthDNF) . routeAttrs - where - partition' :: Set (Set AuthLiteral) -> Text -> Either InvalidAuthTag (Set (Set AuthLiteral)) - 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 $ Set.filter (not . (`Set.isSubsetOf` authTags)) prev - | otherwise - = Left $ InvalidAuthTag t - -evalAuthTags :: forall m. MonadAP m => AuthTagActive -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult --- ^ `tell`s disabled predicates, identified as pivots -evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite - = do - mr <- getMsgRenderer - let - authVarSpecificity = authTagSpecificity `on` plVar - authDNF = sortBy (authVarSpecificity `on` maximumBy authVarSpecificity . impureNonNull) $ map (sortBy authVarSpecificity) authDNF' - - authTagIsInactive = not . authTagIsActive - - evalAuthTag :: AuthTag -> WriterT (Set AuthTag) m AuthResult - evalAuthTag authTag = lift . ($runCachedMemoT :: CachedMemoT (AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for4 memo evalAccessPred' authTag mAuthId route isWrite - where - evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do - $logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite') - evalAccessPred (tagAccessPredicate authTag') mAuthId' route' isWrite' - - evalAuthLiteral :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult - evalAuthLiteral PLVariable{..} = evalAuthTag plVar - evalAuthLiteral PLNegated{..} = notAR mr plVar <$> evalAuthTag plVar - - 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 :: [[AuthLiteral]] -> WriterT (Set AuthTag) m AuthResult - evalDNF = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthLiteral aTag) (return $ trueAR mr) ats) (return $ falseAR mr) - - $logDebugS "evalAuthTags" . tshow . (route, isWrite, ) $ map (map $ id &&& authTagIsActive . plVar) authDNF - - result <- evalDNF $ filter (all $ authTagIsActive . plVar) authDNF - - unless (is _Authorized result) . forM_ (filter (any $ authTagIsInactive . plVar) authDNF) $ \conj -> - whenM (allM conj (\aTag -> (return . not . authTagIsActive $ plVar aTag) `or2M` (not . is _Unauthorized <$> evalAuthLiteral aTag))) $ do - let pivots = filter (authTagIsInactive . plVar) conj - whenM (allM pivots $ fmap (is _Authorized) . evalAuthLiteral) $ do - let pivots' = plVar <$> pivots - $logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots'}|] - tell $ Set.fromList pivots' - - return result - -evalAccessFor :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult -evalAccessFor mAuthId route isWrite = do - dnf <- either throwM return $ routeAuthTags route - fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) dnf mAuthId route isWrite - -evalAccessForDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlBackend backend) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT backend m AuthResult -evalAccessForDB = evalAccessFor - -evalAccessWith :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> m AuthResult -evalAccessWith assumptions route isWrite = do - mAuthId <- liftHandler maybeAuthId - tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags - dnf <- either throwM return $ routeAuthTags route - let dnf' = ala Endo foldMap (map ((=<<) . uncurry dnfAssumeValue) assumptions) $ Just dnf - case dnf' of - Nothing -> return Authorized - Just dnf'' -> do - (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf'' mAuthId route isWrite - result <$ tellSessionJson SessionInactiveAuthTags deactivated - -evalAccessWithDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlBackend backend) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> ReaderT backend m AuthResult -evalAccessWithDB = evalAccessWith - -evalAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult -evalAccess = evalAccessWith [] - -evalAccessDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlBackend backend) => Route UniWorX -> Bool -> ReaderT backend m AuthResult -evalAccessDB = evalAccess - --- | Check whether the current user is authorized by `evalAccess` for the given route --- Convenience function for a commonly used code fragment -hasAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m Bool -hasAccessTo route isWrite = (== Authorized) <$> evalAccess route isWrite - --- | Check whether the current user is authorized by `evalAccess` to read from the given route --- Convenience function for a commonly used code fragment -hasReadAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool -hasReadAccessTo = flip hasAccessTo False - --- | Check whether the current user is authorized by `evalAccess` to rwrite to the given route --- Convenience function for a commonly used code fragment -hasWriteAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m Bool -hasWriteAccessTo = flip hasAccessTo True - -wouldHaveAccessTo :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) - => [(AuthTag, Bool)] -- ^ Assumptions - -> Route UniWorX - -> Bool - -> m Bool -wouldHaveAccessTo assumptions route isWrite = (== Authorized) <$> evalAccessWith assumptions route isWrite - -wouldHaveReadAccessTo, wouldHaveWriteAccessTo - :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) - => [(AuthTag, Bool)] -- ^ Assumptions - -> Route UniWorX - -> m Bool -wouldHaveReadAccessTo assumptions route = wouldHaveAccessTo assumptions route False -wouldHaveWriteAccessTo assumptions route = wouldHaveAccessTo assumptions route True - -wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff - :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) - => [(AuthTag, Bool)] -- ^ Assumptions - -> Route UniWorX - -> m Bool -wouldHaveReadAccessToIff assumptions route = and2M (not <$> hasReadAccessTo route) $ wouldHaveReadAccessTo assumptions route -wouldHaveWriteAccessToIff assumptions route = and2M (not <$> hasWriteAccessTo route) $ wouldHaveWriteAccessTo assumptions route - --- | Conditional redirect that hides the URL if the user is not authorized for the route -redirectAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> m a -redirectAccess url = do - -- must hide URL if not authorized - access <- evalAccess url False - case access of - Authorized -> redirect url - _ -> permissionDeniedI MsgUnauthorizedRedirect - -redirectAccessWith :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Status -> Route UniWorX -> m a -redirectAccessWith status url = do - -- must hide URL if not authorized - access <- evalAccess url False - case access of - Authorized -> redirectWith status url - _ -> permissionDeniedI MsgUnauthorizedRedirect - - --- | Verify that the currently logged in user is lecturer or corrector for at least one sheet for the given course -evalAccessCorrector :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) - => TermId -> SchoolId -> CourseShorthand -> m AuthResult -evalAccessCorrector tid ssh csh = evalAccess (CourseR tid ssh csh CNotesR) False - - -data instance ButtonClass UniWorX - = BCIsButton - | BCDefault - | BCPrimary - | BCSuccess - | BCInfo - | BCWarning - | BCDanger - | BCLink - | BCMassInputAdd | BCMassInputDelete - deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) - deriving anyclass (Universe, Finite) - -instance PathPiece (ButtonClass UniWorX) where - toPathPiece BCIsButton = "btn" - toPathPiece bClass = ("btn-" <>) . camelToPathPiece' 1 $ tshow bClass - fromPathPiece = flip List.lookup $ map (toPathPiece &&& id) universeF - -instance Button UniWorX ButtonSubmit where - btnClasses BtnSubmit = [BCIsButton, BCPrimary] - - - --- Please see the documentation for the Yesod typeclass. There are a number --- of settings which can be configured by overriding methods here. -instance Yesod UniWorX where - -- Controls the base of generated URLs. For more information on modifying, - -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot - approot = ApprootRequest $ \app req -> - case app ^. _appRoot of - Nothing -> getApprootText guessApproot app req - Just root -> root - - makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notForBearer . sameSite $ case appSessionStore of - SessionStorageMemcachedSql sqlStore - -> mkBackend . stateSettings =<< ServerSession.createState sqlStore - SessionStorageAcid acidStore - | appServerSessionAcidFallback - -> mkBackend . stateSettings =<< ServerSession.createState acidStore - _other - -> return Nothing - where - cfg = JwtSession.ServerSessionJwtConfig - { sJwtJwkSet = appJSONWebKeySet - , sJwtStart = Nothing - , sJwtExpiration = appSessionTokenExpiration - , sJwtEncoding = appSessionTokenEncoding - , sJwtIssueBy = appInstanceID - , sJwtIssueFor = appClusterID - } - mkBackend :: forall sto. - ( ServerSession.SessionData sto ~ Map Text ByteString - , ServerSession.Storage sto - ) - => ServerSession.State sto -> IO (Maybe SessionBackend) - mkBackend = JwtSession.backend cfg (JwtSession.siteApproot app) - stateSettings :: forall sto. ServerSession.State sto -> ServerSession.State sto - stateSettings = ServerSession.setCookieName (toPathPiece CookieSession) . applyServerSessionSettings appServerSessionConfig - sameSite - | Just sameSiteStrict == cookieSameSite (getCookieSettings app CookieSession) - = strictSameSiteSessions - | Just sameSiteLax == cookieSameSite (getCookieSettings app CookieSession) - = laxSameSiteSessions - | otherwise - = id - notForBearer :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend) - notForBearer = fmap $ fmap notForBearer' - where notForBearer' :: SessionBackend -> SessionBackend - notForBearer' (SessionBackend load) - = let load' req - | aHdrs <- mapMaybe (\(h, v) -> v <$ guard (h == W.hAuthorization)) $ W.requestHeaders req - , any (is _Just . W.extractBearerAuth) aHdrs - = return (mempty, const $ return []) - | otherwise - = load req - in SessionBackend load' - - maximumContentLength app _ = app ^. _appMaximumContentLength - - -- Yesod Middleware allows you to run code before and after each handler function. - -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks. - -- Some users may also want to add the defaultCsrfMiddleware, which: - -- a) Sets a cookie with a CSRF token in it. - -- b) Validates that incoming write requests include that token in either a header or POST parameter. - -- 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 = storeBearerMiddleware . csrfMiddleware . dryRunMiddleware . observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . defaultYesodMiddleware . normalizeRouteMiddleware . updateFavouritesMiddleware - where - dryRunMiddleware :: Handler a -> Handler a - dryRunMiddleware handler = do - dryRun <- isDryRun - if | dryRun -> do - hData <- ask - prevState <- readIORef (handlerState hData) - let - restoreSession = - modifyIORef (handlerState hData) $ - \hst -> hst { ghsSession = ghsSession prevState - , ghsCache = ghsCache prevState - , ghsCacheBy = ghsCacheBy prevState - } - site' = (rheSite $ handlerEnv hData) { appMemcached = Nothing } - handler' = local (\hd -> hd { handlerEnv = (handlerEnv hd) { rheSite = site', rheChild = site' } }) handler - - addCustomHeader HeaderDryRun ("1" :: Text) - - handler' `finally` restoreSession - | otherwise -> handler - updateFavouritesMiddleware :: Handler a -> Handler a - updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do - route <- MaybeT getCurrentRoute - case route of -- update Course Favourites here - CourseR tid ssh csh _ -> do - void . lift . runDB . runMaybeT $ do - guardM . lift $ (== Authorized) <$> evalAccessDB (CourseR tid ssh csh CShowR) False - lift . updateFavourites $ Just (tid, ssh, csh) - _other -> return () - normalizeRouteMiddleware :: Handler a -> Handler a - normalizeRouteMiddleware handler = (*> handler) . runMaybeT $ do - route <- MaybeT getCurrentRoute - (route', getAny -> changed) <- lift . runDB . runWriterT $ foldM (&) route routeNormalizers - when changed $ do - $logDebugS "normalizeRouteMiddleware" [st|Redirecting to #{tshow route'}|] - redirectWith movedPermanently301 route' - headerMessagesMiddleware :: Handler a -> Handler a - headerMessagesMiddleware handler = (handler `finally`) . runMaybeT $ do - isModal <- hasCustomHeader HeaderIsModal - dbTableShortcircuit <- hasCustomHeader HeaderDBTableShortcircuit - massInputShortcircuit <- hasCustomHeader HeaderMassInputShortcircuit - $logDebugS "headerMessagesMiddleware" $ tshow (isModal, dbTableShortcircuit, massInputShortcircuit) - guard $ or - [ isModal - , dbTableShortcircuit - , massInputShortcircuit - ] - - lift . bracketOnError getMessages (mapM_ addMessage') $ - addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict . JSON.encode - observeYesodCacheSizeMiddleware :: Handler a -> Handler a - observeYesodCacheSizeMiddleware handler = handler `finally` observeYesodCacheSize - csrfMiddleware :: Handler a -> Handler a - csrfMiddleware handler = do - hasBearer <- is _Just <$> lookupBearerAuth - - if | hasBearer -> local (\HandlerData{..} -> HandlerData{ handlerRequest = handlerRequest { reqToken = Nothing }, .. }) handler - | otherwise -> csrfSetCookieMiddleware' . defaultCsrfCheckMiddleware $ handler - where - csrfSetCookieMiddleware' handler' = do - mcsrf <- reqToken <$> getRequest - whenIsJust mcsrf $ setRegisteredCookie CookieXSRFToken - handler' - storeBearerMiddleware :: Handler a -> Handler a - storeBearerMiddleware handler = do - askBearer >>= \case - Just (Jwt bs) -> setSessionBS (toPathPiece SessionBearer) bs - Nothing -> return () - - handler - - -- Since we implement `errorHandler` ourselves we don't need `defaultMessageWidget` - defaultMessageWidget _title _body = error "defaultMessageWidget: undefined" - - errorHandler err = do - shouldEncrypt <- do - canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True - shouldEncrypt <- getsYesod $ view _appEncryptErrors - return $ shouldEncrypt && not canDecrypt - - sessErr <- bool return (_InternalError $ encodedSecretBox SecretBoxShort) shouldEncrypt err - setSessionJson SessionError sessErr - - selectRep $ do - provideRep $ do - mr <- getMessageRender - let - encrypted :: ToJSON a => a -> Widget -> Widget - encrypted plaintextJson plaintext = do - if - | shouldEncrypt -> do - ciphertext <- encodedSecretBox SecretBoxPretty plaintextJson - - [whamlet| -

_{MsgErrorResponseEncrypted} - 

-                        #{ciphertext}
-                    |]
-                | otherwise -> plaintext
-
-            errPage = case err of
-              NotFound -> [whamlet|
_{MsgErrorResponseNotFound}|]
-              InternalError err' -> encrypted err' [whamlet|
#{err'}|]
-              InvalidArgs errs -> [whamlet|
-