From c72b9ef385b9bd08d71671ed47f1795f416d79e2 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 1 Jul 2018 00:23:38 +0200 Subject: [PATCH] Hierarchical submission routes --- routes | 15 +++--- src/Foundation.hs | 96 +++++++++++++++++---------------- src/Handler/Corrections.hs | 16 +++++- src/Handler/CryptoIDDispatch.hs | 4 +- src/Handler/Submission.hs | 65 +++++++++++----------- src/Handler/Utils/Submission.hs | 17 ++++-- src/Model/Types.hs | 26 ++++++++- 7 files changed, 146 insertions(+), 93 deletions(-) diff --git a/routes b/routes index fa34e27ae..1c10335ea 100644 --- a/routes +++ b/routes @@ -58,16 +58,19 @@ /show SShowR GET !timeANDregistered !timeANDmaterials !corrector /edit SEditR GET POST /delete SDelR GET POST - /sub/new SubmissionNewR GET POST !timeANDregistered - /sub/own SubmissionOwnR GET !free - !/sub/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !owner !corrector - !/sub/#CryptoFileNameSubmission SubmissionR GET POST !owner !corrector - !/sub/#CryptoFileNameSubmission/*FilePath SubmissionDownloadSingleR GET !owner !corrector - /correctors SCorrR GET POST /subs SSubsR GET POST + /subs/new SubmissionNewR GET POST !timeANDregistered + /subs/own SubmissionOwnR GET !free + /sub/#CryptoFileNameSubmission SubmissionR !corrector: + / SubShowR GET POST !owner + /archive SubArchiveR GET !owner + /correction CorrectionR GET POST !ownerANDisRead + !/#SubmissionFileType/*FilePath SubDownloadR GET !owner + /correctors SCorrR GET POST !/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector /corrections CorrectionsR GET POST !free +/corrections/upload CorrectionsUploadR GET POST !free !/#UUID CryptoUUIDDispatchR GET !free -- just redirect diff --git a/src/Foundation.hs b/src/Foundation.hs index c70a713c0..b729ad7df 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -126,6 +126,9 @@ type MsgRenderer = MsgRendererS UniWorX -- see Utils pattern CSheetR tid csh shn ptn = CourseR tid csh (SheetR shn ptn) +pattern CSubmissionR tid csh shn cid ptn + = CSheetR tid csh shn (SubmissionR cid ptn) + -- Menus and Favourites data MenuItem = MenuItem { menuItemLabel :: Text @@ -174,9 +177,9 @@ instance RenderMessage UniWorX SheetFileType where -- Access Control data AccessPredicate - = APPure (Route UniWorX -> Reader MsgRenderer AuthResult) - | APHandler (Route UniWorX -> Handler AuthResult) - | APDB (Route UniWorX -> DB AuthResult) + = APPure (Route UniWorX -> Bool -> Reader MsgRenderer AuthResult) + | APHandler (Route UniWorX -> Bool -> Handler AuthResult) + | APDB (Route UniWorX -> Bool -> DB AuthResult) orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult orAR _ Authorized _ = Authorized @@ -199,22 +202,22 @@ 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 -> shortCircuitM sc (f r) (g r) . ops =<< ask -liftAR ops sc (APHandler f) (APHandler g) = APHandler $ \r -> shortCircuitM sc (f r) (g r) . ops =<< getMsgRenderer -liftAR ops sc (APDB f) (APDB g) = APDB $ \r -> shortCircuitM sc (f r) (g r) . ops =<< getMsgRenderer -liftAR ops sc (APPure f) apg = liftAR ops sc (APHandler $ \r -> runReader (f r) <$> getMsgRenderer) apg +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 $ lift . f) apdb +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 $ return Authorized -falseAP = APPure . const $ Unauthorized . ($ MsgUnauthorized) . render <$> ask -- always use adminAP instead +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 $ \case +adminAP = APDB $ \route _ -> case route of -- Courses: access only to school admins CourseR tid csh _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId @@ -237,13 +240,13 @@ adminAP = APDB $ \case knownTags :: Map (CI Text) AccessPredicate knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or requireAuthId [("free", trueAP) - ,("deprecated", APHandler $ \r -> do + ,("deprecated", APHandler $ \r _ -> do $logWarnS "AccessControl" ("deprecated route: " <> tshow r) addMessageI "error" MsgDeprecatedRoute allow <- appAllowDeprecated . appSettings <$> getYesod return $ bool (Unauthorized "Deprecated Route") Authorized allow ) - ,("lecturer", APDB $ \case + ,("lecturer", APDB $ \route _ -> case route of CourseR tid csh _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do @@ -259,7 +262,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] [] return Authorized ) - ,("corrector", APDB $ \route -> exceptT return return $ do + ,("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 @@ -270,7 +273,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req 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 cID) -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do + CSubmissionR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID Submission{..} <- MaybeT . lift $ get sid guard $ maybe False (== authId) submissionRatingBy @@ -288,7 +291,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny) return Authorized ) - ,("time", APDB $ \case + ,("time", APDB $ \route _ -> case route of CSheetR tid csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh Entity sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn @@ -314,7 +317,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req $logErrorS "AccessControl" $ "'!time' used on route that doesn't support it: " <> tshow r unauthorizedI MsgUnauthorized ) - ,("registered", APDB $ \case + ,("registered", APDB $ \route _ -> case route of CourseR tid csh _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do @@ -329,7 +332,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req $logErrorS "AccessControl" $ "'!registered' used on route that doesn't support it: " <> tshow r unauthorizedI MsgUnauthorized ) - ,("materials", APDB $ \case + ,("materials", APDB $ \route _ -> case route of CourseR tid csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do Entity _ Course{..} <- MaybeT . getBy $ CourseTermShort tid csh guard courseMaterialFree @@ -338,8 +341,8 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req $logErrorS "AccessControl" $ "'!materials' used on route that doesn't support it: " <> tshow r unauthorizedI MsgUnauthorized ) - ,("owner", APDB $ \case - CSheetR _ _ _ (SubmissionR cID) -> exceptT return return $ do + ,("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 @@ -349,24 +352,15 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req $logErrorS "AccessControl" $ "'!owner' used on route that doesn't support it: " <> tshow r unauthorizedI MsgUnauthorized ) - ,("isRead", APHandler $ \route -> - bool <$> return Authorized - <*> unauthorizedI MsgUnauthorizedWrite - <*> isWriteRequest route - ) - ,("isWrite", APHandler $ \route -> do - write <- isWriteRequest route - if write - then return Authorized - else unauthorizedI MsgUnauthorized - ) + ,("isRead", APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)) + ,("isWrite", 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 -> do -- Can this be pure like falseAP? GK: not if we want to log a message (which we definitely should) + 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 @@ -376,17 +370,17 @@ route2ap r = foldr orAP adminAP attrsAND -- adminAP causes all to be in DB!!! GK attrsAND = map splitAND $ Set.toList $ routeAttrs r splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND" -evalAccessDB :: Route UniWorX -> DB AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise -evalAccessDB r = case route2ap r of - (APPure p) -> lift $ runReader (p r) <$> getMsgRenderer - (APHandler p) -> lift $ p r - (APDB p) -> p r +evalAccessDB :: Route UniWorX -> Bool -> DB AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise +evalAccessDB r w = case route2ap r of + (APPure p) -> lift $ runReader (p r w) <$> getMsgRenderer + (APHandler p) -> lift $ p r w + (APDB p) -> p r w -evalAccess :: Route UniWorX -> Handler AuthResult -evalAccess r = case route2ap r of - (APPure p) -> runReader (p r) <$> getMsgRenderer - (APHandler p) -> p r - (APDB p) -> runDB $ p r +evalAccess :: Route UniWorX -> Bool -> Handler AuthResult +evalAccess r w = case route2ap r of + (APPure p) -> runReader (p r w) <$> getMsgRenderer + (APHandler p) -> p r w + (APDB p) -> runDB $ p r w @@ -534,7 +528,7 @@ instance Yesod UniWorX where -- The page to be redirected to when authentication is required. authRoute _ = Just $ AuthR LoginR - isAuthorized route _isWrite = evalAccess route + isAuthorized = evalAccess -- This function creates static content files in the static folder -- and names them based on a hash of their content. This allows @@ -609,7 +603,7 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (CSheetR tid csh shn SSubsR) = return ("Abgaben", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid csh shn SubmissionNewR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid csh shn SubmissionOwnR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) - breadcrumb (CSheetR tid csh shn (SubmissionR _)) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) + breadcrumb (CSubmissionR tid csh shn _ SubShowR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) -- Others breadcrumb _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all @@ -789,7 +783,7 @@ pageHeading (CSheetR tid csh shn SubmissionNewR) = Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn pageHeading (CSheetR tid csh shn SubmissionOwnR) = Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn -pageHeading (CSheetR tid csh shn (SubmissionR _)) -- TODO: Rethink this one! +pageHeading (CSubmissionR tid csh shn _ SubShowR) -- TODO: Rethink this one! = Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn -- TODO: add headings for more single course- and single term-pages @@ -834,6 +828,18 @@ defaultLinks = -- Define the menu items of the header. , menuItemRoute = TermShowR , menuItemAccessCallback' = return True } + , NavbarAside $ MenuItem + { menuItemLabel = "Korrekturen" + , menuItemIcon = Nothing + , menuItemRoute = CorrectionsR + , menuItemAccessCallback' = return True + } + , NavbarAside $ MenuItem + { menuItemLabel = "Korrekturen hochladen" + , menuItemIcon = Nothing + , menuItemRoute = CorrectionsUploadR + , menuItemAccessCallback' = return True + } , NavbarAside $ MenuItem { menuItemLabel = "Benutzer" , menuItemIcon = Just "users" diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 431d35fbb..1350efb13 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -33,7 +33,7 @@ import qualified Data.Map as Map -- import qualified Data.Text as T -- import Data.Function ((&)) -- -import Colonnade hiding (fromMaybe, singleton) +import Colonnade hiding (fromMaybe, singleton, bool) -- import Yesod.Colonnade -- -- import qualified Data.UUID.Cryptographic as UUID @@ -108,7 +108,7 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission) csh = E.unValue $ course ^. _2 shn = sheetName $ entityVal sheet cid <- encrypt (entityKey submission :: SubmissionId) - [whamlet|#{display cid}|] + [whamlet|#{display cid}|] colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool))) colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _) } -> encrypt subId @@ -340,3 +340,15 @@ postSSubsR tid csh shn = do , assignAction (Right shid) , autoAssignAction shid ] + +getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> Handler Html +getCorrectionR tid csh shn cid = do + mayPost <- isAuthorized (CSubmissionR tid csh shn cid CorrectionR) True + bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid csh shn cid +postCorrectionR tid csh shn cid = undefined +getCorrectionUserR tid csh shn cid = undefined + + +getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html +getCorrectionsUploadR = postCorrectionsUploadR +postCorrectionsUploadR = undefined diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs index b96495d78..32781c28d 100644 --- a/src/Handler/CryptoIDDispatch.hs +++ b/src/Handler/CryptoIDDispatch.hs @@ -43,7 +43,7 @@ instance CryptoRoute UUID SubmissionId where Sheet{..} <- get404 shid Course{..} <- get404 sheetCourse return (courseTerm, courseShorthand, sheetName) - return $ CSheetR tid csh shn $ SubmissionR cID' + return $ CSubmissionR tid csh shn cID' SubShowR instance CryptoRoute (CI FilePath) SubmissionId where cryptoIDRoute _ (CryptoID -> cID) = do @@ -53,7 +53,7 @@ instance CryptoRoute (CI FilePath) SubmissionId where Sheet{..} <- get404 shid Course{..} <- get404 sheetCourse return (courseTerm, courseShorthand, sheetName) - return $ CSheetR tid csh shn $ SubmissionR cID + return $ CSubmissionR tid csh shn cID SubShowR instance CryptoRoute UUID UserId where cryptoIDRoute _ (CryptoID -> cID) = do diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 7cf47ae44..7e465c986 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -29,6 +29,7 @@ import Control.Monad.Trans.Maybe import Control.Monad.State.Class import Control.Monad.Trans.State.Strict (StateT) +import Data.Maybe (fromJust) import qualified Data.Maybe import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -53,6 +54,8 @@ import Colonnade hiding (bool) import qualified Yesod.Colonnade as Yesod import qualified Text.Blaze.Html5.Attributes as HA +import Text.Shakespeare.Text (st) + numberOfSubmissionEditDates :: Int64 numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production. @@ -80,9 +83,9 @@ getSubmissionNewR = postSubmissionNewR postSubmissionNewR tid csh shn = submissionHelper tid csh shn NewSubmission -getSubmissionR, postSubmissionR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> Handler Html -getSubmissionR = postSubmissionR -postSubmissionR tid csh shn cid = submissionHelper tid csh shn $ ExistingSubmission cid +getSubShowR, postSubShowR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> Handler Html +getSubShowR = postSubShowR +postSubShowR tid csh shn cid = submissionHelper tid csh shn $ ExistingSubmission cid getSubmissionOwnR :: TermId -> Text -> Text -> Handler Html getSubmissionOwnR tid csh shn = do @@ -98,7 +101,7 @@ getSubmissionOwnR tid csh shn = do ((E.Value sid):_) -> return sid [] -> notFound cID <- encrypt sid - redirect . CourseR tid csh . SheetR shn $ SubmissionR cID + redirect $ CSubmissionR tid csh shn cID SubShowR submissionHelper :: TermId -> Text -> Text -> SubmissionMode -> Handler Html submissionHelper tid csh shn (SubmissionMode mcid) = do @@ -136,10 +139,11 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do (E.Value smid:_) -> do cID <- encrypt smid addMessageI "info" $ MsgSubmissionAlreadyExists - redirect $ CSheetR tid csh shn $ SubmissionR cID + redirect $ CSubmissionR tid csh shn cID SubShowR (Just smid) -> do + submissionMatchesSheet tid csh shn (fromJust mcid) + shid' <- submissionSheet <$> get404 smid - when (shid /= shid') $ invalidArgsI [MsgSubmissionWrongSheet] -- fetch buddies from current submission buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId) @@ -227,11 +231,9 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do _other -> return Nothing case mCID of - Just cID -> redirect $ CSheetR tid csh shn $ SubmissionR cID + Just cID -> redirect $ CSubmissionR tid csh shn cID SubShowR Nothing -> return () - mArCid <- fmap ZIPArchiveName <$> traverse encrypt msmid - let pageTitle = MsgSubmissionEditHead tid csh shn let formTitle = pageTitle let formText = Nothing :: Maybe UniWorXMessage @@ -240,9 +242,9 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (WidgetT UniWorX IO) ()) colonnadeFiles cid = mconcat -- [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype - [ sortable (Just "path") "Dateiname" $ anchorCell (\(Entity _ File{..}) -> CSheetR tid csh shn $ SubmissionDownloadSingleR cid fileTitle) - (\(Entity _ File{..}) -> str2widget fileTitle) - , sortable (Just "time") "Modifikation" $ \(Entity _ File{..}) -> stringCell $ formatTimeGerWDT fileModified + [ sortable (Just "path") "Dateiname" $ anchorCell (\(Entity _ SubmissionFile{..}, Entity _ File{..}) -> CSubmissionR tid csh shn cid $ SubDownloadR (isUpdateSubmissionFileType submissionFileIsUpdate) fileTitle) + (\(_, Entity _ File{..}) -> str2widget fileTitle) + , sortable (Just "time") "Modifikation" $ \(_, Entity _ File{..}) -> stringCell $ formatTimeGerWDT fileModified ] smid2ArchiveTable (smid,cid) = DBTable { dbtSQLQuery = submissionFileQuery smid @@ -264,10 +266,10 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do setTitleI pageTitle $(widgetFile "formPageI18n") [whamlet| - $maybe arCid <- mArCid + $maybe cid <- mcid

