diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 7030d0c15..ed32f7571 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -198,11 +198,13 @@ SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt. SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt. SubmissionEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName}: Abgabe editieren/anlegen CorrectionHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{display tid}-#{display ssh}-#{csh} #{sheetName}: Korrektur -SubmissionMember n@Int: Mitabgebende(r) ##{display n} +SubmissionMembers: Abgebende SubmissionArchive: Zip-Archiv der Abgabedatei(en) SubmissionFile: Datei zur Abgabe SubmissionFiles: Abgegebene Dateien -SubmissionAlreadyExistsFor email@UserEmail: #{email} hat bereits eine Abgabe zu diesem bÜbungsblatt. +SubmissionAlreadyExistsFor email@UserEmail: #{email} hat bereits eine Abgabe zu diesem Übungsblatt. +SubmissionUsersEmpty: Es kann keine Abgabe ohne Abgebende erstellt werden +SubmissionUserAlreadyAdded: Dieser Nutzer ist bereits als Mitabgebende(r) eingetragen SubmissionsDeleteQuestion n@Int: Wollen Sie #{pluralDE n "die unten aufgeführte Abgabe" "die unten aufgeführten Abgaben"} wirklich löschen? SubmissionsDeleted n@Int: #{pluralDE n "Abgabe gelöscht" "Abgaben gelöscht"} @@ -508,6 +510,7 @@ BothSubmissions: Abgabe direkt & extern mit Pseudonym SheetCorrectorSubmissionsTip: Abgabe erfolgt über ein Uni2work-externes Verfahren (zumeist in Papierform durch Einwurf) unter Angabe eines persönlichen Pseudonyms. Korrektorn können mithilfe des Pseudonyms später Korrekturergebnisse in Uni2work eintragen, damit Sie sie einsehen können. SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen. +SubmissionReplace: Abgabe ersetzen AdminFeaturesHeading: Studiengänge StudyTerms: Studiengänge @@ -586,6 +589,8 @@ MailSubjectCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@S MailSubjectTutorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand tutn@TutorialName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Tutor für #{tutn} +MailSubjectSubmissionUserInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{display tid}-#{display ssh}-#{csh}] Einladung zu einer Abgabe für #{shn} + SheetGrading: Bewertung SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten @@ -863,6 +868,11 @@ TutorInvitationDeclined tutn@TutorialName: Sie haben die Einladung, Tutor für # TutorInviteHeading tutn@TutorialName: Einladung zum Tutor für #{tutn} TutorInviteExplanation: Sie wurden eingeladen, Tutor zu sein. +SubmissionUserInvitationAccepted shn@SheetName: Sie wurden als Mitabgebende(r) für eine Abgabe zu #{shn} eingetragen +SubmissionUserInvitationDeclined shn@SheetName: Sie haben die Einladung, Mitabgebende(r) für #{shn} zu werden, abgelehnt +SubmissionUserInviteHeading shn@SheetName: Einladung zu einer Abgabe für #{shn} +SubmissionUserInviteExplanation: Sie wurden eingeladen, Mitabgebende(r) bei einer Abgabe zu sein. + InvitationAction: Aktion InvitationActionTip: Abgelehnte Einladungen können nicht mehr angenommen werden InvitationMissingRestrictions: Authorisierungs-Token fehlen benötigte Daten diff --git a/routes b/routes index 5ecd799a0..89b7fc369 100644 --- a/routes +++ b/routes @@ -107,6 +107,7 @@ /delete SubDelR GET POST !ownerANDtime /assign SAssignR GET POST !lecturerANDtime /correction CorrectionR GET POST !corrector !ownerANDreadANDrated + /invite SInviteR GET POST !ownerANDtime !/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector /correctors SCorrR GET POST /iscorrector SIsCorrR GET !corrector -- Route is used to check for corrector access to this sheet diff --git a/src/Foundation.hs b/src/Foundation.hs index 9161ef86a..d9ec45191 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -155,6 +155,11 @@ instance HasAppSettings UniWorX where -- type Widget = WidgetT UniWorX IO () mkYesodData "UniWorX" $(parseRoutesFile "routes") +deriving instance Generic CourseR +deriving instance Generic SheetR +deriving instance Generic SubmissionR +deriving instance Generic MaterialR +deriving instance Generic TutorialR deriving instance Generic (Route UniWorX) -- | Convenient Type Synonyms: @@ -503,13 +508,19 @@ validateToken mAuthId' route' isWrite' token' = runCachedMemoT $ for4 memo valid User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get tokenAuthority guardMExceptT (Just tokenIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired) + let + -- Prevent infinite loops + noTokenAuth :: AuthDNF -> AuthDNF + noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar + authorityVal <- do dnf <- either throwM return $ routeAuthTags route - fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) dnf (Just tokenAuthority) route isWrite + fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) (Just tokenAuthority) route isWrite guardExceptT (is _Authorized authorityVal) authorityVal whenIsJust tokenAddAuth $ \addDNF -> do - additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) addDNF mAuthId route isWrite + $logDebugS "validateToken" $ tshow addDNF + additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth addDNF) mAuthId route isWrite guardExceptT (is _Authorized additionalVal) additionalVal return Authorized @@ -2108,6 +2119,14 @@ pageActions (CSheetR tid ssh csh shn SSubsR) = , menuItemModal = False , menuItemAccessCallback' = return True } + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuSubmissionNew + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR + , menuItemModal = True + , menuItemAccessCallback' = return True + } ] pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = [ MenuItem @@ -2409,7 +2428,9 @@ routeNormalizers = -- How to run database actions. instance YesodPersist UniWorX where type YesodPersistBackend UniWorX = SqlBackend - runDB action = runSqlPool action =<< appConnPool <$> getYesod + runDB action = do + $logDebugS "YesodPersist" "runDB" + runSqlPool action =<< appConnPool <$> getYesod instance YesodPersistRunner UniWorX where getDBRunner = defaultGetDBRunner appConnPool diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 3e5306383..b727e912e 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -191,12 +191,10 @@ postAdminTestR = do (intRes, intView) <- mreq intField ("" & addName (nudge "int")) $ initial <|> Just cData return (intRes, toWidget csrf >> fvInput intView) -- | How does the shape (`ListLength`) change if a certain cell is deleted? - deleteCell :: ListLength -- ^ Current shape + deleteCell :: Map ListPosition Int -- ^ Current shape, including initialisation data -> ListPosition -- ^ Coordinate to delete -> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition) -- ^ Monadically compute a set of new positions and their associated old positions - deleteCell l pos - | l >= 2 = return . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)] -- Close gap left by deleted position with values from further down the list; try prohibiting certain deletions by utilising `guard` - | otherwise = return Map.empty + deleteCell = miDeleteList -- | Make a decision on whether an add widget should be allowed to further cells, given the current @liveliness@ (i.e. before performing the addition) allowAdd :: ListPosition -> Natural -> ListLength -> Bool allowAdd _ _ l = l < 7 -- Limit list length; much more complicated checks are possible (this could in principle be monadic, but @massInput@ is probably already complicated enough to cover just current (2019-03) usecases) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index b73e6a1bb..1def7e552 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -686,14 +686,14 @@ instance FromJSON (InvitationDBData Lecturer) where instance ToJSON (InvitationTokenData Lecturer) where toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } - toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } + toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 } instance FromJSON (InvitationTokenData Lecturer) where parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } lecturerInvitationConfig :: InvitationConfig Lecturer lecturerInvitationConfig = InvitationConfig{..} where - invitationRoute Course{..} _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR + invitationRoute (Entity _ Course{..}) _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR invitationResolveFor = do Just (CourseR tid csh ssh CLecInviteR) <- getCurrentRoute getKeyBy404 $ TermSchoolCourseShort tid csh ssh @@ -802,7 +802,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation") return (lrwRes,lrwView') - miDelete :: ListLength -- ^ Current shape + miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape -> ListPosition -- ^ Coordinate to delete -> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition) miDelete = miDeleteList diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 749cd9a09..97ce8b441 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -712,7 +712,7 @@ correctorForm shid = wFormToAForm $ do return (res, $(widgetFile "sheetCorrectors/cell")) - miDelete :: ListLength + miDelete :: Map ListPosition (Either UserEmail UserId) -> ListPosition -> MaybeT (MForm Handler) (Map ListPosition ListPosition) miDelete = miDeleteList @@ -821,14 +821,14 @@ instance FromJSON (InvitationDBData SheetCorrector) where instance ToJSON (InvitationTokenData SheetCorrector) where toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } - toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } + toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 } instance FromJSON (InvitationTokenData SheetCorrector) where parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } correctorInvitationConfig :: InvitationConfig SheetCorrector correctorInvitationConfig = InvitationConfig{..} where - invitationRoute Sheet{..} _ = do + invitationRoute (Entity _ Sheet{..}) _ = do Course{..} <- get404 sheetCourse return $ CSheetR courseTerm courseSchool courseShorthand sheetName SCorrInviteR invitationResolveFor = do diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 99149b23c..080ac9667 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -1,15 +1,21 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Handler.Submission where import Import import Jobs +import Utils.Lens + -- import Yesod.Form.Bootstrap3 import Handler.Utils import Handler.Utils.Delete import Handler.Utils.Submission import Handler.Utils.Table.Cells +import Handler.Utils.Form.MassInput +import Handler.Utils.Invitations import Network.Mime @@ -22,9 +28,6 @@ import Data.Maybe (fromJust) -- import qualified Data.Maybe import qualified Data.Text.Encoding as Text -import Data.CaseInsensitive (CI) --- import qualified Data.CaseInsensitive as CI - import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Internal.Sql as E (unsafeSqlFunction) @@ -33,12 +36,16 @@ import qualified Data.Conduit.List as Conduit -- import Data.Set (Set) import qualified Data.Set as Set -import Data.Map (Map) +import Data.Map (Map, (!), (!?)) import qualified Data.Map as Map -- import Data.Bifunctor import System.FilePath +import Text.Blaze (Markup) +import Data.Aeson hiding (Result(..)) +import Text.Hamlet (ihamlet) + -- import Colonnade hiding (bool, fromMaybe) -- import qualified Yesod.Colonnade as Yesod -- import qualified Text.Blaze.Html5.Attributes as HA @@ -48,30 +55,203 @@ import System.FilePath -- numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production. -makeSubmissionForm :: Maybe SubmissionId -> UploadMode -> SheetGroup -> NonEmpty UserEmail -> Form (Maybe (Source Handler File), NonEmpty UserEmail) -makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identifyForm FIDsubmission $ \html -> do - let - fileUploadForm = case uploadMode of - NoUpload -> pure Nothing - (Upload unpackZips) -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing - flip (renderAForm FormStandard) html $ (,) - <$> fileUploadForm - <*> ( (:|) - -- #227 Part I: change aforced to areq if the user is the lecturer or an admin (lecturer can upload for students) - <$> aforced ciField (fslpI (MsgSubmissionMember 1) "user@campus.lmu.de" ) self - <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies ciField (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy - | g <- [2..(fromIntegral groupNr)] - | buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies - ]) - ) - where - (groupNr, editableBuddies) - | Arbitrary{..} <- grouping = (maxParticipants, True) - | RegisteredGroups <- grouping = (fromIntegral $ length buddies, False) - | otherwise = (0, False) +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) - aforced' f fs (Just (Just v)) = Just <$> aforced f fs v - aforced' _ _ _ = error "Cannot happen since groupNr==0 if grouping/=Arbitrary" + _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 + Just (CSubmissionR _tid _ssh _csh _shn cID SInviteR) <- getCurrentRoute + subId <- decrypt cID + bool notFound (return subId) =<< existsKey subId + invitationSubject Submission{..} _ = do + Sheet{..} <- getJust submissionSheet + Course{..} <- getJust sheetCourse + return . SomeMessage $ MsgMailSubjectSubmissionUserInvitation courseTerm courseSchool courseShorthand sheetName + invitationHeading Submission{..} _ = do + Sheet{..} <- getJust submissionSheet + return . SomeMessage $ MsgSubmissionUserInviteHeading sheetName + invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSubmissionUserInviteExplanation}|] + invitationTokenConfig Submission{..} _ = do + Sheet{..} <- getJust submissionSheet + Course{..} <- getJust sheetCourse + itAuthority <- liftHandlerT 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 + invitationSuccessMsg Submission{..} _ = do + Sheet{..} <- getJust submissionSheet + return . SomeMessage $ MsgSubmissionUserInvitationAccepted sheetName + invitationUltDest Submission{..} (Entity _ SubmissionUser{..}) = do + Sheet{..} <- getJust submissionSheet + Course{..} <- getJust sheetCourse + cID <- encrypt submissionUserSubmission + return . SomeRoute $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SubShowR + + +makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe (Source Handler File), Set (Either UserEmail UserId)) +makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = identifyForm FIDsubmission . renderAForm FormStandard $ (,) + <$> fileUploadForm + <*> wFormToAForm submittorsForm + where + fileUploadForm = case uploadMode of + NoUpload + -> pure Nothing + (Upload unpackZips) + -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing + + miCell' :: Markup -> Either UserEmail UserId -> Widget + miCell' csrf (Left email) = $(widgetFile "widgets/massinput/submissionUsers/cellInvitation") + miCell' csrf (Right uid) = do + User{..} <- liftHandlerT . 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.orderBy [E.asc $ user E.^. UserEmail] + return user + + addField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Bool -> Field m (Set (Either UserEmail UserId)) + addField isAdmin = multiUserField True $ courseUsers <$ guard isAdmin + + addFieldSettings, submittorSettings :: FieldSettings UniWorX + addFieldSettings = fslI MsgSubmissionMembers + submittorSettings = fslI MsgSubmissionMembers & setTooltip MsgMassInputTip + + miButtonAction' :: forall p. PathPiece p => Maybe (Route UniWorX) -> p -> Maybe (SomeRoute UniWorX) + miButtonAction' mCurrent frag = mCurrent <&> \current -> SomeRoute (current :#: frag) + + 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 (addField True) (addFieldSettings & 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 <- liftHandlerT requireAuthId + mRoute <- getCurrentRoute + + let + maxSize + | Arbitrary{..} <- grouping = Just maxParticipants + | otherwise = Nothing + mayEdit = is _Arbitrary grouping + + 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 True) (addFieldSettings & 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 = setOf $ folded . _1 + 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 @@ -100,13 +280,14 @@ getSubmissionOwnR tid ssh csh shn = do submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe CryptoFileNameSubmission -> Handler Html submissionHelper tid ssh csh shn mcid = do - (Entity uid userData) <- requireAuth + uid <- requireAuthId msmid <- traverse decrypt mcid - actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute - maySubmit <- (== Authorized) <$> isAuthorized actionUrl True -- affects visibility of Edit-Dates, Submission-Button, etc. + Just actionUrl <- getCurrentRoute - (Entity shid Sheet{..}, buddies, lastEdits) <- runDB $ do + (Entity shid Sheet{..}, buddies, lastEdits, maySubmit, isLecturer, isOwner) <- 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 case msmid of Nothing -> do submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do @@ -132,8 +313,8 @@ submissionHelper tid ssh csh shn mcid = do E.where_ $ submissionUser E.^. SubmissionUserSubmission `E.in_` oldids E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid E.orderBy [E.asc $ user E.^. UserEmail] - return $ user E.^. UserEmail - return (csheet, map E.unValue buddies, []) + return $ user E.^. UserId + return (csheet, Set.fromList $ map (Right . E.unValue) buddies, [], maySubmit, isLecturer, not isLecturer) (E.Value smid:_) -> do cID <- encrypt smid addMessageI Info MsgSubmissionAlreadyExists @@ -146,15 +327,18 @@ submissionHelper tid ssh csh shn mcid = do invalidArgsI [MsgSubmissionWrongSheet] -- fetch buddies from current submission (Any isOwner, buddies) <- do - submitters <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> 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, user E.^. UserEmail) - let breakUserFromBuddies (E.Value userID, E.Value email) - | uid == userID = (Any True , []) - | otherwise = (Any False, [email]) - return $ foldMap breakUserFromBuddies submitters + return $ user E.^. UserId + let breakUserFromBuddies (E.Value userID) + | uid == userID = (Any True , mempty ) + | otherwise = (mempty , Set.singleton $ Right userID) + + invites <- sourceInvitationsList 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 @@ -167,38 +351,38 @@ submissionHelper tid ssh csh shn mcid = do else E.nothing return (userName, submissionEdit E.^. SubmissionEditTime) forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time - return (csheet,buddies,lastEdits) - ((res,formWidget'), formEnctype) <- runFormPost $ makeSubmissionForm msmid (fromMaybe (Upload True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping (userEmail userData :| buddies) + return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner) + ((res,formWidget'), formEnctype) <- runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (Upload True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (Set.insert $ Right uid) isOwner buddies let formWidget = wrapForm formWidget' def { formAction = Just $ SomeRoute actionUrl , formEncoding = formEnctype } + mCID <- fmap join . msgSubmissionErrors . runDBJobs $ do res' <- case res of FormMissing -> return FormMissing (FormFailure failmsgs) -> return $ FormFailure failmsgs -- #227 Part II: no longer ignore submitter, if the user is lecturer or admin (allow lecturers to submit for their students) - (FormSuccess (mFiles,_submitter:|[])) -> return $ FormSuccess (mFiles,[]) -- Type change - (FormSuccess (mFiles,_submitter:|gEMails@(_:_))) -- Validate AdHoc Group Members - | Arbitrary{..} <- sheetGrouping -> do + (FormSuccess res'@(_, groupMembers)) + | Set.null groupMembers -> return $ FormSuccess res' + | Arbitrary{..} <- sheetGrouping -> do -- Validate AdHoc Group Members -- , length gEMails < maxParticipants -> do -- < since submitting user is already accounted for - let prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map (CI Text) (Maybe (UserId, Bool, Bool)) + 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.filter (maybe True $ \(i,_,_) -> i /= uid) . 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.^. UserEmail) `E.in_` E.valList gEMails + E.where_ $ (user E.^. UserId) `E.in_` E.valList gIds let - isParticipant = E.sub_select . E.from $ \courseParticipant -> do + isParticipant = E.exists . E.from $ \courseParticipant -> do E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val sheetCourse - return $ E.countRows E.>. E.val (0 :: Int64) - hasSubmitted = E.sub_select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do + 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 $ E.countRows E.>. E.val (0 :: Int64) return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted)) $logDebugS "SUBMISSION.AdHocGroupValidation" $ tshow participants @@ -207,22 +391,22 @@ submissionHelper tid ssh csh shn mcid = do let failmsgs = (concat :: [[Text]] -> [Text]) [ flip Map.foldMapWithKey participants $ \email -> \case - Nothing -> pure . mr $ MsgEMailUnknown email + -- Nothing -> pure . mr $ MsgEMailUnknown email (Just (_,False,_)) -> pure . mr $ MsgNotAParticipant email tid csh (Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor email _other -> mempty - , case fromIntegral (length participants) `compare` maxParticipants of + , case fromIntegral (Map.size participants) `compare` maxParticipants of LT -> mempty _ -> pure $ mr MsgTooManyParticipants ] return $ if null failmsgs - then FormSuccess (mFiles, foldMap (\(Just (i,_,_)) -> [i]) participants) + then FormSuccess res' else FormFailure failmsgs | otherwise -> return $ FormFailure ["Mismatching number of group participants"] case res' of - (FormSuccess (mFiles, setFromList -> adhocIds)) -> do + (FormSuccess (mFiles, adhocMembers)) -> do smid <- do smid <- case (mFiles, msmid) of (Nothing, Just smid) -- no new files, existing submission partners updated @@ -238,19 +422,24 @@ submissionHelper tid ssh csh shn mcid = do , submissionRatingAssigned = Nothing , submissionRatingTime = Nothing } - -- Determine members of pre-registered group - groupUids <- fmap (setFromList . map 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_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid - E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse - return $ submissionGroupUser' E.^. SubmissionGroupUserUser - -- SubmissionUser for all group members (pre-registered & ad-hoc) - let subUsers = Set.insert uid $ groupUids `Set.union` adhocIds - -- remove obsolete old entries - deleteWhere [SubmissionUserSubmission ==. smid, SubmissionUserUser /<-. setToList subUsers] - -- maybe add current users - forM_ subUsers $ \uid' -> void . insertUnique $ SubmissionUser uid' smid + subUsers <- if + | isLecturer -> return adhocMembers + | otherwise -> 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_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid + E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse + return $ submissionGroupUser' E.^. SubmissionGroupUserUser + -- SubmissionUser for all group members (pre-registered & ad-hoc) + return $ groupUids `Set.union` adhocMembers + let (subEmails, subUids) = partitionEithers $ Set.toList subUsers + + deleteWhere [SubmissionUserSubmission ==. smid] + deleteWhere [InvitationFor ==. invRef @SubmissionUser smid, InvitationEmail /<-. subEmails] + insertMany_ $ map (flip SubmissionUser smid) subUids + sinkInvitationsF submissionUserInvitationConfig $ map (\lEmail -> (lEmail, smid, (InvDBDataSubmissionUser, InvTokenDataSubmissionUser))) subEmails return smid cID <- encrypt smid return $ Just cID @@ -327,6 +516,10 @@ submissionHelper tid ssh csh shn mcid = do urlOriginal cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName 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 = runDB $ do diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index 255f26aea..b3b12fad3 100644 --- a/src/Handler/Tutorial.hs +++ b/src/Handler/Tutorial.hs @@ -227,14 +227,14 @@ instance FromJSON (InvitationDBData Tutor) where instance ToJSON (InvitationTokenData Tutor) where toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } - toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } + toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 } instance FromJSON (InvitationTokenData Tutor) where parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } tutorInvitationConfig :: InvitationConfig Tutor tutorInvitationConfig = InvitationConfig{..} where - invitationRoute Tutorial{..} _ = do + invitationRoute (Entity _ Tutorial{..}) _ = do Course{..} <- get404 tutorialCourse return $ CTutorialR courseTerm courseSchool courseShorthand tutorialName TInviteR invitationResolveFor = do diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index c82c574ee..31a8cbb89 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -162,7 +162,7 @@ commR CommunicationRoute{..} = do hasContent c = not (null $ categoryIndices c) || Map.member (1, (EnumPosition c, 0)) addWdgts categoryIndices c = Set.filter ((== c) . unEnumPosition . fst) $ review liveCoords liveliness $(widgetFile "widgets/communication/recipientLayout") - miDelete :: MapLiveliness (EnumLiveliness RecipientCategory) ListLength -> (EnumPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (EnumPosition RecipientCategory, ListPosition) (EnumPosition RecipientCategory, ListPosition)) + miDelete :: Map (EnumPosition RecipientCategory, ListPosition) (Either UserEmail UserId) -> (EnumPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (EnumPosition RecipientCategory, ListPosition) (EnumPosition RecipientCategory, ListPosition)) -- miDelete liveliness@(MapLiveliness lMap) (EnumPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(EnumPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (EnumPosition RecipientCustom, ) . Map.mapKeysMonotonic (EnumPosition RecipientCustom, ) <$> miDeleteList (lMap ! EnumPosition RecipientCustom) delPos miDelete _ _ = mzero miIdent :: Text diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index 2c6560876..9119b031a 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/src/Handler/Utils/Form/MassInput.hs @@ -8,7 +8,7 @@ module Handler.Utils.Form.MassInput , module Handler.Utils.Form.MassInput.Liveliness , massInputA, massInputW , massInputList - , massInputAccum, massInputAccumA + , massInputAccum, massInputAccumA, massInputAccumW , ListLength(..), ListPosition(..), miDeleteList , EnumLiveliness(..), EnumPosition(..) , MapLiveliness(..) @@ -144,10 +144,11 @@ instance (Liveliness l1, Liveliness l2) => Liveliness (MapLiveliness l1 l2) wher -miDeleteList :: Applicative m => ListLength -> ListPosition -> m (Map ListPosition ListPosition) -miDeleteList l pos +miDeleteList :: Applicative m => Map ListPosition a -> ListPosition -> m (Map ListPosition ListPosition) +miDeleteList dat pos -- Close gap left by deleted position with values from further down the list; try prohibiting certain deletions by utilising `guard` - | l >= 2 = pure . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)] + | Just l <- preview liveCoords $ Map.keysSet dat :: Maybe ListLength + , l >= 2 = pure . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)] | otherwise = pure Map.empty data ButtonMassInput coord @@ -245,7 +246,7 @@ data MassInput handler liveliness cellData cellResult = forall i. PathPiece i => -> Maybe cellResult -- Initial result from Argument to @massInput@ -> (Text -> Text) -- Nudge deterministic field ids -> (Markup -> MForm handler (FormResult cellResult, Widget)) -- ^ Construct a singular cell - , miDelete :: liveliness + , miDelete :: Map (BoxCoord liveliness) cellData -> BoxCoord liveliness -> MaybeT (MForm handler) (Map (BoxCoord liveliness) (BoxCoord liveliness)) -- ^ Decide whether a deletion-operation should be permitted and produce a finite map of new coordinates to their old correspondants , miAllowAdd :: BoxCoord liveliness @@ -349,13 +350,12 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR addedShape <- if | Just s <- addShape -> return s | otherwise -> return sentShape' - addedLiveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet addedShape ^? liveCoords :: MForm handler liveliness let delForm :: BoxCoord liveliness -> MaybeT (MForm handler) (FormResult (Map (BoxCoord liveliness) (BoxCoord liveliness)), FieldView UniWorX) delForm miCoord = do (delRes, delView) <- lift $ mopt (buttonField $ MassInputDeleteCell miCoord) ("" & addName MassInputDeleteButton{..} & addFormAction) Nothing - shapeUpdate <- miDelete addedLiveliness miCoord + shapeUpdate <- miDelete addedShape miCoord guard $ isJust (Map.keysSet shapeUpdate ^? liveCoords :: Maybe liveliness) return (shapeUpdate <$ assertM (is _Just) delRes, delView) @@ -545,6 +545,24 @@ massInputAccumA :: forall handler cellData ident. massInputAccumA miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev = formToAForm $ over _2 pure <$> massInputAccum miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev mempty +massInputAccumW :: forall handler cellData ident. + ( MonadHandler handler, HandlerSite handler ~ UniWorX + , MonadLogger handler + , ToJSON cellData, FromJSON cellData + , PathPiece ident + ) + => ((Text -> Text) -> FieldView UniWorX -> (Markup -> MForm handler (FormResult ([cellData] -> FormResult [cellData]), Widget))) + -> (cellData -> Widget) + -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) + -> MassInputLayout ListLength cellData () + -> ident + -> FieldSettings UniWorX + -> Bool + -> Maybe [cellData] + -> WForm handler (FormResult [cellData]) +massInputAccumW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev + = mFormToWForm $ massInputAccum miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev mempty + massInputA :: forall handler cellData cellResult liveliness. ( MonadHandler handler, HandlerSite handler ~ UniWorX diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index a256a7a99..a8d0223ae 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/src/Handler/Utils/Invitations.hs @@ -113,7 +113,7 @@ invRef = toJSON . InvRef @junction -- -- It is advisable to define this once per `junction` in a global constant data InvitationConfig junction = InvitationConfig - { invitationRoute :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX (Route UniWorX) + { invitationRoute :: Entity (InvitationFor junction) -> InvitationData junction -> YesodDB UniWorX (Route UniWorX) -- ^ Which route calls `invitationR` for this kind of invitation? , invitationResolveFor :: YesodDB UniWorX (Key (InvitationFor junction)) -- ^ Monadically resolve `InvitationFor` during `inviteR` @@ -200,7 +200,7 @@ sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lif fRec <- get404 fid jInviter <- liftHandlerT requireAuthId - route <- mapReaderT liftHandlerT $ invitationRoute fRec dat + route <- mapReaderT liftHandlerT $ invitationRoute (Entity fid fRec) dat InvitationTokenConfig{..} <- mapReaderT liftHandlerT $ invitationTokenConfig fRec dat protoToken <- bearerToken itAuthority (Just . HashSet.singleton $ urlRoute route) itAddAuth itExpiresAt itStartsAt let token = protoToken & tokenRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData) diff --git a/src/Handler/Utils/Tokens.hs b/src/Handler/Utils/Tokens.hs index 8ca5ad400..736bb929a 100644 --- a/src/Handler/Utils/Tokens.hs +++ b/src/Handler/Utils/Tokens.hs @@ -27,8 +27,8 @@ requireBearerToken = liftHandlerT $ do guardAuthResult <=< runDB $ validateToken mAuthId currentRoute isWrite token return token -currentTokenRestrictions :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, FromJSON a, ToJSON a) => m (Maybe a) +currentTokenRestrictions :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, MonadLogger m, FromJSON a, ToJSON a) => m (Maybe a) currentTokenRestrictions = runMaybeT $ do - token <- MaybeT maybeBearerToken + token <- requireBearerToken route <- MaybeT getCurrentRoute hoistMaybe $ preview (_tokenRestrictionIx route) token diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 73e1dbe8d..7006bd5e5 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -49,7 +49,7 @@ import GHC.Generics as Import (Generic) import GHC.Exts as Import (IsList) import Data.Hashable as Import -import Data.List.NonEmpty as Import (NonEmpty(..)) +import Data.List.NonEmpty as Import (NonEmpty(..), nonEmpty) import Data.List.NonEmpty.Instances as Import () import Data.NonNull.Instances as Import () import Data.Text.Encoding.Error as Import(UnicodeException(..)) diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 0791bb218..1086b40ec 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -557,7 +557,7 @@ derivePersistField "Theme" newtype ZIPArchiveName obj = ZIPArchiveName { unZIPArchiveName :: obj } - deriving (Show, Read, Eq) + deriving (Show, Read, Eq, Ord, Generic, Typeable) instance PathPiece obj => PathPiece (ZIPArchiveName obj) where fromPathPiece = fmap ZIPArchiveName . fromPathPiece <=< (stripSuffix `on` CI.foldCase) ".zip" @@ -832,8 +832,7 @@ data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a } instance Hashable a => Hashable (PredLiteral a) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 - , sumEncoding = ObjectWithSingleField - , unwrapUnaryRecords = True + , sumEncoding = TaggedObject "val" "var" } ''PredLiteral instance PathPiece a => PathPiece (PredLiteral a) where diff --git a/src/Utils.hs b/src/Utils.hs index 64e352bd1..4fee6e818 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -77,6 +77,8 @@ import Network.Wai (requestMethod) import Data.Time.Clock +import Data.List.NonEmpty (NonEmpty, nonEmpty) + {-# ANN choice ("HLint: ignore Use asum" :: String) #-} @@ -382,6 +384,9 @@ partitionWith f (x:xs) = case f x of Right c -> (bs, c:cs) where (bs,cs) = partitionWith f xs +nonEmpty' :: Alternative f => [a] -> f (NonEmpty a) +nonEmpty' = maybe empty pure . nonEmpty + ---------- -- Sets -- ---------- @@ -391,7 +396,8 @@ setIntersections :: Ord a => [Set a] -> Set a setIntersections [] = Set.empty setIntersections (h:t) = foldl' Set.intersection h t - +setMapMaybe :: (Ord a, Ord b) => (a -> Maybe b) -> Set a -> Set b +setMapMaybe f = Set.fromList . mapMaybe f . Set.toList ---------- -- Maps -- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 15f824b08..412dd5b0c 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -630,6 +630,10 @@ aFormToWForm = mapRWST mFormToWForm' . over (mapped . _2) ($ []) . aFormToForm ((a, vs), ints, enctype) <- lift f writer ((a, ints, enctype), vs) +infixl 4 `fmapAForm` + +fmapAForm :: Functor m => (FormResult a -> FormResult b) -> (AForm m a -> AForm m b) +fmapAForm f (AForm act) = AForm $ \app env ints -> over _1 f <$> act app env ints --------------------------------------------- -- Special variants of @mopt@, @mreq@, ... -- diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 7a7c6a4db..d52b852c8 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -27,6 +27,9 @@ _InnerJoinLeft f (E.InnerJoin l r) = (`E.InnerJoin` r) <$> f l _InnerJoinRight :: Lens' (E.InnerJoin l r) r _InnerJoinRight f (E.InnerJoin l r) = (l `E.InnerJoin`) <$> f r +_nullable :: MonoFoldable mono => Prism' mono (NonNull mono) +_nullable = prism' toNullable fromNullable + ----------------------------------- -- Lens Definitions for our Types @@ -80,6 +83,8 @@ makeLenses_ ''SheetGrading makeLenses_ ''SheetType +makePrisms ''SheetGroup + makePrisms ''AuthResult makePrisms ''FormResult @@ -112,6 +117,8 @@ makePrisms ''OccurenceException makeLenses_ ''Occurences +makeLenses_ ''PredDNF + -- makeClassy_ ''Load diff --git a/static/js/utils/massInput.js b/static/js/utils/massInput.js index d77a4b942..5d75a7c6c 100644 --- a/static/js/utils/massInput.js +++ b/static/js/utils/massInput.js @@ -116,12 +116,14 @@ var requestBody = serializeForm(submitButton, enctype); if (requestFn && requestBody) { + var headers = {'Mass-Input-Shortcircuit': massInputId}; + + if (enctype !== 'multipart/form-data') + headers['Content-Type'] = enctype; + requestFn( url, - { - 'Content-Type': enctype, - 'Mass-Input-Shortcircuit': massInputId, - }, + headers, requestBody, ).then(function(response) { return response.text(); diff --git a/templates/submission.hamlet b/templates/submission.hamlet index b64a9a41c..c48654517 100644 --- a/templates/submission.hamlet +++ b/templates/submission.hamlet @@ -22,7 +22,9 @@ $maybe cID <- mcid $nothing
  • #{display time} - -$if maySubmit -
    - ^{formWidget} + $if maySubmit +
    +

    _{MsgSubmissionReplace} + ^{formWidget} +$nothing + ^{formWidget} diff --git a/templates/widgets/massinput/submissionUsers/add.hamlet b/templates/widgets/massinput/submissionUsers/add.hamlet new file mode 100644 index 000000000..7986b68e3 --- /dev/null +++ b/templates/widgets/massinput/submissionUsers/add.hamlet @@ -0,0 +1,6 @@ +$newline never + + #{csrf} + ^{fvInput addView} + + ^{fvInput btn} diff --git a/templates/widgets/massinput/submissionUsers/cellInvitation.hamlet b/templates/widgets/massinput/submissionUsers/cellInvitation.hamlet new file mode 100644 index 000000000..6050ac678 --- /dev/null +++ b/templates/widgets/massinput/submissionUsers/cellInvitation.hamlet @@ -0,0 +1,10 @@ + $newline never + + #{csrf} + + #{email} + +
    +
    +
    + _{MsgEmailInvitationWarning} diff --git a/templates/widgets/massinput/submissionUsers/cellKnown.hamlet b/templates/widgets/massinput/submissionUsers/cellKnown.hamlet new file mode 100644 index 000000000..f6d3beaef --- /dev/null +++ b/templates/widgets/massinput/submissionUsers/cellKnown.hamlet @@ -0,0 +1,4 @@ +$newline never + + #{csrf} + ^{nameEmailWidget userEmail userDisplayName userSurname} diff --git a/templates/widgets/massinput/submissionUsers/layout.hamlet b/templates/widgets/massinput/submissionUsers/layout.hamlet new file mode 100644 index 000000000..f1842a72f --- /dev/null +++ b/templates/widgets/massinput/submissionUsers/layout.hamlet @@ -0,0 +1,13 @@ +$newline never + + + $forall coord <- review liveCoords lLength + + ^{cellWdgts ! coord} + + + ^{addWdgt} diff --git a/test/FoundationSpec.hs b/test/FoundationSpec.hs new file mode 100644 index 000000000..04081f1b9 --- /dev/null +++ b/test/FoundationSpec.hs @@ -0,0 +1,58 @@ +module FoundationSpec where + +import TestImport + +import ModelSpec () + +import qualified Data.CryptoID as CID +import Yesod.EmbeddedStatic + +instance Arbitrary TermId where + arbitrary = TermKey <$> arbitrary + +instance Arbitrary SchoolId where + arbitrary = SchoolKey <$> arbitrary + +instance Arbitrary (Route Auth) where + arbitrary = oneof + [ return CheckR + , return LoginR + , return LogoutR + , PluginR <$> arbitrary <*> arbitrary + ] + +instance Arbitrary (Route EmbeddedStatic) where + arbitrary = embeddedResourceR <$> arbitrary <*> arbitrary + +instance Arbitrary CourseR where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary SheetR where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary SubmissionR where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary MaterialR where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary TutorialR where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary (Route UniWorX) where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary a => Arbitrary (CID.CryptoID ns a) where + arbitrary = CID.CryptoID <$> arbitrary + +spec :: Spec +spec = do + parallel $ + lawsCheckHspec (Proxy @(Route UniWorX)) + [ eqLaws, hashableLaws, jsonLaws, jsonKeyLaws, pathPieceLaws ] diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index b042b2aa6..7e725c166 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -148,6 +148,10 @@ instance Arbitrary AuthenticationMode where instance Arbitrary LecturerType where arbitrary = genericArbitrary shrink = genericShrink + +instance Arbitrary a => Arbitrary (ZIPArchiveName a) where + arbitrary = genericArbitrary + shrink = genericShrink spec :: Spec @@ -211,6 +215,8 @@ spec = do [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ] lawsCheckHspec (Proxy @LecturerType) [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws ] + lawsCheckHspec (Proxy @(ZIPArchiveName (CI Text))) + [ eqLaws, ordLaws, showReadLaws, pathPieceLaws ] describe "TermIdentifier" $ do it "has compatible encoding/decoding to/from Text" . property $ diff --git a/test/Test/QuickCheck/Classes/Binary.hs b/test/Test/QuickCheck/Classes/Binary.hs new file mode 100644 index 000000000..1261ce44b --- /dev/null +++ b/test/Test/QuickCheck/Classes/Binary.hs @@ -0,0 +1,17 @@ +module Test.QuickCheck.Classes.Binary + ( binaryLaws + ) where + +import ClassyPrelude +import Test.QuickCheck +import Test.QuickCheck.Classes + +import Data.Proxy (Proxy(..)) +import Data.Binary +import Data.Binary.Put + +binaryLaws :: forall a. (Arbitrary a, Binary a, Eq a, Show a) => Proxy a -> Laws +binaryLaws _ = Laws "Binary" + [ ("Partial Isomorphism", property $ \(a :: a) -> decode (encode a) == Just a) + , ("Valid list encoding", property $ \(as :: [a]) -> runPut (putList as) == runPut (put as)) + ] diff --git a/test/TestImport.hs b/test/TestImport.hs index 4ba8082bd..522201f4c 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -26,6 +26,7 @@ import Test.QuickCheck.Classes.Hashable as X import Test.QuickCheck.Classes.JSON as X import Test.QuickCheck.Classes.HttpApiData as X import Test.QuickCheck.Classes.Universe as X +import Test.QuickCheck.Classes.Binary as X import Data.Proxy as X import Data.UUID as X (UUID) import System.IO as X (hPrint, hPutStrLn, stderr)
    + $maybe delButton <- delButtons !? coord + ^{fvInput delButton} + $maybe addWdgt <- addWdgts !? (0, 0) +