feat(submission): allow restriction of submittors via token

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
+    bearerDryRun = has (_Just . _Object . ix "dry-run") <$> maybeCurrentBearerRestrictions @Value
-      JSON.Object hm -> Just $ HashMap.member "dry-run" hm
-      _other -> Nothing
     bearerRequired = maybeT (return True) . catchIfMaybeT cPred . liftHandler $ do
       mAuthId <- maybeAuthId
       currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute

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