Improve AuthPred memoisation
This commit is contained in:
Gregor Kleen
parent
8bf9e44c82
commit
710b591b4a
@ -60,7 +60,7 @@ import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
import Control.Monad.Trans.Reader (runReader, mapReaderT)
|
||||
import Control.Monad.Trans.Writer (WriterT(..), runWriterT)
|
||||
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 Handler.Utils.StudyFeatures
|
||||
@ -137,6 +137,8 @@ type SMTPPool = Pool SMTPConnection
|
||||
-- type Widget = WidgetT UniWorX IO ()
|
||||
mkYesodData "UniWorX" $(parseRoutesFile "routes")
|
||||
|
||||
deriving instance Generic (Route UniWorX)
|
||||
|
||||
-- | Convenient Type Synonyms:
|
||||
type DB a = YesodDB UniWorX a
|
||||
type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
|
||||
@ -385,24 +387,24 @@ appLanguagesOpts = do
|
||||
|
||||
-- Access Control
|
||||
data AccessPredicate
|
||||
= APPure (Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
|
||||
| APHandler (Route UniWorX -> Bool -> Handler AuthResult)
|
||||
| APDB (Route UniWorX -> Bool -> DB AuthResult)
|
||||
= 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 -> DB AuthResult)
|
||||
|
||||
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
|
||||
evalAccessPred aPred r w = liftHandlerT $ case aPred of
|
||||
(APPure p) -> runReader (p r w) <$> getMsgRenderer
|
||||
(APHandler p) -> p r w
|
||||
(APDB p) -> runDB $ p r w
|
||||
evalAccessPred aPred aid r w = liftHandlerT $ case aPred of
|
||||
(APPure p) -> runReader (p aid r w) <$> getMsgRenderer
|
||||
(APHandler p) -> p aid r w
|
||||
(APDB p) -> runDB $ p aid r w
|
||||
|
||||
instance (MonadHandler m, HandlerSite m ~ UniWorX, backend ~ YesodPersistBackend UniWorX) => MonadAP (ReaderT backend m) where
|
||||
evalAccessPred aPred r w = mapReaderT liftHandlerT $ case aPred of
|
||||
(APPure p) -> lift $ runReader (p r w) <$> getMsgRenderer
|
||||
(APHandler p) -> lift $ p r w
|
||||
(APDB p) -> p r w
|
||||
evalAccessPred aPred aid r w = mapReaderT liftHandlerT $ 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
|
||||
@ -423,16 +425,16 @@ trueAR = const Authorized
|
||||
falseAR = Unauthorized . ($ MsgUnauthorized) . render
|
||||
|
||||
trueAP, falseAP :: AccessPredicate
|
||||
trueAP = APPure . const . const $ trueAR <$> ask
|
||||
falseAP = APPure . const . const $ falseAR <$> ask -- included for completeness
|
||||
trueAP = APPure . const . const . const $ trueAR <$> ask
|
||||
falseAP = APPure . const . const . const $ falseAR <$> ask -- included for completeness
|
||||
|
||||
|
||||
tagAccessPredicate :: AuthTag -> AccessPredicate
|
||||
tagAccessPredicate AuthFree = trueAP
|
||||
tagAccessPredicate AuthAdmin = APDB $ \route _ -> case route of
|
||||
tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
|
||||
-- Courses: access only to school admins
|
||||
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.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool
|
||||
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId
|
||||
@ -444,13 +446,13 @@ tagAccessPredicate AuthAdmin = APDB $ \route _ -> case route of
|
||||
return Authorized
|
||||
-- other routes: access to any admin is granted here
|
||||
_other -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
|
||||
guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
|
||||
return Authorized
|
||||
tagAccessPredicate AuthNoEscalation = APDB $ \route _ -> case route of
|
||||
tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
|
||||
AdminHijackUserR cID -> exceptT return return $ do
|
||||
myUid <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
myUid <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
uid <- decrypt cID
|
||||
otherSchoolsAdmin <- lift $ Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. 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)
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthNoEscalation r
|
||||
tagAccessPredicate AuthDeprecated = APHandler $ \r _ -> do
|
||||
tagAccessPredicate AuthDeprecated = APHandler $ \_ r _ -> do
|
||||
$logWarnS "AccessControl" ("deprecated route: " <> tshow r)
|
||||
addMessageI Error MsgDeprecatedRoute
|
||||
allow <- appAllowDeprecated . appSettings <$> getYesod
|
||||
return $ bool (Unauthorized "Deprecated Route") Authorized allow
|
||||
tagAccessPredicate AuthDevelopment = APHandler $ \r _ -> do
|
||||
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 $ \route _ -> case route of
|
||||
tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of
|
||||
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.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
|
||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
|
||||
@ -484,11 +486,11 @@ tagAccessPredicate AuthLecturer = APDB $ \route _ -> case route of
|
||||
return Authorized
|
||||
-- lecturer for any school will do
|
||||
_ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] []
|
||||
return Authorized
|
||||
tagAccessPredicate AuthCorrector = APDB $ \route _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
resList <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
|
||||
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
|
||||
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
||||
@ -515,7 +517,7 @@ tagAccessPredicate AuthCorrector = APDB $ \route _ -> exceptT return return $ do
|
||||
_ -> do
|
||||
guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
|
||||
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
|
||||
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
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
|
||||
now <- liftIO getCurrentTime
|
||||
mbc <- getBy $ TermSchoolCourseShort tid ssh csh
|
||||
mAid <- lift maybeAuthId
|
||||
registered <- case (mbc,mAid) of
|
||||
registered <- case (mbc,mAuthId) of
|
||||
(Just (Entity cid _), Just uid) -> isJust <$> (getBy $ UniqueParticipant uid cid)
|
||||
_ -> return False
|
||||
case mbc of
|
||||
@ -564,9 +565,9 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
|
||||
return Authorized
|
||||
|
||||
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
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
|
||||
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
|
||||
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId
|
||||
@ -577,7 +578,7 @@ tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of
|
||||
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered)
|
||||
return Authorized
|
||||
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
|
||||
let authorizedIfExists f = do
|
||||
[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
|
||||
unauthorizedI MsgUnauthorizedParticipant
|
||||
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
|
||||
Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
|
||||
guard $ NTop courseCapacity > NTop (Just registered)
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthCapacity r
|
||||
tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of
|
||||
tagAccessPredicate AuthEmpty = APDB $ \_ route _ -> case route of
|
||||
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
|
||||
-- Entity cid Course{..} <- MaybeT . getBy $ 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 Authorized
|
||||
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
|
||||
Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
guard courseMaterialFree
|
||||
return Authorized
|
||||
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
|
||||
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
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthOwner r
|
||||
tagAccessPredicate AuthRated = APDB $ \route _ -> case route of
|
||||
tagAccessPredicate AuthRated = APDB $ \_ route _ -> case route of
|
||||
CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
|
||||
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
sub <- MaybeT $ get sid
|
||||
guard $ submissionRatingDone sub
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate 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
|
||||
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
|
||||
guard $ sheetSubmissionMode == UserSubmissions
|
||||
return Authorized
|
||||
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
|
||||
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
|
||||
guard $ sheetSubmissionMode == CorrectorSubmissions
|
||||
return Authorized
|
||||
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
|
||||
smId <- decrypt cID
|
||||
SystemMessage{..} <- MaybeT $ get smId
|
||||
isAuthenticated <- isJust <$> liftHandlerT maybeAuthId
|
||||
let isAuthenticated = isJust mAuthId
|
||||
guard $ not systemMessageAuthenticatedOnly || isAuthenticated
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthAuthentication r
|
||||
tagAccessPredicate AuthRead = APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)
|
||||
tagAccessPredicate AuthWrite = APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
|
||||
tagAccessPredicate AuthRead = APHandler . const . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)
|
||||
tagAccessPredicate AuthWrite = APHandler . const . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
|
||||
|
||||
|
||||
newtype InvalidAuthTag = InvalidAuthTag Text
|
||||
@ -734,25 +735,29 @@ routeAuthTags = fmap (impureNonNull . Set.mapMonotonic impureNonNull) . ofoldM p
|
||||
| otherwise
|
||||
= 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
|
||||
evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . toNullable -> authDNF) route isWrite
|
||||
= startEvalMemoT $ do
|
||||
mr <- lift getMsgRenderer
|
||||
evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . toNullable -> authDNF) mAuthId route isWrite
|
||||
= do
|
||||
mr <- getMsgRenderer
|
||||
let
|
||||
authTagIsInactive = not . authTagIsActive
|
||||
|
||||
evalAuthTag :: AuthTag -> MemoT AuthTag AuthResult (WriterT (Set AuthTag) m) AuthResult
|
||||
evalAuthTag = memo $ \authTag -> lift . lift $ evalAccessPred (tagAccessPredicate authTag) route isWrite
|
||||
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' = 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' = shortCircuitM (is _Authorized) (orAR 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)
|
||||
|
||||
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
|
||||
|
||||
@ -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
|
||||
let pivots = filter authTagIsInactive conj
|
||||
whenM (allM pivots $ fmap (is _Authorized) . evalAuthTag) $ do
|
||||
lift $ $logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots}|]
|
||||
lift . tell $ Set.fromList pivots
|
||||
$logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots}|]
|
||||
tell $ Set.fromList pivots
|
||||
|
||||
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 route isWrite = do
|
||||
mAuthId <- liftHandlerT maybeAuthId
|
||||
tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
|
||||
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
|
||||
|
||||
evalAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
|
||||
|
||||
@ -17,7 +17,7 @@ import Yesod.Default.Config2 as Import
|
||||
import Utils as Import
|
||||
import Utils.Modal as Import
|
||||
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
|
||||
|
||||
@ -749,6 +749,8 @@ instance ToJSONKey AuthTag where
|
||||
instance FromJSONKey AuthTag where
|
||||
fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String
|
||||
|
||||
instance Binary AuthTag
|
||||
|
||||
|
||||
newtype AuthTagActive = AuthTagActive { authTagIsActive :: AuthTag -> Bool }
|
||||
deriving (Read, Show, Generic)
|
||||
|
||||
@ -15,37 +15,58 @@ import Data.ByteString.Builder (toLazyByteString)
|
||||
import System.FilePath ((</>))
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Types
|
||||
|
||||
import Control.Monad.Fix
|
||||
import Control.Monad.Fail (MonadFail)
|
||||
import qualified Control.Monad.Fail as MonadFail
|
||||
import Control.Monad.Except (MonadError(..))
|
||||
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
|
||||
fromPathPiece
|
||||
= parseRoute
|
||||
. 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
|
||||
fromPathPiece = routeFromPathPiece
|
||||
toPathPiece = routeToPathPiece
|
||||
|
||||
instance (RenderRoute site, ParseRoute site) => FromJSON (Route site) where
|
||||
parseJSON = withText "Route" $ maybe (fail "Could not parse route") return . fromPathPiece
|
||||
instance ParseRoute site => FromJSON (Route site) where
|
||||
parseJSON = withText "Route" $ maybe (fail "Could not parse route") return . routeFromPathPiece
|
||||
|
||||
instance (RenderRoute site, ParseRoute site) => ToJSON (Route site) where
|
||||
toJSON = String . toPathPiece
|
||||
instance RenderRoute site => ToJSON (Route site) where
|
||||
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
|
||||
@ -77,3 +98,5 @@ instance Extend FormResult where
|
||||
duplicated (FormSuccess x) = FormSuccess $ FormSuccess x
|
||||
duplicated FormMissing = FormMissing
|
||||
duplicated (FormFailure errs) = FormFailure errs
|
||||
|
||||
|
||||
|
||||
@ -1,16 +1,48 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-}
|
||||
|
||||
module Yesod.Core.Types.Instances
|
||||
(
|
||||
( CachedMemoT(..)
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
import ClassyPrelude.Yesod
|
||||
import Yesod.Core.Types
|
||||
|
||||
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
|
||||
mfix f = HandlerT $ \r -> mfix $ \a -> unHandlerT (f a) r
|
||||
|
||||
instance MonadFix m => MonadFix (WidgetT site m) where
|
||||
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
11
start.sh
@ -1,12 +1,11 @@
|
||||
#!/usr/bin/env bash
|
||||
|
||||
unset HOST
|
||||
export DETAILED_LOGGING=true
|
||||
export LOG_ALL=false
|
||||
export LOGLEVEL=info
|
||||
export DUMMY_LOGIN=true
|
||||
export ALLOW_DEPRECATED=true
|
||||
export PWFILE=users.yml
|
||||
export DETAILED_LOGGING=${DETAILED_LOGGIN:-true}
|
||||
export LOG_ALL=${LOG_ALL:-false}
|
||||
export LOGLEVEL=${LOGLEVEL:-info}
|
||||
export DUMMY_LOGIN=${DUMMY_LOGIN:-true}
|
||||
export ALLOW_DEPRECATED=${ALLOW_DEPRECATED:-true}
|
||||
|
||||
move-back() {
|
||||
mv -v .stack-work .stack-work-run
|
||||
|
||||
Loading…
Reference in New Issue
Block a user