- Archiv + Archiv $forall (name,time) <- lastEdits
last edited by #{name} at #{formatTimeGerDTlong time} $maybe fileTable <- mFileTable @@ -276,14 +278,12 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do |] -getSubmissionDownloadSingleR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> FilePath -> Handler TypedContent -getSubmissionDownloadSingleR tid csh shn cID path = do +getSubDownloadR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent +getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do submissionID <- decrypt cID runDB $ do - shid <- fetchSheetId tid csh shn - Submission{..} <- get404 submissionID - when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet] + submissionMatchesSheet tid csh shn cID isRating <- maybe False (== submissionID) <$> isRatingFile path case isRating of @@ -291,13 +291,13 @@ getSubmissionDownloadSingleR tid csh shn cID path = do file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID) maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file False -> do - results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do + results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile) - E.where_ (sf E.^. SubmissionFileSubmission E.==. E.val submissionID) - E.where_ (f E.^. FileTitle E.==. E.val path) - E.where_ . E.not_ . E.isNothing $ f E.^. FileContent - E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion - E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] + E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID + E.&&. f E.^. FileTitle E.==. E.val path + E.&&. E.not_ (E.isNothing $ f E.^. FileContent) + E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion) + E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate return f let fileName = Text.pack $ takeFileName path @@ -305,15 +305,14 @@ getSubmissionDownloadSingleR tid csh shn cID path = do [Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName <> "; charset=utf-8") (toContent c) _ -> notFound -getSubmissionDownloadArchiveR :: TermId -> Text -> Text -> ZIPArchiveName SubmissionId -> Handler TypedContent -getSubmissionDownloadArchiveR tid csh shn (ZIPArchiveName cID) = do +getSubArchiveR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> Handler TypedContent +getSubArchiveR tid csh shn cID@CryptoID{..} = do submissionID <- decrypt cID - cUUID <- encrypt submissionID + + addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece cID}.zip"|] + respondSourceDB "application/zip" $ do - lift $ do - shid <- fetchSheetId tid csh shn - Submission{..} <- get404 submissionID - when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet] + lift $ submissionMatchesSheet tid csh shn cID rating <- lift $ getRating submissionID case rating of @@ -321,5 +320,5 @@ getSubmissionDownloadArchiveR tid csh shn (ZIPArchiveName cID) = do Just rating' -> do let fileEntitySource' :: Source (YesodDB UniWorX) File fileEntitySource' = submissionFileSource submissionID =$= Conduit.map entityVal >> yieldM (ratingFile cID rating') - info = ZipInfo { zipComment = Text.encodeUtf8 . pack . CI.foldedCase $ ciphertext (cUUID :: CryptoFileNameSubmission) } + info = ZipInfo { zipComment = Text.encodeUtf8 . pack $ CI.foldedCase ciphertext } fileEntitySource' =$= produceZip info =$= Conduit.map toFlushBuilder diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 8cf22e67d..10ac1f07f 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -19,6 +19,7 @@ module Handler.Utils.Submission , submissionMultiArchive , SubmissionSinkException(..) , sinkSubmission + , submissionMatchesSheet ) where import Import hiding ((.=), joinPath) @@ -46,6 +47,7 @@ import Generics.Deriving.Monoid (memptydefault, mappenddefault) import Handler.Utils.Rating import Handler.Utils.Zip +import Handler.Utils.Sheet import qualified Database.Esqueleto as E @@ -119,16 +121,16 @@ assignSubmissions sid restriction = do submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File) -submissionFileSource = E.selectSource . E.from . submissionFileQuery +submissionFileSource = E.selectSource . fmap snd . E.from . submissionFileQuery submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile) `E.InnerJoin` E.SqlExpr (Entity File) - -> E.SqlQuery (E.SqlExpr (Entity File)) + -> E.SqlQuery (E.SqlExpr (Entity SubmissionFile), E.SqlExpr (Entity File)) submissionFileQuery submissionID (sf `E.InnerJoin` f) = E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile) E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion -- TODO@gk: won't work as intended! Fix with refactor E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] -- E.desc returns corrector updated data first - return f + return (sf, f) submissionMultiArchive :: Set SubmissionId -> Handler TypedContent submissionMultiArchive (Set.toList -> ids) = do @@ -378,6 +380,8 @@ sinkMultiSubmission :: UserId -- ^ Expects all supplied 'SubmissionContent' to contain an encrypted 'SubmissionId' and replaces the currently saved files for the respective submissions (either corrected files or original ones, depending on arguments) with the supplied 'SubmissionContent'. -- -- Files that don't occur in the 'SubmissionContent' but are in the database are deleted (or marked as deleted in the case of this being a correction). +-- +-- In contrast to `sinkSubmission` this function does authorization-checks against `CorrectionR` -- TODO sinkMultiSubmission userId isUpdate = do let feed :: SubmissionId @@ -410,3 +414,10 @@ sinkMultiSubmission userId isUpdate = do (msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle lift . maybe (const $ return ()) feed msId $ Left f{ fileTitle = fileTitle' } fmap Map.keysSet . lift $ mapM (void . closeResumableSink) sinks + +submissionMatchesSheet :: TermId -> Text -> Text -> CryptoFileNameSubmission -> DB () +submissionMatchesSheet tid csh shn cid = do + sid <- decrypt cid + shid <- fetchSheetId tid csh shn + Submission{..} <- get404 sid + when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index efa329e4a..526c88f7b 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -73,6 +73,9 @@ data SheetGroup deriveJSON defaultOptions ''SheetGroup derivePersistFieldJSON "SheetGroup" +enumFromPathPiece :: (PathPiece a, Enum a, Bounded a) => Text -> Maybe a +enumFromPathPiece t = lookup (CI.mk t) [(CI.mk $ toPathPiece ty,ty) | ty <- [minBound..maxBound]] + data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking deriving (Show, Read, Eq, Ord, Enum, Bounded) derivePersistField "SheetFileType" @@ -82,8 +85,7 @@ instance PathPiece SheetFileType where toPathPiece SheetHint = "hint" toPathPiece SheetSolution = "solution" toPathPiece SheetMarking = "marking" - fromPathPiece t = - lookup (CI.mk t) [(CI.mk $ toPathPiece ty,ty) | ty <- [minBound..maxBound]] + fromPathPiece = enumFromPathPiece -- $(deriveSimpleWith ''DisplayAble 'display (drop 17) ''SheetFileType) instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instance in Foundation @@ -92,6 +94,26 @@ instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instan display SheetSolution = "Musterlösung" display SheetMarking = "Korrekturhinweise" +data SubmissionFileType = SubmissionOriginal | SubmissionCorrected + deriving (Show, Read, Eq, Ord, Enum, Bounded) + +submissionFileTypeIsUpdate :: SubmissionFileType -> Bool +submissionFileTypeIsUpdate SubmissionOriginal = False +submissionFileTypeIsUpdate SubmissionCorrected = True + +isUpdateSubmissionFileType :: Bool -> SubmissionFileType +isUpdateSubmissionFileType False = SubmissionOriginal +isUpdateSubmissionFileType True = SubmissionCorrected + +instance PathPiece SubmissionFileType where + toPathPiece SubmissionOriginal = "file" + toPathPiece SubmissionCorrected = "corrected" + fromPathPiece = enumFromPathPiece + +instance DisplayAble SubmissionFileType where + display SubmissionOriginal = "Abgabe" + display SubmissionCorrected = "Korrektur" + {- data DA = forall a . (DisplayAble a) => DA a