From 44776e15065d80e113113bcfe58289d5bbeab939 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 7 Jun 2018 10:29:27 +0200 Subject: [PATCH] refactor SubmissionR --- routes | 4 +++- src/Foundation.hs | 18 ++++++++++++------ src/Handler/CryptoIDDispatch.hs | 2 +- src/Handler/Submission.hs | 31 +++++++++++++++++++++++++++---- 4 files changed, 43 insertions(+), 12 deletions(-) diff --git a/routes b/routes index f864ff89c..450bbcd99 100644 --- a/routes +++ b/routes @@ -50,7 +50,9 @@ /#SheetFileType/#FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector /edit SEditR GET POST /delete SDelR GET POST - !/submission/#SubmissionMode SubmissionR GET POST !timeANDregistered !owner + !/sub/new SubmissionNewR GET POST !timeANDregistered + !/sub/own SubmissionOwnR GET !free + !/sub/#CryptoUUIDSubmission SubmissionR GET POST !owner !corrector !/#UUID CryptoUUIDDispatchR GET !free -- just redirect diff --git a/src/Foundation.hs b/src/Foundation.hs index 3678b20f4..7a11bd875 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -245,7 +245,7 @@ knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId resMap :: Map CourseId (Set SheetId) resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ] case route of - CSheetR _ _ _ (SubmissionR (ExistingSubmission cID)) -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do + CSheetR _ _ _ (SubmissionR cID) -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID Submission{..} <- MaybeT . lift $ get sid guard $ maybe False (== authId) submissionRatingBy @@ -271,7 +271,7 @@ knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId case subRoute of SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom - SubmissionR NewSubmission -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo + SubmissionNewR -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo _ -> guard $ maybe False (<= cTime) sheetVisibleFrom return Authorized r -> do @@ -303,12 +303,12 @@ knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId unauthorizedI MsgUnauthorized ) ,("owner", APDB $ \case - CSheetR _ _ _ (SubmissionR (ExistingSubmission cID)) -> exceptT return return $ do + CSheetR _ _ _ (SubmissionR 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 - CSheetR _ _ _ (SubmissionR NewSubmission) -> unauthorizedI MsgUnauthorizedSubmissionOwner + CSheetR _ _ _ SubmissionNewR -> unauthorizedI MsgUnauthorizedSubmissionOwner r -> do $logErrorS "AccessControl" $ "'!owner' used on route that doesn't support it: " <> tshow r unauthorizedI MsgUnauthorized @@ -652,10 +652,16 @@ pageActions (CourseR tid csh SheetListR) = ] pageActions (CSheetR tid csh shn SShowR) = [ PageActionPrime $ MenuItem + { menuItemLabel = "Abgabe anlegen" + , menuItemIcon = Nothing + , menuItemRoute = CSheetR tid csh shn SubmissionNewR + , menuItemAccessCallback' = return True -- TODO: check that no submission already exists + } + , PageActionPrime $ MenuItem { menuItemLabel = "Abgabe" , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid csh shn (SubmissionR NewSubmission) - , menuItemAccessCallback' = return True + , menuItemRoute = CSheetR tid csh shn SubmissionOwnR + , menuItemAccessCallback' = return True -- TODO: check that a submission already exists } ] pageActions TermShowR = diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs index b02e95a0c..da31ab516 100644 --- a/src/Handler/CryptoIDDispatch.hs +++ b/src/Handler/CryptoIDDispatch.hs @@ -38,7 +38,7 @@ instance CryptoRoute UUID SubmissionId where Sheet{..} <- get404 shid Course{..} <- get404 sheetCourse return (courseTerm, courseShorthand, sheetName) - return $ CSheetR tid csh shn $ SubmissionR $ SubmissionMode $ Just cID + return $ CSheetR tid csh shn $ SubmissionR cID class Dispatch ciphertext (x :: [*]) where diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index becc5ed2c..70ed42d6a 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -74,10 +74,33 @@ makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $ aforced' f fs (Just (Just v)) = Just <$> aforced f fs v aforced' _ _ _ = error "Cannot happen since groupNr==0 if grouping/=Arbitrary" +getSubmissionNewR, postSubmissionNewR :: TermId -> Text -> Text -> Handler Html +getSubmissionNewR = postSubmissionNewR +postSubmissionNewR tid csh shn = submissionHelper tid csh shn NewSubmission -getSubmissionR, postSubmissionR :: TermId -> Text -> Text -> SubmissionMode -> Handler Html + +getSubmissionR, postSubmissionR :: TermId -> Text -> Text -> CryptoUUIDSubmission -> Handler Html getSubmissionR = postSubmissionR -postSubmissionR tid csh shn (SubmissionMode mcid) = do +postSubmissionR tid csh shn cid = submissionHelper tid csh shn $ ExistingSubmission cid + +getSubmissionOwnR :: TermId -> Text -> Text -> Handler Html +getSubmissionOwnR tid csh shn = do + authId <- requireAuthId + sid <- runDB $ do + shid <- fetchSheetId tid csh shn + submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do + E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission) + E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val authId + E.&&. submission E.^. SubmissionSheet E.==. E.val shid + return $ submission E.^. SubmissionId + case submissions of + ((E.Value sid):_) -> return sid + [] -> notFound + cID <- encrypt sid + redirect . CourseR tid csh . SheetR shn $ SubmissionR cID + +submissionHelper :: TermId -> Text -> Text -> SubmissionMode -> Handler Html +submissionHelper tid csh shn (SubmissionMode mcid) = do uid <- requireAuthId msmid <- traverse decrypt mcid (Entity shid Sheet{..}, buddies, lastEdits) <- runDB $ do @@ -112,7 +135,7 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do (E.Value smid:_) -> do cID <- encrypt smid addMessageI "info" $ MsgSubmissionAlreadyExists - redirect $ CSheetR tid csh shn $ SubmissionR $ SubmissionMode $ Just cID + redirect $ CSheetR tid csh shn $ SubmissionR cID (Just smid) -> do shid' <- submissionSheet <$> get404 smid when (shid /= shid') $ invalidArgsI [MsgSubmissionWrongSheet] @@ -203,7 +226,7 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do _other -> return Nothing case mCID of - Just cID -> redirect $ CSheetR tid csh shn $ SubmissionR $ SubmissionMode $ Just cID + Just cID -> redirect $ CSheetR tid csh shn $ SubmissionR cID Nothing -> return () mArCid <- fmap ZIPArchiveName <$> traverse encrypt msmid