fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Improve AuthPred memoisation

Browse Source
This commit is contained in:
Gregor Kleen 2019-04-03 22:07:30 +02:00
parent 8bf9e44c82
commit 710b591b4a
6 changed files with 156 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

126
src/Foundation.hs
View File

@ -60,7 +60,7 @@ import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Trans.Reader (runReader, mapReaderT) import Control.Monad.Trans.Reader (runReader, mapReaderT)
import Control.Monad.Trans.Writer (WriterT(..), runWriterT) import Control.Monad.Trans.Writer (WriterT(..), runWriterT)
import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Memo (MemoT, startEvalMemoT, MonadMemo(..)) import Control.Monad.Memo.Class (MonadMemo(..), for4)
import qualified Control.Monad.Catch as C import qualified Control.Monad.Catch as C
import Handler.Utils.StudyFeatures import Handler.Utils.StudyFeatures
@ -137,6 +137,8 @@ type SMTPPool = Pool SMTPConnection
-- type Widget = WidgetT UniWorX IO () -- type Widget = WidgetT UniWorX IO ()
mkYesodData "UniWorX" $(parseRoutesFile "routes") mkYesodData "UniWorX" $(parseRoutesFile "routes")
deriving instance Generic (Route UniWorX)
-- | Convenient Type Synonyms: -- | Convenient Type Synonyms:
type DB a = YesodDB UniWorX a type DB a = YesodDB UniWorX a
type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget) type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
@ -385,24 +387,24 @@ appLanguagesOpts = do
-- Access Control -- Access Control
data AccessPredicate data AccessPredicate
= APPure (Route UniWorX -> Bool -> Reader MsgRenderer AuthResult) = APPure (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
| APHandler (Route UniWorX -> Bool -> Handler AuthResult) | APHandler (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Handler AuthResult)
| APDB (Route UniWorX -> Bool -> DB AuthResult) | APDB (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> DB AuthResult)
class (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where class (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where
evalAccessPred :: AccessPredicate -> Route UniWorX -> Bool -> m AuthResult evalAccessPred :: AccessPredicate -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where
evalAccessPred aPred r w = liftHandlerT $ case aPred of evalAccessPred aPred aid r w = liftHandlerT $ case aPred of
(APPure p) -> runReader (p r w) <$> getMsgRenderer (APPure p) -> runReader (p aid r w) <$> getMsgRenderer
(APHandler p) -> p r w (APHandler p) -> p aid r w
(APDB p) -> runDB $ p r w (APDB p) -> runDB $ p aid r w
instance (MonadHandler m, HandlerSite m ~ UniWorX, backend ~ YesodPersistBackend UniWorX) => MonadAP (ReaderT backend m) where instance (MonadHandler m, HandlerSite m ~ UniWorX, backend ~ YesodPersistBackend UniWorX) => MonadAP (ReaderT backend m) where
evalAccessPred aPred r w = mapReaderT liftHandlerT $ case aPred of evalAccessPred aPred aid r w = mapReaderT liftHandlerT $ case aPred of
(APPure p) -> lift $ runReader (p r w) <$> getMsgRenderer (APPure p) -> lift $ runReader (p aid r w) <$> getMsgRenderer
(APHandler p) -> lift $ p r w (APHandler p) -> lift $ p aid r w
(APDB p) -> p r w (APDB p) -> p aid r w
orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult
@ -423,16 +425,16 @@ trueAR = const Authorized
falseAR = Unauthorized . ($ MsgUnauthorized) . render falseAR = Unauthorized . ($ MsgUnauthorized) . render
trueAP, falseAP :: AccessPredicate trueAP, falseAP :: AccessPredicate
trueAP = APPure . const . const $ trueAR <$> ask trueAP = APPure . const . const . const $ trueAR <$> ask
falseAP = APPure . const . const $ falseAR <$> ask -- included for completeness falseAP = APPure . const . const . const $ falseAR <$> ask -- included for completeness
tagAccessPredicate :: AuthTag -> AccessPredicate tagAccessPredicate :: AuthTag -> AccessPredicate
tagAccessPredicate AuthFree = trueAP tagAccessPredicate AuthFree = trueAP
tagAccessPredicate AuthAdmin = APDB $ \route _ -> case route of tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
-- Courses: access only to school admins -- Courses: access only to school admins
CourseR tid ssh csh _ -> exceptT return return $ do CourseR tid ssh csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do
E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId
@ -444,13 +446,13 @@ tagAccessPredicate AuthAdmin = APDB $ \route _ -> case route of
return Authorized return Authorized
-- other routes: access to any admin is granted here -- other routes: access to any admin is granted here
_other -> exceptT return return $ do _other -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
adrights <- lift $ selectFirst [UserAdminUser ==. authId] [] adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin) guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
return Authorized return Authorized
tagAccessPredicate AuthNoEscalation = APDB $ \route _ -> case route of tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
AdminHijackUserR cID -> exceptT return return $ do AdminHijackUserR cID -> exceptT return return $ do
myUid <- maybeExceptT AuthenticationRequired $ lift maybeAuthId myUid <- maybeExceptT AuthenticationRequired $ return mAuthId
uid <- decrypt cID uid <- decrypt cID
otherSchoolsAdmin <- lift $ Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] [] otherSchoolsAdmin <- lift $ Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] []
otherSchoolsLecturer <- lift $ Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] [] otherSchoolsLecturer <- lift $ Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] []
@ -458,21 +460,21 @@ tagAccessPredicate AuthNoEscalation = APDB $ \route _ -> case route of
guardMExceptT ((otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation) guardMExceptT ((otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation)
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthNoEscalation r r -> $unsupportedAuthPredicate AuthNoEscalation r
tagAccessPredicate AuthDeprecated = APHandler $ \r _ -> do tagAccessPredicate AuthDeprecated = APHandler $ \_ r _ -> do
$logWarnS "AccessControl" ("deprecated route: " <> tshow r) $logWarnS "AccessControl" ("deprecated route: " <> tshow r)
addMessageI Error MsgDeprecatedRoute addMessageI Error MsgDeprecatedRoute
allow <- appAllowDeprecated . appSettings <$> getYesod allow <- appAllowDeprecated . appSettings <$> getYesod
return $ bool (Unauthorized "Deprecated Route") Authorized allow return $ bool (Unauthorized "Deprecated Route") Authorized allow
tagAccessPredicate AuthDevelopment = APHandler $ \r _ -> do tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do
$logWarnS "AccessControl" ("route in development: " <> tshow r) $logWarnS "AccessControl" ("route in development: " <> tshow r)
#ifdef DEVELOPMENT #ifdef DEVELOPMENT
return Authorized return Authorized
#else #else
return $ Unauthorized "Route under development" return $ Unauthorized "Route under development"
#endif #endif
tagAccessPredicate AuthLecturer = APDB $ \route _ -> case route of tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of
CourseR tid ssh csh _ -> exceptT return return $ do CourseR tid ssh csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
@ -484,11 +486,11 @@ tagAccessPredicate AuthLecturer = APDB $ \route _ -> case route of
return Authorized return Authorized
-- lecturer for any school will do -- lecturer for any school will do
_ -> exceptT return return $ do _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] [] void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] []
return Authorized return Authorized
tagAccessPredicate AuthCorrector = APDB $ \route _ -> exceptT return return $ do tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
resList <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do resList <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
@ -515,7 +517,7 @@ tagAccessPredicate AuthCorrector = APDB $ \route _ -> exceptT return return $ do
_ -> do _ -> do
guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny) guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
return Authorized return Authorized
tagAccessPredicate AuthTime = APDB $ \route _ -> case route of tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
@ -541,8 +543,7 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
CourseR tid ssh csh CRegisterR -> do CourseR tid ssh csh CRegisterR -> do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
mbc <- getBy $ TermSchoolCourseShort tid ssh csh mbc <- getBy $ TermSchoolCourseShort tid ssh csh
mAid <- lift maybeAuthId registered <- case (mbc,mAuthId) of
registered <- case (mbc,mAid) of
(Just (Entity cid _), Just uid) -> isJust <$> (getBy $ UniqueParticipant uid cid) (Just (Entity cid _), Just uid) -> isJust <$> (getBy $ UniqueParticipant uid cid)
_ -> return False _ -> return False
case mbc of case mbc of
@ -564,9 +565,9 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthTime r r -> $unsupportedAuthPredicate AuthTime r
tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of tagAccessPredicate AuthRegistered = APDB $ \mAuthId route _ -> case route of
CourseR tid ssh csh _ -> exceptT return return $ do CourseR tid ssh csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId
@ -577,7 +578,7 @@ tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered) guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered)
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthRegistered r r -> $unsupportedAuthPredicate AuthRegistered r
tagAccessPredicate AuthParticipant = APDB $ \route _ -> case route of tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do
let authorizedIfExists f = do let authorizedIfExists f = do
[E.Value ok] <- lift . E.select . return . E.exists $ E.from f [E.Value ok] <- lift . E.select . return . E.exists $ E.from f
@ -639,14 +640,14 @@ tagAccessPredicate AuthParticipant = APDB $ \route _ -> case route of
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
unauthorizedI MsgUnauthorizedParticipant unauthorizedI MsgUnauthorizedParticipant
r -> $unsupportedAuthPredicate AuthParticipant r r -> $unsupportedAuthPredicate AuthParticipant r
tagAccessPredicate AuthCapacity = APDB $ \route _ -> case route of tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do
Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
guard $ NTop courseCapacity > NTop (Just registered) guard $ NTop courseCapacity > NTop (Just registered)
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthCapacity r r -> $unsupportedAuthPredicate AuthCapacity r
tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of tagAccessPredicate AuthEmpty = APDB $ \_ route _ -> case route of
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
-- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
@ -657,50 +658,50 @@ tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of
return E.countRows return E.countRows
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthEmpty r r -> $unsupportedAuthPredicate AuthEmpty r
tagAccessPredicate AuthMaterials = APDB $ \route _ -> case route of tagAccessPredicate AuthMaterials = APDB $ \_ route _ -> case route of
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
guard courseMaterialFree guard courseMaterialFree
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthMaterials r r -> $unsupportedAuthPredicate AuthMaterials r
tagAccessPredicate AuthOwner = APDB $ \route _ -> case route of tagAccessPredicate AuthOwner = APDB $ \mAuthId route _ -> case route of
CSubmissionR _ _ _ _ cID _ -> exceptT return return $ do CSubmissionR _ _ _ _ cID _ -> exceptT return return $ do
sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthOwner r r -> $unsupportedAuthPredicate AuthOwner r
tagAccessPredicate AuthRated = APDB $ \route _ -> case route of tagAccessPredicate AuthRated = APDB $ \_ route _ -> case route of
CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
sub <- MaybeT $ get sid sub <- MaybeT $ get sid
guard $ submissionRatingDone sub guard $ submissionRatingDone sub
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthRated r r -> $unsupportedAuthPredicate AuthRated r
tagAccessPredicate AuthUserSubmissions = APDB $ \route _ -> case route of tagAccessPredicate AuthUserSubmissions = APDB $ \_ route _ -> case route of
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
guard $ sheetSubmissionMode == UserSubmissions guard $ sheetSubmissionMode == UserSubmissions
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthUserSubmissions r r -> $unsupportedAuthPredicate AuthUserSubmissions r
tagAccessPredicate AuthCorrectorSubmissions = APDB $ \route _ -> case route of tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
guard $ sheetSubmissionMode == CorrectorSubmissions guard $ sheetSubmissionMode == CorrectorSubmissions
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r
tagAccessPredicate AuthAuthentication = APDB $ \route _ -> case route of tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
smId <- decrypt cID smId <- decrypt cID
SystemMessage{..} <- MaybeT $ get smId SystemMessage{..} <- MaybeT $ get smId
isAuthenticated <- isJust <$> liftHandlerT maybeAuthId let isAuthenticated = isJust mAuthId
guard $ not systemMessageAuthenticatedOnly || isAuthenticated guard $ not systemMessageAuthenticatedOnly || isAuthenticated
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthAuthentication r r -> $unsupportedAuthPredicate AuthAuthentication r
tagAccessPredicate AuthRead = APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite) tagAccessPredicate AuthRead = APHandler . const . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)
tagAccessPredicate AuthWrite = APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized) tagAccessPredicate AuthWrite = APHandler . const . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
newtype InvalidAuthTag = InvalidAuthTag Text newtype InvalidAuthTag = InvalidAuthTag Text
@ -734,25 +735,29 @@ routeAuthTags = fmap (impureNonNull . Set.mapMonotonic impureNonNull) . ofoldM p
| otherwise | otherwise
= Left $ InvalidAuthTag t = Left $ InvalidAuthTag t
evalAuthTags :: forall m. (MonadAP m, MonadLogger m) => AuthTagActive -> NonNull (DNF AuthTag) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult evalAuthTags :: forall m. (MonadAP m, MonadLogger m) => AuthTagActive -> NonNull (DNF AuthTag) -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
-- ^ `tell`s disabled predicates, identified as pivots -- ^ `tell`s disabled predicates, identified as pivots
evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . toNullable -> authDNF) route isWrite evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . toNullable -> authDNF) mAuthId route isWrite
= startEvalMemoT $ do = do
mr <- lift getMsgRenderer mr <- getMsgRenderer
let let
authTagIsInactive = not . authTagIsActive authTagIsInactive = not . authTagIsActive
evalAuthTag :: AuthTag -> MemoT AuthTag AuthResult (WriterT (Set AuthTag) m) AuthResult evalAuthTag :: AuthTag -> WriterT (Set AuthTag) m AuthResult
evalAuthTag = memo $ \authTag -> lift . lift $ evalAccessPred (tagAccessPredicate authTag) route isWrite 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' = CachedMemoT $ do
$logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite')
evalAccessPred (tagAccessPredicate authTag') mAuthId' route' isWrite'
orAR', andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult orAR', andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
orAR' = shortCircuitM (is _Authorized) (orAR mr) orAR' = shortCircuitM (is _Authorized) (orAR mr)
andAR' = shortCircuitM (is _Unauthorized) (andAR mr) andAR' = shortCircuitM (is _Unauthorized) (andAR mr)
evalDNF :: [[AuthTag]] -> MemoT AuthTag AuthResult (WriterT (Set AuthTag) m) AuthResult evalDNF :: [[AuthTag]] -> WriterT (Set AuthTag) m AuthResult
evalDNF = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthTag aTag) (return $ trueAR mr) ats) (return $ falseAR mr) evalDNF = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthTag aTag) (return $ trueAR mr) ats) (return $ falseAR mr)
lift . $logDebugS "evalAuthTags" . tshow . (route, isWrite, )$ map (map $ id &&& authTagIsActive) authDNF $logDebugS "evalAuthTags" . tshow . (route, isWrite, )$ map (map $ id &&& authTagIsActive) authDNF
result <- evalDNF $ filter (all authTagIsActive) authDNF result <- evalDNF $ filter (all authTagIsActive) authDNF
@ -760,16 +765,25 @@ evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . toN
whenM (allM conj (\aTag -> (return . not $ authTagIsActive aTag) `or2M` (not . is _Unauthorized <$> evalAuthTag aTag))) $ do whenM (allM conj (\aTag -> (return . not $ authTagIsActive aTag) `or2M` (not . is _Unauthorized <$> evalAuthTag aTag))) $ do
let pivots = filter authTagIsInactive conj let pivots = filter authTagIsInactive conj
whenM (allM pivots $ fmap (is _Authorized) . evalAuthTag) $ do whenM (allM pivots $ fmap (is _Authorized) . evalAuthTag) $ do
lift $ $logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots}|] $logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots}|]
lift . tell $ Set.fromList pivots tell $ Set.fromList pivots
return result return result
evalAccessFor :: (MonadLogger 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 :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
evalAccessForDB = evalAccessFor
evalAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult evalAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult
evalAccess route isWrite = do evalAccess route isWrite = do
mAuthId <- liftHandlerT maybeAuthId
tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
dnf <- either throwM return $ routeAuthTags route dnf <- either throwM return $ routeAuthTags route
(result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf route isWrite (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf mAuthId route isWrite
result <$ tellSessionJson SessionInactiveAuthTags deactivated result <$ tellSessionJson SessionInactiveAuthTags deactivated
evalAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult evalAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult

2
src/Import/NoFoundation.hs
View File

@ -17,7 +17,7 @@ import Yesod.Default.Config2 as Import
import Utils as Import import Utils as Import
import Utils.Modal as Import import Utils.Modal as Import
import Yesod.Core.Json as Import (provideJson) import Yesod.Core.Json as Import (provideJson)
import Yesod.Core.Types.Instances as Import () import Yesod.Core.Types.Instances as Import (CachedMemoT(..))
import Data.Fixed as Import import Data.Fixed as Import

2
src/Model/Types.hs
View File

@ -749,6 +749,8 @@ instance ToJSONKey AuthTag where
instance FromJSONKey AuthTag where instance FromJSONKey AuthTag where
fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String
instance Binary AuthTag
newtype AuthTagActive = AuthTagActive { authTagIsActive :: AuthTag -> Bool } newtype AuthTagActive = AuthTagActive { authTagIsActive :: AuthTag -> Bool }
deriving (Read, Show, Generic) deriving (Read, Show, Generic)

65
src/Yesod/Core/Instances.hs
View File

@ -15,37 +15,58 @@ import Data.ByteString.Builder (toLazyByteString)
import System.FilePath ((</>)) import System.FilePath ((</>))
import Data.Aeson import Data.Aeson
import Data.Aeson.Types
import Control.Monad.Fix import Control.Monad.Fix
import Control.Monad.Fail (MonadFail) import Control.Monad.Fail (MonadFail)
import qualified Control.Monad.Fail as MonadFail import qualified Control.Monad.Fail as MonadFail
import Control.Monad.Except (MonadError(..)) import Control.Monad.Except (MonadError(..))
import Data.Functor.Extend import Data.Functor.Extend
import Data.Binary (Binary)
import qualified Data.Binary as Binary
routeFromPathPiece :: ParseRoute site => Text -> Maybe (Route site)
routeFromPathPiece
= parseRoute
. over (_2.traverse._2) (fromMaybe "")
. over _2 queryToQueryText
. decodePath
. encodeUtf8
routeToPathPiece :: RenderRoute site => Route site -> Text
routeToPathPiece
= pack
. ("/" </>)
. unpack
. decodeUtf8
. toLazyByteString
. uncurry encodePath
. over _2 queryTextToQuery
. over (_2.traverse._2) (assertM' $ not . null)
. renderRoute
instance (RenderRoute site, ParseRoute site) => PathPiece (Route site) where instance (RenderRoute site, ParseRoute site) => PathPiece (Route site) where
fromPathPiece fromPathPiece = routeFromPathPiece
= parseRoute toPathPiece = routeToPathPiece
. over (_2.traverse._2) (fromMaybe "")
. over _2 queryToQueryText
. decodePath
. encodeUtf8
toPathPiece
= pack
. ("/" </>)
. unpack
. decodeUtf8
. toLazyByteString
. uncurry encodePath
. over _2 queryTextToQuery
. over (_2.traverse._2) (assertM' $ not . null)
. renderRoute
instance (RenderRoute site, ParseRoute site) => FromJSON (Route site) where instance ParseRoute site => FromJSON (Route site) where
parseJSON = withText "Route" $ maybe (fail "Could not parse route") return . fromPathPiece parseJSON = withText "Route" $ maybe (fail "Could not parse route") return . routeFromPathPiece
instance (RenderRoute site, ParseRoute site) => ToJSON (Route site) where instance RenderRoute site => ToJSON (Route site) where
toJSON = String . toPathPiece toJSON = String . routeToPathPiece
instance ParseRoute site => FromJSONKey (Route site) where
fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Coulde not parse route") return . routeFromPathPiece
instance RenderRoute site => ToJSONKey (Route site) where
toJSONKey = toJSONKeyText routeToPathPiece
instance (RenderRoute site, ParseRoute site) => Binary (Route site) where
put = Binary.put . toPathPiece
get = Binary.get >>= maybe (fail "Could not parse route") return . fromPathPiece
instance Monad FormResult where instance Monad FormResult where
@ -77,3 +98,5 @@ instance Extend FormResult where
duplicated (FormSuccess x) = FormSuccess $ FormSuccess x duplicated (FormSuccess x) = FormSuccess $ FormSuccess x
duplicated FormMissing = FormMissing duplicated FormMissing = FormMissing
duplicated (FormFailure errs) = FormFailure errs duplicated (FormFailure errs) = FormFailure errs

36
src/Yesod/Core/Types/Instances.hs
View File

@ -1,16 +1,48 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-}
module Yesod.Core.Types.Instances module Yesod.Core.Types.Instances
( ( CachedMemoT(..)
) where ) where
import ClassyPrelude import ClassyPrelude.Yesod
import Yesod.Core.Types import Yesod.Core.Types
import Control.Monad.Fix import Control.Monad.Fix
import Control.Monad.Memo
import Data.Binary (Binary)
import qualified Data.Binary as Binary
import Control.Monad.Logger (MonadLoggerIO)
instance MonadFix m => MonadFix (HandlerT site m) where instance MonadFix m => MonadFix (HandlerT site m) where
mfix f = HandlerT $ \r -> mfix $ \a -> unHandlerT (f a) r mfix f = HandlerT $ \r -> mfix $ \a -> unHandlerT (f a) r
instance MonadFix m => MonadFix (WidgetT site m) where instance MonadFix m => MonadFix (WidgetT site m) where
mfix f = WidgetT $ \r -> mfix $ \ ~(a, _) -> unWidgetT (f a) r mfix f = WidgetT $ \r -> mfix $ \ ~(a, _) -> unWidgetT (f a) r
-- | Type-level tags for compatability of Yesod `cached`-System with `MonadMemo`
newtype CachedMemoT k v m a = CachedMemoT { runCachedMemoT :: m a }
deriving newtype ( Functor, Applicative, Alternative, Monad, MonadPlus, MonadFix
, MonadIO
, MonadThrow, MonadCatch, MonadMask, MonadLogger, MonadLoggerIO
, MonadResource, MonadHandler, MonadWidget
, IsString, Semigroup, Monoid
)
deriving newtype instance MonadBase b m => MonadBase b (CachedMemoT k v m)
deriving newtype instance MonadBaseControl b m => MonadBaseControl b (CachedMemoT k v m)
deriving newtype instance MonadReader r m => MonadReader r (CachedMemoT k v m)
instance MonadTrans (CachedMemoT k v) where
lift = CachedMemoT
-- | Uses `cachedBy` with a `Binary`-encoded @k@
instance (Typeable v, Binary k, MonadHandler m) => MonadMemo k v (CachedMemoT k v m) where
memo act key = cachedBy (toStrict $ Binary.encode key) $ act key

11
start.sh
View File

@ -1,12 +1,11 @@
#!/usr/bin/env bash #!/usr/bin/env bash
unset HOST unset HOST
export DETAILED_LOGGING=true export DETAILED_LOGGING=${DETAILED_LOGGIN:-true}
export LOG_ALL=false export LOG_ALL=${LOG_ALL:-false}
export LOGLEVEL=info export LOGLEVEL=${LOGLEVEL:-info}
export DUMMY_LOGIN=true export DUMMY_LOGIN=${DUMMY_LOGIN:-true}
export ALLOW_DEPRECATED=true export ALLOW_DEPRECATED=${ALLOW_DEPRECATED:-true}
export PWFILE=users.yml
move-back() { move-back() {
mv -v .stack-work .stack-work-run mv -v .stack-work .stack-work-run