diff --git a/src/Foundation.hs b/src/Foundation.hs index 97325ec8f..a02f1d10c 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -92,6 +92,7 @@ import Data.Bits (Bits(zeroBits)) import Network.Wai.Parse (lbsBackEnd) import qualified Data.Aeson as JSON +import Data.Aeson.Lens hiding (_Value, key) import Data.FileEmbed (embedFile) @@ -402,7 +403,8 @@ requireBearerToken = liftHandler $ do guardAuthResult <=< runDBRead $ validateBearer mAuthId currentRoute isWrite bearer return bearer -requireCurrentBearerRestrictions :: ( MonadHandler m +requireCurrentBearerRestrictions :: forall a m. + ( MonadHandler m , HandlerSite m ~ UniWorX , FromJSON a , ToJSON a @@ -413,7 +415,8 @@ requireCurrentBearerRestrictions = runMaybeT $ do route <- MaybeT getCurrentRoute hoistMaybe $ bearer ^? _bearerRestrictionIx route -maybeCurrentBearerRestrictions :: ( MonadHandler m +maybeCurrentBearerRestrictions :: forall a m. + ( MonadHandler m , HandlerSite m ~ UniWorX , MonadCatch m , FromJSON a @@ -437,9 +440,7 @@ isDryRun = $cachedHere $ orM , and2M bearerDryRun bearerRequired ] where - bearerDryRun = maybeT (return False) $ MaybeT maybeCurrentBearerRestrictions >>= hoistMaybe . \case - JSON.Object hm -> Just $ HashMap.member "dry-run" hm - _other -> Nothing + bearerDryRun = has (_Just . _Object . ix "dry-run") <$> maybeCurrentBearerRestrictions @Value bearerRequired = maybeT (return True) . catchIfMaybeT cPred . liftHandler $ do mAuthId <- maybeAuthId currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index cdaf46ca8..b3ce95818 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -46,6 +46,8 @@ import qualified Data.Text as Text import Text.Blaze (Markup) import Data.Aeson hiding (Result(..)) +import qualified Data.Aeson.Types as JSON +import Data.Aeson.Lens import Text.Hamlet (ihamlet) import qualified Data.HashSet as HashSet @@ -138,7 +140,7 @@ submissionUserInvitationConfig = InvitationConfig{..} makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe FileUploads, Set (Either UserEmail UserId)) makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = identifyForm FIDsubmission . renderAForm FormStandard $ (,) <$> fileUploadForm (not isLecturer && is _Nothing msmid) (fslI . bool MsgSubmissionFile MsgSubmissionArchive) uploadMode - <*> wFormToAForm submittorsForm + <*> wFormToAForm submittorsForm' where miCell' :: Markup -> Either UserEmail UserId -> Widget miCell' csrf (Left email) = do @@ -205,6 +207,13 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident miButtonAction' :: forall p. PathPiece p => Maybe (Route UniWorX) -> p -> Maybe (SomeRoute UniWorX) miButtonAction' mCurrent frag = mCurrent <&> \current -> SomeRoute (current :#: frag) + submittorsForm' = maybeT submittorsForm $ do + restr <- MaybeT (maybeCurrentBearerRestrictions @Value) >>= hoistMaybe . preview (_Object . ix "submittors" . _Array) + let _Submittor = prism (either toJSON toJSON) $ \x -> first (const x) $ JSON.parseEither (\x' -> fmap Right (parseJSON x') <|> fmap Left (parseJSON x')) x + submittors <- fmap (pure @FormResult @([Either UserEmail CryptoUUIDUser])) . forM (toList restr) $ hoistMaybe . preview _Submittor + fmap Set.fromList <$> forMOf (traverse . traverse . _Right) submittors decrypt + + submittorsForm | isLecturer = do -- Form is being used by lecturer; allow Everything™ let