diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index d32ad420e..44b1e4d6a 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -8,6 +8,7 @@ module Handler.Corrections , getCorrectionsGradeR, postCorrectionsGradeR , getCAssignR, postCAssignR , getSAssignR, postSAssignR + , getCorrectionsDownloadR , correctionsR' , ratedBy, courseIs, sheetIs, userIs , colTerm, colSchool, colCourse, colSheet, colCorrector, colSubmissionLink, colSelect, colSubmittors, colSMatrikel, colRating, colAssigned, colRated, colPseudonyms, colRatedField, colPointsField, colMaxPointsField, colCommentField, colLastEdit @@ -1401,5 +1402,14 @@ assignHandler tid ssh csh cid assignSids = do setTitleI headingLong $(widgetFile "corrections-overview") - - +getCorrectionsDownloadR :: Handler TypedContent +getCorrectionsDownloadR = do -- download all assigned and open submissions + uid <- requireAuthId + subs <- runDB $ selectKeysList + [ SubmissionRatingBy ==. Just uid + , SubmissionRatingTime ==. Nothing + ] [] + when (null subs) $ do + addMessageI Info MsgNoOpenSubmissions + redirect CorrectionsR + submissionMultiArchive SubmissionDownloadAnonymous $ Set.fromList subs diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index b3ce95818..f0aa54748 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -1,319 +1,28 @@ -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-uni-patterns #-} - module Handler.Submission - ( getSubmissionNewR, postSubmissionNewR - , getSubShowR, postSubShowR - , getSubmissionOwnR - , getSInviteR, postSInviteR - , getSubDownloadR - , getSubArchiveR - , getSubDelR, postSubDelR - , getCorrectionsDownloadR - , getSubAssignR, postSubAssignR + ( getSubmissionOwnR + , module Handler.Submission.New + , module Handler.Submission.Show + , module Handler.Submission.Download + , module Handler.Submission.Delete + , module Handler.Submission.Assign + , module Handler.Submission.SubmissionUserInvite ) where +import Handler.Submission.New +import Handler.Submission.Show +import Handler.Submission.Download +import Handler.Submission.Delete +import Handler.Submission.Assign +import Handler.Submission.SubmissionUserInvite (getSInviteR, postSInviteR) + + import Import -import Jobs - --- import Yesod.Form.Bootstrap3 - import Handler.Utils -import Handler.Utils.Delete -import Handler.Utils.Submission -import Handler.Utils.Invitations - --- 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.Encoding as Text import qualified Database.Esqueleto as E -import qualified Database.Esqueleto.Internal.Sql as E (unsafeSqlFunction) - -import qualified Data.Conduit.List as Conduit --- import Data.Conduit.ResumableSink - --- import Data.Set (Set) -import qualified Data.Set as Set -import Data.Map ((!), (!?)) -import qualified Data.Map as Map --- import Data.Bifunctor -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 - --- import Colonnade hiding (bool, fromMaybe) --- import qualified Yesod.Colonnade as Yesod --- import qualified Text.Blaze.Html5.Attributes as HA - --- DEPRECATED: We always show all edits! --- numberOfSubmissionEditDates :: Int64 --- numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production. - - -instance IsInvitableJunction SubmissionUser where - type InvitationFor SubmissionUser = Submission - data InvitableJunction SubmissionUser = JunctionSubmissionUser - deriving (Eq, Ord, Read, Show, Generic, Typeable) - data InvitationDBData SubmissionUser = InvDBDataSubmissionUser - deriving (Eq, Ord, Read, Show, Generic, Typeable) - data InvitationTokenData SubmissionUser = InvTokenDataSubmissionUser - deriving (Eq, Ord, Read, Show, Generic, Typeable) - - _InvitableJunction = iso - (\SubmissionUser{..} -> (submissionUserUser, submissionUserSubmission, JunctionSubmissionUser)) - (\(submissionUserUser, submissionUserSubmission, JunctionSubmissionUser) -> SubmissionUser{..}) - -instance ToJSON (InvitableJunction SubmissionUser) where - toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } - toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } -instance FromJSON (InvitableJunction SubmissionUser) where - parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } - -instance ToJSON (InvitationDBData SubmissionUser) where - toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } - toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } -instance FromJSON (InvitationDBData SubmissionUser) where - parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } - -instance ToJSON (InvitationTokenData SubmissionUser) where - toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } - toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 } -instance FromJSON (InvitationTokenData SubmissionUser) where - parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } - -submissionUserInvitationConfig :: InvitationConfig SubmissionUser -submissionUserInvitationConfig = InvitationConfig{..} - where - invitationRoute (Entity subId Submission{..}) _ = do - Sheet{..} <- getJust submissionSheet - Course{..} <- getJust sheetCourse - cID <- encrypt subId - return $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SInviteR - invitationResolveFor _ = do - cRoute <- getCurrentRoute - case cRoute of - Just (CSubmissionR _tid _ssh _csh _shn cID SInviteR) -> do - subId <- decrypt cID - bool notFound (return subId) =<< existsKey subId - _other -> - error "submissionUserInvitationConfig called from unsupported route" - invitationSubject (Entity _ Submission{..}) _ = do - Sheet{..} <- getJust submissionSheet - Course{..} <- getJust sheetCourse - return . SomeMessage $ MsgMailSubjectSubmissionUserInvitation courseTerm courseSchool courseShorthand sheetName - invitationHeading (Entity _ Submission{..}) _ = do - Sheet{..} <- getJust submissionSheet - return . SomeMessage $ MsgSubmissionUserInviteHeading sheetName - invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSubmissionUserInviteExplanation}|] - invitationTokenConfig (Entity _ Submission{..}) _ = do - Sheet{..} <- getJust submissionSheet - Course{..} <- getJust sheetCourse - itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId - itAddAuth <- either throwM (return . Just) $ routeAuthTags (CSheetR courseTerm courseSchool courseShorthand sheetName SubmissionNewR) - let itExpiresAt = Nothing - itStartsAt = Nothing - return InvitationTokenConfig{..} - invitationRestriction _ _ = return Authorized - invitationForm _ _ _ = pure (JunctionSubmissionUser, ()) - invitationInsertHook _ _ _ _ _ = id - invitationSuccessMsg (Entity _ Submission{..}) _ = do - Sheet{..} <- getJust submissionSheet - return . SomeMessage $ MsgSubmissionUserInvitationAccepted sheetName - invitationUltDest (Entity subId Submission{..}) _ = do - Sheet{..} <- getJust submissionSheet - Course{..} <- getJust sheetCourse - cID <- encrypt subId - return . SomeRoute $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SubShowR - - -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' - where - miCell' :: Markup -> Either UserEmail UserId -> Widget - miCell' csrf (Left email) = do - invWarnMsg <- messageIconI Info IconEmail $ if - | isLecturer -> MsgEmailInvitationWarningCourseParticipants - | otherwise -> MsgEmailInvitationWarningPrevCoSubmittors - $(widgetFile "widgets/massinput/submissionUsers/cellInvitation") - miCell' csrf (Right uid) = do - User{..} <- liftHandler . runDB $ getJust uid - $(widgetFile "widgets/massinput/submissionUsers/cellKnown") - - miLayout :: ListLength - -> Map ListPosition (Either UserEmail UserId, FormResult ()) -- ^ massInput state - -> Map ListPosition Widget -- ^ Cell widgets - -> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons - -> Map (Natural, ListPosition) Widget -- ^ Addition widgets - -> Widget - miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/submissionUsers/layout") - - miIdent :: Text - miIdent = "submittors" - - courseUsers :: E.SqlQuery (E.SqlExpr (Entity User)) - courseUsers = E.from $ \(user `E.InnerJoin` participant) -> do - E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser - E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid - E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive - E.orderBy [E.asc $ user E.^. UserEmail] - return user - previousCoSubmittors :: UserId -> E.SqlQuery (E.SqlExpr (Entity User)) - previousCoSubmittors uid = E.from $ \(user `E.InnerJoin` submissionUser `E.InnerJoin` submission `E.InnerJoin` sheet) -> do - E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet - E.&&. sheet E.^. SheetCourse E.==. E.val cid - E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission - E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser - E.where_ . E.exists . E.from $ \submissionUser' -> - E.where_ $ submissionUser' E.^. SubmissionUserUser E.==. E.val uid - E.&&. submissionUser' E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId - E.where_ . E.exists . E.from $ \participant -> - E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid - E.&&. participant E.^. CourseParticipantUser E.==. user E.^. UserId - E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive - E.orderBy [E.asc $ user E.^. UserEmail] - return user - - addField :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> Field m (Set (Either UserEmail UserId)) - addField uid = multiUserInvitationField . MUILookupSuggested (SomeMessage MsgMultiUserFieldExplanationPrevCoSubmittors) $ previousCoSubmittors uid - addFieldLecturer = multiUserInvitationField $ MUILookupSuggested (SomeMessage MsgMultiUserFieldExplanationCourseParticipants) courseUsers - - addFieldSettings :: (forall msg. RenderMessage UniWorX msg => msg -> Text) -> FieldSettings UniWorX - addFieldSettings mr = fslpI MsgSubmissionMembers $ mr MsgLdapIdentificationOrEmail - submittorSettings, singleSubSettings :: FieldSettings UniWorX - submittorSettings = fslI MsgSubmissionMembers - singleSubSettings = fslI MsgSubmissionMember - - maxSize | Arbitrary{..} <- grouping = Just maxParticipants - | otherwise = Nothing - mayEdit = is _Arbitrary grouping - - submittorSettings' - | maxSize > Just 1 = submittorSettings - | otherwise = singleSubSettings - - 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 - miAdd :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId]) - miAdd nudge btn csrf = do - MsgRenderer mr <- getMsgRenderer - (addRes, addView) <- mpreq addFieldLecturer (addFieldSettings mr & addName (nudge "emails")) Nothing - let addRes' = addRes <&> \newData oldData -> if - | existing <- newData `Set.intersection` Set.fromList oldData - , not $ Set.null existing - -> FormFailure [mr MsgSubmissionUserAlreadyAdded] - | otherwise - -> FormSuccess $ Set.toList newData - return (addRes', $(widgetFile "widgets/massinput/submissionUsers/add")) - - mRoute <- getCurrentRoute - submittors <- massInputAccumW miAdd (miCell' mempty) (miButtonAction' mRoute) miLayout miIdent submittorSettings True (Just $ Set.toList prefillUsers) - MsgRenderer mr <- getMsgRenderer - return $ submittors >>= \submittors' -> if - | null submittors' -> FormFailure [mr MsgSubmissionUsersEmpty] - | otherwise -> FormSuccess $ Set.fromList submittors' - | otherwise = do - uid <- liftHandler requireAuthId - mRoute <- getCurrentRoute - - let - miAdd :: ListPosition - -> Natural - -> (Text -> Text) - -> FieldView UniWorX - -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId)))) - miAdd _ _ nudge btn = Just $ \csrf -> do - MsgRenderer mr <- getMsgRenderer - (addRes, addView) <- mpreq (addField uid) (addFieldSettings mr & addName (nudge "emails")) Nothing - let addRes' = addRes <&> \newData oldData -> if - | existing <- newData `Set.intersection` setOf folded oldData - , not $ Set.null existing - -> FormFailure [mr MsgSubmissionUserAlreadyAdded] - | otherwise -> let numStart = maybe 0 (succ . fst) $ Map.lookupMax oldData - in FormSuccess . Map.fromList . zip [numStart..] $ Set.toList newData - return (addRes', $(widgetFile "widgets/massinput/submissionUsers/add")) - - miCell :: ListPosition - -> Either UserEmail UserId - -> Maybe () - -> (Text -> Text) - -> Form () - miCell _ dat _ _ csrf = return (FormSuccess (), miCell' csrf dat) - - miDelete :: Map ListPosition (Either UserEmail UserId) - -> ListPosition - -> MaybeT (MForm Handler) (Map ListPosition ListPosition) - miDelete dat delPos = do - guard mayEdit - guard $ Map.size dat > 1 - - -- User may drop from submission only if it already exists; no directly creating submissions for other people - guard $ maybe True (/= Right uid) (dat !? delPos) || isJust msmid - - miDeleteList dat delPos - - miAllowAdd :: ListPosition - -> Natural - -> ListLength - -> Bool - miAllowAdd _ _ l = mayEdit && maybe False ((l <) . fromIntegral) maxSize - - miAddEmpty _ _ _ = Set.empty - - miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) - miButtonAction = miButtonAction' mRoute - - postProcess :: Map ListPosition (Either UserEmail UserId, ()) -> Set (Either UserEmail UserId) - postProcess valMap - | is _Just msmid - , resultUsers == prefillUsers - = resultUsers - | Just maxSize' <- maxSize - , fromIntegral maxSize' >= Set.size resultUsers - = resultUsers - | Just maxSize' <- maxSize - = let resultUsers' = Set.take (fromIntegral maxSize') resultUsers - in if | Set.member (Right uid) resultUsers' -> resultUsers' - | otherwise -> Set.insert (Right uid) $ Set.take (pred $ fromIntegral maxSize') resultUsers' - | otherwise = Set.singleton $ Right uid - where resultUsers = setOf (folded . _1) valMap - -- when (maxSize > Just 1) $ - -- wformMessage =<< messageI Info MsgCosubmittorTip - fmap postProcess <$> massInputW MassInput{..} submittorSettings' True (Just . Map.fromList . zip [0..] . map (, ()) $ Set.toList prefillUsers) - - -getSubmissionNewR, postSubmissionNewR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html -getSubmissionNewR = postSubmissionNewR -postSubmissionNewR tid ssh csh shn = submissionHelper tid ssh csh shn Nothing - - -getSubShowR, postSubShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html -getSubShowR = postSubShowR -postSubShowR tid ssh csh shn cid = submissionHelper tid ssh csh shn $ Just cid + getSubmissionOwnR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSubmissionOwnR tid ssh csh shn = do authId <- requireAuthId @@ -329,475 +38,3 @@ getSubmissionOwnR tid ssh csh shn = do [] -> notFound cID <- encrypt sid redirect $ CSubmissionR tid ssh csh shn cID SubShowR - -submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe CryptoFileNameSubmission -> Handler Html -submissionHelper tid ssh csh shn mcid = do - muid <- maybeAuthId - msmid <- traverse decrypt mcid - actionUrl <- fromMaybe (error "submissionHelper called from 404-handler") <$> getCurrentRoute - - (Entity shid Sheet{..}, buddies, lastEdits, maySubmit, isLecturer, isOwner, msubmission, corrector) <- runDB $ do - csheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn - maySubmit <- (== Authorized) <$> evalAccessDB actionUrl True - isLecturer <- (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SSubsR) True - - submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do - E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission) - E.where_ $ E.just (submissionUser E.^. SubmissionUserUser) E.==. E.val muid - E.&&. submission E.^. SubmissionSheet E.==. E.val shid - return $ submission E.^. SubmissionId - case (msmid, submissions) of - (Nothing, E.Value smid : _) -> do - cID <- encrypt smid - addMessageI Info MsgSubmissionAlreadyExists - redirect $ CSubmissionR tid ssh csh shn cID SubShowR - _other -> return () - - case (msmid, sheetGrouping) of - (Nothing, Arbitrary maxBuddies) -> do - -- fetch buddies from previous submission in this course - buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do - E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId) - let oldids = E.subList_select . E.from $ \(sheet `E.InnerJoin` submission `E.InnerJoin` subUser `E.InnerJoin` submissionEdit) -> do - E.on (submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId) - E.on (subUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId) - E.on (sheet E.^. SheetId E.==. submission E.^. SubmissionSheet) - E.where_ $ E.just (subUser E.^. SubmissionUserUser) E.==. E.val muid - E.&&. sheet E.^. SheetCourse E.==. E.val sheetCourse - E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime] - E.limit 1 - return $ submission E.^. SubmissionId - E.where_ $ submissionUser E.^. SubmissionUserSubmission `E.in_` oldids - E.&&. E.just (submissionUser E.^. SubmissionUserUser) E.!=. E.val muid - E.orderBy [E.asc $ user E.^. UserEmail] - return $ user E.^. UserId - return ( csheet - , buddies - & map (Right . E.unValue) - & Set.fromList - & assertM' ((<= maxBuddies) . fromIntegral . Set.size . bool id (maybe id (Set.insert . Right) muid) (not isLecturer)) - & fromMaybe Set.empty - , [] - , maySubmit - , isLecturer - , not isLecturer - , Nothing, Nothing - ) - (Nothing, RegisteredGroups) -> do - buddies <- E.select . E.from $ \(submissionGroup `E.InnerJoin` user) -> do - E.on . E.exists . E.from $ \submissionGroupUser -> - E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. user E.^. UserId - E.&&. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId - E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse - E.where_ . E.exists . E.from $ \submissionGroupUser -> - E.where_ $ E.just (submissionGroupUser E.^. SubmissionGroupUserUser) E.==. E.val muid - E.&&. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId - E.where_ $ E.just (user E.^. UserId) E.!=. E.val muid - E.where_ . E.not_ . E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do - E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId - E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid - E.&&. submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId - - E.orderBy [E.asc $ user E.^. UserEmail] - - return $ user E.^. UserId - - return ( csheet - , buddies - & map (Right . E.unValue) - & Set.fromList - , [] - , maySubmit - , isLecturer - , not isLecturer - , Nothing, Nothing - ) - (Nothing, _) -> return (csheet, Set.empty, [], maySubmit, isLecturer, not isLecturer, Nothing, Nothing) - (Just smid, _) -> do - void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid) - - sub@Submission{..} <- get404 smid - let shid' = submissionSheet - unless (shid == shid') $ - invalidArgsI [MsgSubmissionWrongSheet] - -- fetch buddies from current submission - (Any isOwner, buddies) <- do - submittors <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do - E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId) - E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smid - E.orderBy [E.asc $ user E.^. UserEmail] - return $ user E.^. UserId - let breakUserFromBuddies (E.Value userID) - | muid == Just userID = (Any True , mempty ) - | otherwise = (mempty , Set.singleton $ Right userID) - - invites <- sourceInvitationsF smid <&> Set.fromList . map (\(email, InvDBDataSubmissionUser) -> Left email) - - return . over _2 (Set.union invites) $ foldMap breakUserFromBuddies submittors - - lastEdits <- do - raw <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do - E.on $ E.just (user E.^. UserId) E.==. submissionEdit E.^. SubmissionEditUser - E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid - E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime] - -- E.limit numberOfSubmissionEditDates -- DEPRECATED we always show all edit times - let userName = if isOwner || maySubmit - then E.just $ user E.^. UserDisplayName - else E.nothing - return (userName, submissionEdit E.^. SubmissionEditTime) - forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time - - corrector <- fmap join $ traverse getEntity submissionRatingBy - - return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner,Just sub,corrector) - - if | is _Nothing muid - , is _Nothing msubmission - , not isLecturer - -> notAuthenticated - | otherwise - -> return () - - -- @submissionModeUser == Nothing@ below iff we are currently serving a user with elevated rights (lecturer, admin, ...) - -- Therefore we do not restrict upload behaviour in any way in that case - ((res,formWidget'), formEnctype) <- runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (UploadAny True Nothing) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (maybe id (Set.insert . Right) muid) isOwner buddies - let formWidget = wrapForm' BtnHandIn formWidget' def - { formAction = Just $ SomeRoute actionUrl - , formEncoding = formEnctype - } - - mCID <- fmap join . msgSubmissionErrors . runDBJobs $ do - -- Determine old submission users - subUsersOld <- if - | Just smid <- msmid -> Set.union - <$> (setOf (folded . _entityVal . _submissionUserUser . to Right) <$> selectList [SubmissionUserSubmission ==. smid] []) - <*> (sourceInvitationsF smid <&> Set.fromList . map (\(email, InvDBDataSubmissionUser) -> Left email)) - | otherwise -> return Set.empty - - res' <- case res of - FormMissing -> return FormMissing - (FormFailure failmsgs) -> return $ FormFailure failmsgs - (FormSuccess res'@(_, groupMembers)) - | groupMembers == subUsersOld -> return $ FormSuccess res' - | Arbitrary{..} <- sheetGrouping -> do -- Validate AdHoc Group Members - let (gEMails, gIds) = partitionEithers $ Set.toList groupMembers - prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map UserEmail (Maybe (UserId, Bool, Bool)) - prep ps = Map.fromList $ map (, Nothing) gEMails ++ [(m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps] - participants <- fmap prep . E.select . E.from $ \user -> do - E.where_ $ (user E.^. UserId) `E.in_` E.valList gIds - let - isParticipant = E.exists . E.from $ \courseParticipant -> do - E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser - E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val sheetCourse - E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive - hasSubmitted = E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do - E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId - E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId - E.&&. submission E.^. SubmissionSheet E.==. E.val shid - case msmid of -- Multiple `E.where_`-Statements are merged with `&&` in esqueleto 2.5.3 - Nothing -> return () - Just smid -> E.where_ $ submission E.^. SubmissionId E.!=. E.val smid - return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted)) - - $logDebugS "SUBMISSION.AdHocGroupValidation" $ tshow participants - - mr <- getMessageRender - let - failmsgs = (concat :: [[Text]] -> [Text]) - [ flip Map.foldMapWithKey participants $ \email -> \case - -- Nothing -> pure . mr $ MsgEMailUnknown email - (Just (_,False,_)) -> pure . mr $ MsgNotAParticipant email tid csh - (Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor email - _other -> mempty - , case fromIntegral (Map.size participants) `compare` maxParticipants of - GT | not isLecturer -> pure $ mr MsgTooManyParticipants - _ -> mempty - ] - return $ if null failmsgs - then FormSuccess res' - else FormFailure failmsgs - | otherwise -> return $ FormSuccess res' - - - case res' of - (FormSuccess (mFiles, adhocMembers)) -> do - smid <- do - smid <- case (mFiles, msmid) of - (Nothing, Just smid) -- no new files, existing submission partners updated - -> return smid - (Just files, _) -> -- new files - runConduit $ transPipe (lift . lift) files .| Conduit.mapM (either get404 return) .| extractRatingsMsg .| sinkSubmission muid (maybe (Left shid) Right msmid) False - (Nothing, Nothing) -- new submission, no file upload requested - -> do - sid <- insert Submission - { submissionSheet = shid - , submissionRatingPoints = Nothing - , submissionRatingComment = Nothing - , submissionRatingBy = Nothing - , submissionRatingAssigned = Nothing - , submissionRatingTime = Nothing - } - audit $ TransactionSubmissionEdit sid shid - return sid - - -- Determine new submission users - subUsers <- if - | isLecturer -> return adhocMembers - | RegisteredGroups <- sheetGrouping -> do - -- Determine members of pre-registered group - groupUids <- fmap (setFromList . map (Right . E.unValue)) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do - E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup - E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId - E.where_ $ E.just (submissionGroupUser E.^. SubmissionGroupUserUser) E.==. E.val muid - E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse - - E.where_ . E.not_ . E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do - E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId - E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid - E.&&. submissionUser E.^. SubmissionUserUser E.==. submissionGroupUser' E.^. SubmissionGroupUserUser - E.where_ $ submission E.^. SubmissionId E.!=. E.val smid - - return $ submissionGroupUser' E.^. SubmissionGroupUserUser - -- SubmissionUser for all group members (pre-registered & ad-hoc) - return $ maybe id (Set.insert . Right) muid groupUids - | otherwise -> return adhocMembers - - -- Since invitations carry no data we only need to consider changes to - -- the set of users/invited emails - -- Otherwise we would have to update old invitations (via - -- `sinkInvitationsF`) because their associated @DBData@ might have - -- changed - - forM_ (subUsers `setSymmDiff` subUsersOld) $ \change -> if - -- change is a new user being added to the submission users => send invitation / insert - | change `Set.member` subUsers -> case change of - Left subEmail -> do - -- user does not exist yet => send invitation - sinkInvitationsF submissionUserInvitationConfig [(subEmail, smid, (InvDBDataSubmissionUser, InvTokenDataSubmissionUser))] - return () - Right subUid -> do - -- user exists and has an id => insert as SubmissionUser and audit - insert_ $ SubmissionUser subUid smid - audit $ TransactionSubmissionUserEdit smid subUid - unless (Just subUid == muid) $ - queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated subUid smid - -- change is an old user that is not a submission user anymore => delete invitation / delete - | otherwise -> case change of - Left subEmail -> deleteInvitation @SubmissionUser smid subEmail - Right subUid -> do - deleteBy $ UniqueSubmissionUser subUid smid - audit $ TransactionSubmissionUserDelete smid subUid - unless (Just subUid == muid) $ - queueDBJob . JobQueueNotification $ NotificationSubmissionUserDeleted subUid shid smid - - addMessageI Success $ if | Nothing <- msmid -> MsgSubmissionCreated - | otherwise -> MsgSubmissionUpdated - return smid - cID <- encrypt smid - return $ Just cID - (FormFailure msgs) -> Nothing <$ forM_ msgs (addMessage Warning . toHtml) - _other -> return Nothing - - case mCID of - Just cID -> do - let showRoute = CSubmissionR tid ssh csh shn cID SubShowR - mayShow <- hasReadAccessTo showRoute - if - | mayShow -> redirect showRoute - | otherwise -> redirect $ CSheetR tid ssh csh shn SShowR - Nothing -> return () - - -- Maybe construct a table to display uploaded archive files - let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerFor UniWorX) ()) - colonnadeFiles cid = mconcat - [ sortable (Just "path") (i18nCell MsgFileTitle) $ \(coalesce -> (mOrig, mCorr)) -> let - Just fileTitle' = fileTitle . entityVal . snd <$> (mOrig <|> mCorr) - origIsFile = fmap (isJust . fileContent . entityVal . snd) mOrig - corrIsFile = fmap (isJust . fileContent . entityVal . snd) mCorr - Just isFile = origIsFile <|> corrIsFile - in if - | Just True <- origIsFile -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionOriginal fileTitle') - [whamlet|#{fileTitle'}|] - | otherwise -> textCell $ bool (<> "/") id isFile fileTitle' - , sortable (toNothing "state") (i18nCell MsgCorState) $ \(coalesce -> (_, mCorr)) -> case mCorr of - Nothing -> cell mempty - Just (_, Entity _ File{..}) - | isJust fileContent -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionCorrected fileTitle) - [whamlet|_{MsgFileCorrected}|] - | otherwise -> i18nCell MsgCorrected - , sortable (Just "time") (i18nCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let - origTime = fileModified . entityVal . snd <$> mOrig - corrTime = fileModified . entityVal . snd <$> mCorr - Just fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime - in dateTimeCell fileTime - ] - coalesce :: ((Maybe (Entity SubmissionFile), Maybe (Entity File)), (Maybe (Entity SubmissionFile), Maybe (Entity File))) -> (Maybe (Entity SubmissionFile, Entity File), Maybe (Entity SubmissionFile, Entity File)) - coalesce ((ma, mb), (mc, md)) = ((,) <$> ma <*> mb, (,) <$> mc <*> md) - submissionFiles :: _ -> _ -> E.SqlQuery _ - submissionFiles smid ((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) = do - E.on $ f2 E.?. FileId E.==. sf2 E.?. SubmissionFileFile - E.on $ f1 E.?. FileTitle E.==. f2 E.?. FileTitle - E.&&. sf1 E.?. SubmissionFileSubmission E.==. sf2 E.?. SubmissionFileSubmission - E.&&. sf1 E.?. SubmissionFileId E.!=. sf2 E.?. SubmissionFileId - E.&&. sf2 E.?. SubmissionFileIsDeletion E.==. E.val (Just False) - E.on $ f1 E.?. FileId E.==. sf1 E.?. SubmissionFileFile - - E.where_ $ (sf1 E.?. SubmissionFileIsUpdate E.==. E.val (Just False) E.||. E.isNothing (sf1 E.?. SubmissionFileIsUpdate)) - E.&&. (sf2 E.?. SubmissionFileIsUpdate E.==. E.val (Just True) E.||. E.isNothing (sf2 E.?. SubmissionFileIsUpdate)) - E.&&. (sf2 E.?. SubmissionFileIsDeletion E.==. E.val (Just False) E.||. E.isNothing (sf2 E.?. SubmissionFileIsDeletion)) - E.&&. (sf1 E.?. SubmissionFileSubmission E.==. E.val (Just smid) E.||. sf2 E.?. SubmissionFileSubmission E.==. E.val (Just smid)) - - return ((sf1, f1), (sf2, f2)) - smid2ArchiveTable (smid,cid) = DBTable - { dbtSQLQuery = submissionFiles smid - , dbtRowKey = \((_ `E.InnerJoin` f1) `E.FullOuterJoin` (_ `E.InnerJoin` f2)) -> (f1 E.?. FileId, f2 E.?. FileId) - , dbtColonnade = colonnadeFiles cid - , dbtProj = return . dbrOutput - , dbtStyle = def - , dbtIdent = "files" :: Text - , dbtSorting = Map.fromList - [ ( "path" - , SortColumn $ \((_sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (_sf2 `E.InnerJoin` f2)) -> E.coalesce [f1 E.?. FileTitle, f2 E.?. FileTitle] - ) - , ( "time" - , SortColumn $ \((_sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (_sf2 `E.InnerJoin` f2)) -> (E.unsafeSqlFunction "GREATEST" ([f1 E.?. FileModified, f2 E.?. FileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime))) - ) - ] - , dbtFilter = mempty - , dbtFilterUI = mempty - , dbtParams = def - , dbtCsvEncode = noCsvEncode - , dbtCsvDecode = Nothing - } - mFileTable <- traverse (runDB . dbTableWidget' def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid - - - showCorrection <- fmap (fromMaybe False) . for mcid $ \cid -> hasReadAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR - - let correctionWdgt = guardOnM (showCorrection && maybe False submissionRatingDone msubmission) ((,) <$> msubmission <*> mcid) <&> \(Submission{..}, cid) -> - let ratingComment = assertM (not . null) $ Text.strip <$> submissionRatingComment - in $(widgetFile "correction-user") - - - defaultLayout $ do - setTitleI $ MsgSubmissionEditHead tid ssh csh shn - let urlArchive cID = CSubmissionR tid ssh csh shn cID $ SubArchiveR SubmissionCorrected - urlOriginal cID = CSubmissionR tid ssh csh shn cID $ SubArchiveR SubmissionOriginal - $(widgetFile "submission") - -getSInviteR, postSInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html -getSInviteR = postSInviteR -postSInviteR = invitationR submissionUserInvitationConfig - - -getSubDownloadR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent -getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do - (submissionID, isRating) <- runDB $ do - submissionID <- submissionMatchesSheet tid ssh csh shn cID - - isRating <- (== Just submissionID) <$> isRatingFile path - - when (isUpdate || isRating) $ - guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False - - return (submissionID, isRating) - - case isRating of - True - | isUpdate -> runDB $ do - file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID) - maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file - | otherwise -> notFound - False -> do - let results = (.| Conduit.map entityVal) . E.selectSource . 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.&&. f E.^. FileTitle E.==. E.val path - E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion) - E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate - -- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204 - return f - - serveOneFile results - -getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> Handler TypedContent -getSubArchiveR tid ssh csh shn cID sfType = do - when (sfType == SubmissionCorrected) $ - guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False - - sfType' <- ap getMessageRender $ pure sfType - archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgSubmissionTypeArchiveName tid ssh csh shn cID sfType' - - let source = do - submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID - rating <- lift $ getRating submissionID - - case sfType of - SubmissionOriginal -> (.| Conduit.map entityVal) . E.selectSource . 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.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val False - return f - _ -> submissionFileSource submissionID .| Conduit.map entityVal - - when (sfType == SubmissionCorrected) $ - maybe (return ()) (yieldM . ratingFile cID) rating - - serveSomeFiles archiveName source - -getSubDelR, postSubDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html -getSubDelR = postSubDelR -postSubDelR tid ssh csh shn cID = do - subId <- runDB $ submissionMatchesSheet tid ssh csh shn cID - deleteR $ (submissionDeleteRoute $ Set.singleton subId) - { drAbort = SomeRoute $ CSubmissionR tid ssh csh shn cID SubShowR - , drSuccess = SomeRoute $ CSheetR tid ssh csh shn SShowR - } - - -getCorrectionsDownloadR :: Handler TypedContent -getCorrectionsDownloadR = do -- download all assigned and open submissions - uid <- requireAuthId - subs <- runDB $ selectKeysList - [ SubmissionRatingBy ==. Just uid - , SubmissionRatingTime ==. Nothing - ] [] - when (null subs) $ do - addMessageI Info MsgNoOpenSubmissions - redirect CorrectionsR - submissionMultiArchive SubmissionDownloadAnonymous $ Set.fromList subs - - -getSubAssignR, postSubAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html -getSubAssignR = postSubAssignR -postSubAssignR tid ssh csh shn cID = do - let actionUrl = CSubmissionR tid ssh csh shn cID SubAssignR - sId <- decrypt cID - (currentCorrector, sheetCorrectors) <- runDB $ do - Submission{submissionRatingBy, submissionSheet} <- get404 sId - sheetCorrectors <- map (sheetCorrectorUser . entityVal) <$> selectList [SheetCorrectorSheet ==. submissionSheet] [] - userCorrector <- traverse getJustEntity submissionRatingBy - return (userCorrector, maybe id (:) submissionRatingBy sheetCorrectors) - - $logDebugS "SubAssignR" $ tshow currentCorrector - let correctorField = selectField $ optionsPersistCryptoId [UserId <-. sheetCorrectors] [Asc UserSurname, Asc UserDisplayName] userDisplayName - ((corrResult, corrForm'), corrEncoding) <- runFormPost . renderAForm FormStandard $ - aopt correctorField (fslI MsgCorrector) (Just currentCorrector) - formResult corrResult $ \(fmap entityKey -> mbUserId) -> do - when (mbUserId /= fmap entityKey currentCorrector) . runDB $ do - now <- liftIO getCurrentTime - update sId [ SubmissionRatingBy =. mbUserId - , SubmissionRatingAssigned =. (now <$ mbUserId) - ] - addMessageI Success MsgCorrectorUpdated - sub <- getJust sId - audit $ TransactionSubmissionEdit sId $ sub ^. _submissionSheet - redirect actionUrl - let corrForm = wrapForm' BtnSave corrForm' def - { formAction = Just $ SomeRoute actionUrl - , formEncoding = corrEncoding - , formSubmit = FormSubmit - } - defaultLayout $ do - setTitleI MsgCorrectorAssignTitle - $(widgetFile "submission-assign") diff --git a/src/Handler/Submission/Assign.hs b/src/Handler/Submission/Assign.hs new file mode 100644 index 000000000..5010f736a --- /dev/null +++ b/src/Handler/Submission/Assign.hs @@ -0,0 +1,42 @@ +module Handler.Submission.Assign + ( getSubAssignR, postSubAssignR + ) where + +import Import + +import Handler.Utils + + +getSubAssignR, postSubAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html +getSubAssignR = postSubAssignR +postSubAssignR tid ssh csh shn cID = do + let actionUrl = CSubmissionR tid ssh csh shn cID SubAssignR + sId <- decrypt cID + (currentCorrector, sheetCorrectors) <- runDB $ do + Submission{submissionRatingBy, submissionSheet} <- get404 sId + sheetCorrectors <- map (sheetCorrectorUser . entityVal) <$> selectList [SheetCorrectorSheet ==. submissionSheet] [] + userCorrector <- traverse getJustEntity submissionRatingBy + return (userCorrector, maybe id (:) submissionRatingBy sheetCorrectors) + + $logDebugS "SubAssignR" $ tshow currentCorrector + let correctorField = selectField $ optionsPersistCryptoId [UserId <-. sheetCorrectors] [Asc UserSurname, Asc UserDisplayName] userDisplayName + ((corrResult, corrForm'), corrEncoding) <- runFormPost . renderAForm FormStandard $ + aopt correctorField (fslI MsgCorrector) (Just currentCorrector) + formResult corrResult $ \(fmap entityKey -> mbUserId) -> do + when (mbUserId /= fmap entityKey currentCorrector) . runDB $ do + now <- liftIO getCurrentTime + update sId [ SubmissionRatingBy =. mbUserId + , SubmissionRatingAssigned =. (now <$ mbUserId) + ] + addMessageI Success MsgCorrectorUpdated + sub <- getJust sId + audit $ TransactionSubmissionEdit sId $ sub ^. _submissionSheet + redirect actionUrl + let corrForm = wrapForm' BtnSave corrForm' def + { formAction = Just $ SomeRoute actionUrl + , formEncoding = corrEncoding + , formSubmit = FormSubmit + } + defaultLayout $ do + setTitleI MsgCorrectorAssignTitle + $(widgetFile "submission-assign") diff --git a/src/Handler/Submission/Delete.hs b/src/Handler/Submission/Delete.hs new file mode 100644 index 000000000..e2cd1d190 --- /dev/null +++ b/src/Handler/Submission/Delete.hs @@ -0,0 +1,20 @@ +module Handler.Submission.Delete + ( getSubDelR, postSubDelR + ) where + +import Import + +import Handler.Utils.Delete +import Handler.Utils.Submission + +import qualified Data.Set as Set + + +getSubDelR, postSubDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html +getSubDelR = postSubDelR +postSubDelR tid ssh csh shn cID = do + subId <- runDB $ submissionMatchesSheet tid ssh csh shn cID + deleteR $ (submissionDeleteRoute $ Set.singleton subId) + { drAbort = SomeRoute $ CSubmissionR tid ssh csh shn cID SubShowR + , drSuccess = SomeRoute $ CSheetR tid ssh csh shn SShowR + } diff --git a/src/Handler/Submission/Download.hs b/src/Handler/Submission/Download.hs new file mode 100644 index 000000000..881f27b8e --- /dev/null +++ b/src/Handler/Submission/Download.hs @@ -0,0 +1,71 @@ +module Handler.Submission.Download + ( getSubDownloadR + , getSubArchiveR + ) where + +import Import + +import Handler.Utils +import Handler.Utils.Submission + +import qualified Data.Text.Encoding as Text + +import qualified Database.Esqueleto as E + +import qualified Data.Conduit.Combinators as Conduit + + +getSubDownloadR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent +getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do + (submissionID, isRating) <- runDB $ do + submissionID <- submissionMatchesSheet tid ssh csh shn cID + + isRating <- (== Just submissionID) <$> isRatingFile path + + when (isUpdate || isRating) $ + guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False + + return (submissionID, isRating) + + case isRating of + True + | isUpdate -> runDB $ do + file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID) + maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file + | otherwise -> notFound + False -> do + let results = (.| Conduit.map entityVal) . E.selectSource . 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.&&. f E.^. FileTitle E.==. E.val path + E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion) + E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate + -- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204 + return f + + serveOneFile results + +getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> Handler TypedContent +getSubArchiveR tid ssh csh shn cID sfType = do + when (sfType == SubmissionCorrected) $ + guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False + + sfType' <- ap getMessageRender $ pure sfType + archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgSubmissionTypeArchiveName tid ssh csh shn cID sfType' + + let source = do + submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID + rating <- lift $ getRating submissionID + + case sfType of + SubmissionOriginal -> (.| Conduit.map entityVal) . E.selectSource . 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.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val False + return f + _ -> submissionFileSource submissionID .| Conduit.map entityVal + + when (sfType == SubmissionCorrected) $ + maybe (return ()) (yieldM . ratingFile cID) rating + + serveSomeFiles archiveName source diff --git a/src/Handler/Submission/Helper.hs b/src/Handler/Submission/Helper.hs new file mode 100644 index 000000000..631dca54e --- /dev/null +++ b/src/Handler/Submission/Helper.hs @@ -0,0 +1,555 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} + +module Handler.Submission.Helper + ( submissionHelper + ) where + +import Import + +import Jobs + +import Handler.Utils +import Handler.Utils.Submission +import Handler.Utils.Invitations + +import Data.Maybe (fromJust) + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Internal.Sql as E (unsafeSqlFunction) + +import qualified Data.Conduit.Combinators as Conduit + +import qualified Data.Set as Set +import Data.Map ((!), (!?)) +import qualified Data.Map as Map +import qualified Data.Text as Text + +import Text.Blaze (Markup) +import qualified Data.Aeson.Types as JSON +import Data.Aeson.Lens + + +import Handler.Submission.SubmissionUserInvite + + +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' + where + miCell' :: Markup -> Either UserEmail UserId -> Widget + miCell' csrf (Left email) = do + invWarnMsg <- messageIconI Info IconEmail $ if + | isLecturer -> MsgEmailInvitationWarningCourseParticipants + | otherwise -> MsgEmailInvitationWarningPrevCoSubmittors + $(widgetFile "widgets/massinput/submissionUsers/cellInvitation") + miCell' csrf (Right uid) = do + User{..} <- liftHandler . runDB $ getJust uid + $(widgetFile "widgets/massinput/submissionUsers/cellKnown") + + miLayout :: ListLength + -> Map ListPosition (Either UserEmail UserId, FormResult ()) -- ^ massInput state + -> Map ListPosition Widget -- ^ Cell widgets + -> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons + -> Map (Natural, ListPosition) Widget -- ^ Addition widgets + -> Widget + miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/submissionUsers/layout") + + miIdent :: Text + miIdent = "submittors" + + courseUsers :: E.SqlQuery (E.SqlExpr (Entity User)) + courseUsers = E.from $ \(user `E.InnerJoin` participant) -> do + E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser + E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid + E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive + E.orderBy [E.asc $ user E.^. UserEmail] + return user + previousCoSubmittors :: UserId -> E.SqlQuery (E.SqlExpr (Entity User)) + previousCoSubmittors uid = E.from $ \(user `E.InnerJoin` submissionUser `E.InnerJoin` submission `E.InnerJoin` sheet) -> do + E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet + E.&&. sheet E.^. SheetCourse E.==. E.val cid + E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission + E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser + E.where_ . E.exists . E.from $ \submissionUser' -> + E.where_ $ submissionUser' E.^. SubmissionUserUser E.==. E.val uid + E.&&. submissionUser' E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId + E.where_ . E.exists . E.from $ \participant -> + E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid + E.&&. participant E.^. CourseParticipantUser E.==. user E.^. UserId + E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive + E.orderBy [E.asc $ user E.^. UserEmail] + return user + + addField :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> Field m (Set (Either UserEmail UserId)) + addField uid = multiUserInvitationField . MUILookupSuggested (SomeMessage MsgMultiUserFieldExplanationPrevCoSubmittors) $ previousCoSubmittors uid + addFieldLecturer = multiUserInvitationField $ MUILookupSuggested (SomeMessage MsgMultiUserFieldExplanationCourseParticipants) courseUsers + + addFieldSettings :: (forall msg. RenderMessage UniWorX msg => msg -> Text) -> FieldSettings UniWorX + addFieldSettings mr = fslpI MsgSubmissionMembers $ mr MsgLdapIdentificationOrEmail + submittorSettings, singleSubSettings :: FieldSettings UniWorX + submittorSettings = fslI MsgSubmissionMembers + singleSubSettings = fslI MsgSubmissionMember + + maxSize | Arbitrary{..} <- grouping = Just maxParticipants + | otherwise = Nothing + mayEdit = is _Arbitrary grouping + + submittorSettings' + | maxSize > Just 1 = submittorSettings + | otherwise = singleSubSettings + + 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 + miAdd :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId]) + miAdd nudge btn csrf = do + MsgRenderer mr <- getMsgRenderer + (addRes, addView) <- mpreq addFieldLecturer (addFieldSettings mr & addName (nudge "emails")) Nothing + let addRes' = addRes <&> \newData oldData -> if + | existing <- newData `Set.intersection` Set.fromList oldData + , not $ Set.null existing + -> FormFailure [mr MsgSubmissionUserAlreadyAdded] + | otherwise + -> FormSuccess $ Set.toList newData + return (addRes', $(widgetFile "widgets/massinput/submissionUsers/add")) + + mRoute <- getCurrentRoute + submittors <- massInputAccumW miAdd (miCell' mempty) (miButtonAction' mRoute) miLayout miIdent submittorSettings True (Just $ Set.toList prefillUsers) + MsgRenderer mr <- getMsgRenderer + return $ submittors >>= \submittors' -> if + | null submittors' -> FormFailure [mr MsgSubmissionUsersEmpty] + | otherwise -> FormSuccess $ Set.fromList submittors' + | otherwise = do + uid <- liftHandler requireAuthId + mRoute <- getCurrentRoute + + let + miAdd :: ListPosition + -> Natural + -> (Text -> Text) + -> FieldView UniWorX + -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId)))) + miAdd _ _ nudge btn = Just $ \csrf -> do + MsgRenderer mr <- getMsgRenderer + (addRes, addView) <- mpreq (addField uid) (addFieldSettings mr & addName (nudge "emails")) Nothing + let addRes' = addRes <&> \newData oldData -> if + | existing <- newData `Set.intersection` setOf folded oldData + , not $ Set.null existing + -> FormFailure [mr MsgSubmissionUserAlreadyAdded] + | otherwise -> let numStart = maybe 0 (succ . fst) $ Map.lookupMax oldData + in FormSuccess . Map.fromList . zip [numStart..] $ Set.toList newData + return (addRes', $(widgetFile "widgets/massinput/submissionUsers/add")) + + miCell :: ListPosition + -> Either UserEmail UserId + -> Maybe () + -> (Text -> Text) + -> Form () + miCell _ dat _ _ csrf = return (FormSuccess (), miCell' csrf dat) + + miDelete :: Map ListPosition (Either UserEmail UserId) + -> ListPosition + -> MaybeT (MForm Handler) (Map ListPosition ListPosition) + miDelete dat delPos = do + guard mayEdit + guard $ Map.size dat > 1 + + -- User may drop from submission only if it already exists; no directly creating submissions for other people + guard $ maybe True (/= Right uid) (dat !? delPos) || isJust msmid + + miDeleteList dat delPos + + miAllowAdd :: ListPosition + -> Natural + -> ListLength + -> Bool + miAllowAdd _ _ l = mayEdit && maybe False ((l <) . fromIntegral) maxSize + + miAddEmpty _ _ _ = Set.empty + + miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) + miButtonAction = miButtonAction' mRoute + + postProcess :: Map ListPosition (Either UserEmail UserId, ()) -> Set (Either UserEmail UserId) + postProcess valMap + | is _Just msmid + , resultUsers == prefillUsers + = resultUsers + | Just maxSize' <- maxSize + , fromIntegral maxSize' >= Set.size resultUsers + = resultUsers + | Just maxSize' <- maxSize + = let resultUsers' = Set.take (fromIntegral maxSize') resultUsers + in if | Set.member (Right uid) resultUsers' -> resultUsers' + | otherwise -> Set.insert (Right uid) $ Set.take (pred $ fromIntegral maxSize') resultUsers' + | otherwise = Set.singleton $ Right uid + where resultUsers = setOf (folded . _1) valMap + -- when (maxSize > Just 1) $ + -- wformMessage =<< messageI Info MsgCosubmittorTip + fmap postProcess <$> massInputW MassInput{..} submittorSettings' True (Just . Map.fromList . zip [0..] . map (, ()) $ Set.toList prefillUsers) + +submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe CryptoFileNameSubmission -> Handler Html +submissionHelper tid ssh csh shn mcid = do + muid <- maybeAuthId + msmid <- traverse decrypt mcid + actionUrl <- fromMaybe (error "submissionHelper called from 404-handler") <$> getCurrentRoute + + (Entity shid Sheet{..}, buddies, lastEdits, maySubmit, isLecturer, isOwner, msubmission, corrector) <- runDB $ do + csheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn + maySubmit <- (== Authorized) <$> evalAccessDB actionUrl True + isLecturer <- (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SSubsR) True + + submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do + E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission) + E.where_ $ E.just (submissionUser E.^. SubmissionUserUser) E.==. E.val muid + E.&&. submission E.^. SubmissionSheet E.==. E.val shid + return $ submission E.^. SubmissionId + case (msmid, submissions) of + (Nothing, E.Value smid : _) -> do + cID <- encrypt smid + addMessageI Info MsgSubmissionAlreadyExists + redirect $ CSubmissionR tid ssh csh shn cID SubShowR + _other -> return () + + case (msmid, sheetGrouping) of + (Nothing, Arbitrary maxBuddies) -> do + -- fetch buddies from previous submission in this course + buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do + E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId) + let oldids = E.subList_select . E.from $ \(sheet `E.InnerJoin` submission `E.InnerJoin` subUser `E.InnerJoin` submissionEdit) -> do + E.on (submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId) + E.on (subUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId) + E.on (sheet E.^. SheetId E.==. submission E.^. SubmissionSheet) + E.where_ $ E.just (subUser E.^. SubmissionUserUser) E.==. E.val muid + E.&&. sheet E.^. SheetCourse E.==. E.val sheetCourse + E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime] + E.limit 1 + return $ submission E.^. SubmissionId + E.where_ $ submissionUser E.^. SubmissionUserSubmission `E.in_` oldids + E.&&. E.just (submissionUser E.^. SubmissionUserUser) E.!=. E.val muid + E.orderBy [E.asc $ user E.^. UserEmail] + return $ user E.^. UserId + return ( csheet + , buddies + & map (Right . E.unValue) + & Set.fromList + & assertM' ((<= maxBuddies) . fromIntegral . Set.size . bool id (maybe id (Set.insert . Right) muid) (not isLecturer)) + & fromMaybe Set.empty + , [] + , maySubmit + , isLecturer + , not isLecturer + , Nothing, Nothing + ) + (Nothing, RegisteredGroups) -> do + buddies <- E.select . E.from $ \(submissionGroup `E.InnerJoin` user) -> do + E.on . E.exists . E.from $ \submissionGroupUser -> + E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. user E.^. UserId + E.&&. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId + E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse + E.where_ . E.exists . E.from $ \submissionGroupUser -> + E.where_ $ E.just (submissionGroupUser E.^. SubmissionGroupUserUser) E.==. E.val muid + E.&&. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId + E.where_ $ E.just (user E.^. UserId) E.!=. E.val muid + E.where_ . E.not_ . E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do + E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId + E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid + E.&&. submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId + + E.orderBy [E.asc $ user E.^. UserEmail] + + return $ user E.^. UserId + + return ( csheet + , buddies + & map (Right . E.unValue) + & Set.fromList + , [] + , maySubmit + , isLecturer + , not isLecturer + , Nothing, Nothing + ) + (Nothing, _) -> return (csheet, Set.empty, [], maySubmit, isLecturer, not isLecturer, Nothing, Nothing) + (Just smid, _) -> do + void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid) + + sub@Submission{..} <- get404 smid + let shid' = submissionSheet + unless (shid == shid') $ + invalidArgsI [MsgSubmissionWrongSheet] + -- fetch buddies from current submission + (Any isOwner, buddies) <- do + submittors <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do + E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId) + E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smid + E.orderBy [E.asc $ user E.^. UserEmail] + return $ user E.^. UserId + let breakUserFromBuddies (E.Value userID) + | muid == Just userID = (Any True , mempty ) + | otherwise = (mempty , Set.singleton $ Right userID) + + invites <- sourceInvitationsF smid <&> Set.fromList . map (\(email, InvDBDataSubmissionUser) -> Left email) + + return . over _2 (Set.union invites) $ foldMap breakUserFromBuddies submittors + + lastEdits <- do + raw <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do + E.on $ E.just (user E.^. UserId) E.==. submissionEdit E.^. SubmissionEditUser + E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid + E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime] + -- E.limit numberOfSubmissionEditDates -- DEPRECATED we always show all edit times + let userName = if isOwner || maySubmit + then E.just $ user E.^. UserDisplayName + else E.nothing + return (userName, submissionEdit E.^. SubmissionEditTime) + forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time + + corrector <- fmap join $ traverse getEntity submissionRatingBy + + return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner,Just sub,corrector) + + if | is _Nothing muid + , is _Nothing msubmission + , not isLecturer + -> notAuthenticated + | otherwise + -> return () + + -- @submissionModeUser == Nothing@ below iff we are currently serving a user with elevated rights (lecturer, admin, ...) + -- Therefore we do not restrict upload behaviour in any way in that case + ((res,formWidget'), formEnctype) <- runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (UploadAny True Nothing) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (maybe id (Set.insert . Right) muid) isOwner buddies + let formWidget = wrapForm' BtnHandIn formWidget' def + { formAction = Just $ SomeRoute actionUrl + , formEncoding = formEnctype + } + + mCID <- fmap join . msgSubmissionErrors . runDBJobs $ do + -- Determine old submission users + subUsersOld <- if + | Just smid <- msmid -> Set.union + <$> (setOf (folded . _entityVal . _submissionUserUser . to Right) <$> selectList [SubmissionUserSubmission ==. smid] []) + <*> (sourceInvitationsF smid <&> Set.fromList . map (\(email, InvDBDataSubmissionUser) -> Left email)) + | otherwise -> return Set.empty + + res' <- case res of + FormMissing -> return FormMissing + (FormFailure failmsgs) -> return $ FormFailure failmsgs + (FormSuccess res'@(_, groupMembers)) + | groupMembers == subUsersOld -> return $ FormSuccess res' + | Arbitrary{..} <- sheetGrouping -> do -- Validate AdHoc Group Members + let (gEMails, gIds) = partitionEithers $ Set.toList groupMembers + prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map UserEmail (Maybe (UserId, Bool, Bool)) + prep ps = Map.fromList $ map (, Nothing) gEMails ++ [(m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps] + participants <- fmap prep . E.select . E.from $ \user -> do + E.where_ $ (user E.^. UserId) `E.in_` E.valList gIds + let + isParticipant = E.exists . E.from $ \courseParticipant -> do + E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser + E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val sheetCourse + E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive + hasSubmitted = E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do + E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId + E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId + E.&&. submission E.^. SubmissionSheet E.==. E.val shid + case msmid of -- Multiple `E.where_`-Statements are merged with `&&` in esqueleto 2.5.3 + Nothing -> return () + Just smid -> E.where_ $ submission E.^. SubmissionId E.!=. E.val smid + return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted)) + + $logDebugS "SUBMISSION.AdHocGroupValidation" $ tshow participants + + mr <- getMessageRender + let + failmsgs = (concat :: [[Text]] -> [Text]) + [ flip Map.foldMapWithKey participants $ \email -> \case + -- Nothing -> pure . mr $ MsgEMailUnknown email + (Just (_,False,_)) -> pure . mr $ MsgNotAParticipant email tid csh + (Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor email + _other -> mempty + , case fromIntegral (Map.size participants) `compare` maxParticipants of + GT | not isLecturer -> pure $ mr MsgTooManyParticipants + _ -> mempty + ] + return $ if null failmsgs + then FormSuccess res' + else FormFailure failmsgs + | otherwise -> return $ FormSuccess res' + + + case res' of + (FormSuccess (mFiles, adhocMembers)) -> do + smid <- do + smid <- case (mFiles, msmid) of + (Nothing, Just smid) -- no new files, existing submission partners updated + -> return smid + (Just files, _) -> -- new files + runConduit $ transPipe (lift . lift) files .| Conduit.mapM (either get404 return) .| extractRatingsMsg .| sinkSubmission muid (maybe (Left shid) Right msmid) False + (Nothing, Nothing) -- new submission, no file upload requested + -> do + sid <- insert Submission + { submissionSheet = shid + , submissionRatingPoints = Nothing + , submissionRatingComment = Nothing + , submissionRatingBy = Nothing + , submissionRatingAssigned = Nothing + , submissionRatingTime = Nothing + } + audit $ TransactionSubmissionEdit sid shid + return sid + + -- Determine new submission users + subUsers <- if + | isLecturer -> return adhocMembers + | RegisteredGroups <- sheetGrouping -> do + -- Determine members of pre-registered group + groupUids <- fmap (setFromList . map (Right . E.unValue)) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do + E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup + E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId + E.where_ $ E.just (submissionGroupUser E.^. SubmissionGroupUserUser) E.==. E.val muid + E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse + + E.where_ . E.not_ . E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do + E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId + E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid + E.&&. submissionUser E.^. SubmissionUserUser E.==. submissionGroupUser' E.^. SubmissionGroupUserUser + E.where_ $ submission E.^. SubmissionId E.!=. E.val smid + + return $ submissionGroupUser' E.^. SubmissionGroupUserUser + -- SubmissionUser for all group members (pre-registered & ad-hoc) + return $ maybe id (Set.insert . Right) muid groupUids + | otherwise -> return adhocMembers + + -- Since invitations carry no data we only need to consider changes to + -- the set of users/invited emails + -- Otherwise we would have to update old invitations (via + -- `sinkInvitationsF`) because their associated @DBData@ might have + -- changed + + forM_ (subUsers `setSymmDiff` subUsersOld) $ \change -> if + -- change is a new user being added to the submission users => send invitation / insert + | change `Set.member` subUsers -> case change of + Left subEmail -> do + -- user does not exist yet => send invitation + sinkInvitationsF submissionUserInvitationConfig [(subEmail, smid, (InvDBDataSubmissionUser, InvTokenDataSubmissionUser))] + return () + Right subUid -> do + -- user exists and has an id => insert as SubmissionUser and audit + insert_ $ SubmissionUser subUid smid + audit $ TransactionSubmissionUserEdit smid subUid + unless (Just subUid == muid) $ + queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated subUid smid + -- change is an old user that is not a submission user anymore => delete invitation / delete + | otherwise -> case change of + Left subEmail -> deleteInvitation @SubmissionUser smid subEmail + Right subUid -> do + deleteBy $ UniqueSubmissionUser subUid smid + audit $ TransactionSubmissionUserDelete smid subUid + unless (Just subUid == muid) $ + queueDBJob . JobQueueNotification $ NotificationSubmissionUserDeleted subUid shid smid + + addMessageI Success $ if | Nothing <- msmid -> MsgSubmissionCreated + | otherwise -> MsgSubmissionUpdated + return smid + cID <- encrypt smid + return $ Just cID + (FormFailure msgs) -> Nothing <$ forM_ msgs (addMessage Warning . toHtml) + _other -> return Nothing + + case mCID of + Just cID -> do + let showRoute = CSubmissionR tid ssh csh shn cID SubShowR + mayShow <- hasReadAccessTo showRoute + if + | mayShow -> redirect showRoute + | otherwise -> redirect $ CSheetR tid ssh csh shn SShowR + Nothing -> return () + + -- Maybe construct a table to display uploaded archive files + let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerFor UniWorX) ()) + colonnadeFiles cid = mconcat + [ sortable (Just "path") (i18nCell MsgFileTitle) $ \(coalesce -> (mOrig, mCorr)) -> let + Just fileTitle' = fileTitle . entityVal . snd <$> (mOrig <|> mCorr) + origIsFile = fmap (isJust . fileContent . entityVal . snd) mOrig + corrIsFile = fmap (isJust . fileContent . entityVal . snd) mCorr + Just isFile = origIsFile <|> corrIsFile + in if + | Just True <- origIsFile -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionOriginal fileTitle') + [whamlet|#{fileTitle'}|] + | otherwise -> textCell $ bool (<> "/") id isFile fileTitle' + , sortable (toNothing "state") (i18nCell MsgCorState) $ \(coalesce -> (_, mCorr)) -> case mCorr of + Nothing -> cell mempty + Just (_, Entity _ File{..}) + | isJust fileContent -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionCorrected fileTitle) + [whamlet|_{MsgFileCorrected}|] + | otherwise -> i18nCell MsgCorrected + , sortable (Just "time") (i18nCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let + origTime = fileModified . entityVal . snd <$> mOrig + corrTime = fileModified . entityVal . snd <$> mCorr + Just fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime + in dateTimeCell fileTime + ] + coalesce :: ((Maybe (Entity SubmissionFile), Maybe (Entity File)), (Maybe (Entity SubmissionFile), Maybe (Entity File))) -> (Maybe (Entity SubmissionFile, Entity File), Maybe (Entity SubmissionFile, Entity File)) + coalesce ((ma, mb), (mc, md)) = ((,) <$> ma <*> mb, (,) <$> mc <*> md) + submissionFiles :: _ -> _ -> E.SqlQuery _ + submissionFiles smid ((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) = do + E.on $ f2 E.?. FileId E.==. sf2 E.?. SubmissionFileFile + E.on $ f1 E.?. FileTitle E.==. f2 E.?. FileTitle + E.&&. sf1 E.?. SubmissionFileSubmission E.==. sf2 E.?. SubmissionFileSubmission + E.&&. sf1 E.?. SubmissionFileId E.!=. sf2 E.?. SubmissionFileId + E.&&. sf2 E.?. SubmissionFileIsDeletion E.==. E.val (Just False) + E.on $ f1 E.?. FileId E.==. sf1 E.?. SubmissionFileFile + + E.where_ $ (sf1 E.?. SubmissionFileIsUpdate E.==. E.val (Just False) E.||. E.isNothing (sf1 E.?. SubmissionFileIsUpdate)) + E.&&. (sf2 E.?. SubmissionFileIsUpdate E.==. E.val (Just True) E.||. E.isNothing (sf2 E.?. SubmissionFileIsUpdate)) + E.&&. (sf2 E.?. SubmissionFileIsDeletion E.==. E.val (Just False) E.||. E.isNothing (sf2 E.?. SubmissionFileIsDeletion)) + E.&&. (sf1 E.?. SubmissionFileSubmission E.==. E.val (Just smid) E.||. sf2 E.?. SubmissionFileSubmission E.==. E.val (Just smid)) + + return ((sf1, f1), (sf2, f2)) + smid2ArchiveTable (smid,cid) = DBTable + { dbtSQLQuery = submissionFiles smid + , dbtRowKey = \((_ `E.InnerJoin` f1) `E.FullOuterJoin` (_ `E.InnerJoin` f2)) -> (f1 E.?. FileId, f2 E.?. FileId) + , dbtColonnade = colonnadeFiles cid + , dbtProj = return . dbrOutput + , dbtStyle = def + , dbtIdent = "files" :: Text + , dbtSorting = Map.fromList + [ ( "path" + , SortColumn $ \((_sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (_sf2 `E.InnerJoin` f2)) -> E.coalesce [f1 E.?. FileTitle, f2 E.?. FileTitle] + ) + , ( "time" + , SortColumn $ \((_sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (_sf2 `E.InnerJoin` f2)) -> (E.unsafeSqlFunction "GREATEST" ([f1 E.?. FileModified, f2 E.?. FileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime))) + ) + ] + , dbtFilter = mempty + , dbtFilterUI = mempty + , dbtParams = def + , dbtCsvEncode = noCsvEncode + , dbtCsvDecode = Nothing + } + mFileTable <- traverse (runDB . dbTableWidget' def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid + + + showCorrection <- fmap (fromMaybe False) . for mcid $ \cid -> hasReadAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR + + let correctionWdgt = guardOnM (showCorrection && maybe False submissionRatingDone msubmission) ((,) <$> msubmission <*> mcid) <&> \(Submission{..}, cid) -> + let ratingComment = assertM (not . null) $ Text.strip <$> submissionRatingComment + in $(widgetFile "correction-user") + + + defaultLayout $ do + setTitleI $ MsgSubmissionEditHead tid ssh csh shn + let urlArchive cID = CSubmissionR tid ssh csh shn cID $ SubArchiveR SubmissionCorrected + urlOriginal cID = CSubmissionR tid ssh csh shn cID $ SubArchiveR SubmissionOriginal + $(widgetFile "submission") diff --git a/src/Handler/Submission/New.hs b/src/Handler/Submission/New.hs new file mode 100644 index 000000000..c22da6a70 --- /dev/null +++ b/src/Handler/Submission/New.hs @@ -0,0 +1,12 @@ +module Handler.Submission.New + ( getSubmissionNewR, postSubmissionNewR + ) where + +import Import + +import Handler.Submission.Helper + + +getSubmissionNewR, postSubmissionNewR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html +getSubmissionNewR = postSubmissionNewR +postSubmissionNewR tid ssh csh shn = submissionHelper tid ssh csh shn Nothing diff --git a/src/Handler/Submission/Show.hs b/src/Handler/Submission/Show.hs new file mode 100644 index 000000000..57c07ac42 --- /dev/null +++ b/src/Handler/Submission/Show.hs @@ -0,0 +1,12 @@ +module Handler.Submission.Show + ( getSubShowR, postSubShowR + ) where + +import Import + +import Handler.Submission.Helper + + +getSubShowR, postSubShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html +getSubShowR = postSubShowR +postSubShowR tid ssh csh shn cid = submissionHelper tid ssh csh shn $ Just cid diff --git a/src/Handler/Submission/SubmissionUserInvite.hs b/src/Handler/Submission/SubmissionUserInvite.hs new file mode 100644 index 000000000..1b8491d57 --- /dev/null +++ b/src/Handler/Submission/SubmissionUserInvite.hs @@ -0,0 +1,96 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Handler.Submission.SubmissionUserInvite + ( InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..) + , submissionUserInvitationConfig + , getSInviteR, postSInviteR + ) where + +import Import + +import Handler.Utils.Invitations + +import Data.Aeson hiding (Result(..)) +import Text.Hamlet (ihamlet) + +import qualified Data.HashSet as HashSet + + +instance IsInvitableJunction SubmissionUser where + type InvitationFor SubmissionUser = Submission + data InvitableJunction SubmissionUser = JunctionSubmissionUser + deriving (Eq, Ord, Read, Show, Generic, Typeable) + data InvitationDBData SubmissionUser = InvDBDataSubmissionUser + deriving (Eq, Ord, Read, Show, Generic, Typeable) + data InvitationTokenData SubmissionUser = InvTokenDataSubmissionUser + deriving (Eq, Ord, Read, Show, Generic, Typeable) + + _InvitableJunction = iso + (\SubmissionUser{..} -> (submissionUserUser, submissionUserSubmission, JunctionSubmissionUser)) + (\(submissionUserUser, submissionUserSubmission, JunctionSubmissionUser) -> SubmissionUser{..}) + +instance ToJSON (InvitableJunction SubmissionUser) where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } +instance FromJSON (InvitableJunction SubmissionUser) where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } + +instance ToJSON (InvitationDBData SubmissionUser) where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } +instance FromJSON (InvitationDBData SubmissionUser) where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } + +instance ToJSON (InvitationTokenData SubmissionUser) where + toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } + toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 } +instance FromJSON (InvitationTokenData SubmissionUser) where + parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } + +submissionUserInvitationConfig :: InvitationConfig SubmissionUser +submissionUserInvitationConfig = InvitationConfig{..} + where + invitationRoute (Entity subId Submission{..}) _ = do + Sheet{..} <- getJust submissionSheet + Course{..} <- getJust sheetCourse + cID <- encrypt subId + return $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SInviteR + invitationResolveFor _ = do + cRoute <- getCurrentRoute + case cRoute of + Just (CSubmissionR _tid _ssh _csh _shn cID SInviteR) -> do + subId <- decrypt cID + bool notFound (return subId) =<< existsKey subId + _other -> + error "submissionUserInvitationConfig called from unsupported route" + invitationSubject (Entity _ Submission{..}) _ = do + Sheet{..} <- getJust submissionSheet + Course{..} <- getJust sheetCourse + return . SomeMessage $ MsgMailSubjectSubmissionUserInvitation courseTerm courseSchool courseShorthand sheetName + invitationHeading (Entity _ Submission{..}) _ = do + Sheet{..} <- getJust submissionSheet + return . SomeMessage $ MsgSubmissionUserInviteHeading sheetName + invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSubmissionUserInviteExplanation}|] + invitationTokenConfig (Entity _ Submission{..}) _ = do + Sheet{..} <- getJust submissionSheet + Course{..} <- getJust sheetCourse + itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId + itAddAuth <- either throwM (return . Just) $ routeAuthTags (CSheetR courseTerm courseSchool courseShorthand sheetName SubmissionNewR) + let itExpiresAt = Nothing + itStartsAt = Nothing + return InvitationTokenConfig{..} + invitationRestriction _ _ = return Authorized + invitationForm _ _ _ = pure (JunctionSubmissionUser, ()) + invitationInsertHook _ _ _ _ _ = id + invitationSuccessMsg (Entity _ Submission{..}) _ = do + Sheet{..} <- getJust submissionSheet + return . SomeMessage $ MsgSubmissionUserInvitationAccepted sheetName + invitationUltDest (Entity subId Submission{..}) _ = do + Sheet{..} <- getJust submissionSheet + Course{..} <- getJust sheetCourse + cID <- encrypt subId + return . SomeRoute $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SubShowR + +getSInviteR, postSInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html +getSInviteR = postSInviteR +postSInviteR = invitationR submissionUserInvitationConfig