refactor: split up Handler.Submission
This commit is contained in:
Gregor Kleen
parent
fb50d5b9d0
commit
21af3e1348
@ -8,6 +8,7 @@ module Handler.Corrections
|
|||||||
, getCorrectionsGradeR, postCorrectionsGradeR
|
, getCorrectionsGradeR, postCorrectionsGradeR
|
||||||
, getCAssignR, postCAssignR
|
, getCAssignR, postCAssignR
|
||||||
, getSAssignR, postSAssignR
|
, getSAssignR, postSAssignR
|
||||||
|
, getCorrectionsDownloadR
|
||||||
, correctionsR'
|
, correctionsR'
|
||||||
, ratedBy, courseIs, sheetIs, userIs
|
, ratedBy, courseIs, sheetIs, userIs
|
||||||
, colTerm, colSchool, colCourse, colSheet, colCorrector, colSubmissionLink, colSelect, colSubmittors, colSMatrikel, colRating, colAssigned, colRated, colPseudonyms, colRatedField, colPointsField, colMaxPointsField, colCommentField, colLastEdit
|
, 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
|
setTitleI headingLong
|
||||||
$(widgetFile "corrections-overview")
|
$(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
|
||||||
|
|||||||
@ -1,319 +1,28 @@
|
|||||||
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-uni-patterns #-}
|
|
||||||
|
|
||||||
module Handler.Submission
|
module Handler.Submission
|
||||||
( getSubmissionNewR, postSubmissionNewR
|
( getSubmissionOwnR
|
||||||
, getSubShowR, postSubShowR
|
, module Handler.Submission.New
|
||||||
, getSubmissionOwnR
|
, module Handler.Submission.Show
|
||||||
, getSInviteR, postSInviteR
|
, module Handler.Submission.Download
|
||||||
, getSubDownloadR
|
, module Handler.Submission.Delete
|
||||||
, getSubArchiveR
|
, module Handler.Submission.Assign
|
||||||
, getSubDelR, postSubDelR
|
, module Handler.Submission.SubmissionUserInvite
|
||||||
, getCorrectionsDownloadR
|
|
||||||
, getSubAssignR, postSubAssignR
|
|
||||||
) where
|
) 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 Import
|
||||||
|
|
||||||
import Jobs
|
|
||||||
|
|
||||||
-- import Yesod.Form.Bootstrap3
|
|
||||||
|
|
||||||
import Handler.Utils
|
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 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 :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||||
getSubmissionOwnR tid ssh csh shn = do
|
getSubmissionOwnR tid ssh csh shn = do
|
||||||
authId <- requireAuthId
|
authId <- requireAuthId
|
||||||
@ -329,475 +38,3 @@ getSubmissionOwnR tid ssh csh shn = do
|
|||||||
[] -> notFound
|
[] -> notFound
|
||||||
cID <- encrypt sid
|
cID <- encrypt sid
|
||||||
redirect $ CSubmissionR tid ssh csh shn cID SubShowR
|
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")
|
|
||||||
|
|||||||
42
src/Handler/Submission/Assign.hs
Normal file
42
src/Handler/Submission/Assign.hs
Normal file
@ -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")
|
||||||
20
src/Handler/Submission/Delete.hs
Normal file
20
src/Handler/Submission/Delete.hs
Normal file
@ -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
|
||||||
|
}
|
||||||
71
src/Handler/Submission/Download.hs
Normal file
71
src/Handler/Submission/Download.hs
Normal file
@ -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
|
||||||
555
src/Handler/Submission/Helper.hs
Normal file
555
src/Handler/Submission/Helper.hs
Normal file
@ -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")
|
||||||
12
src/Handler/Submission/New.hs
Normal file
12
src/Handler/Submission/New.hs
Normal file
@ -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
|
||||||
12
src/Handler/Submission/Show.hs
Normal file
12
src/Handler/Submission/Show.hs
Normal file
@ -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
|
||||||
96
src/Handler/Submission/SubmissionUserInvite.hs
Normal file
96
src/Handler/Submission/SubmissionUserInvite.hs
Normal file
@ -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
|
||||||
Reference in New Issue
Block a user