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