diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 0c3465350..c29f933d6 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -456,9 +456,10 @@ UploadModeNone: Kein Upload UploadModeUnpack: Upload, einzelne Datei UploadModeNoUnpack: Upload, ZIP-Archive entpacken -SheetNoSubmissions: Keine Abgabe -SheetCorrectorSubmissions: Abgabe extern mit Pseudonym -SheetUserSubmissions: Direkte Abgabe +NoSubmissions: Keine Abgabe +CorrectorSubmissions: Abgabe extern mit Pseudonym +UserSubmissions: Direkte Abgabe +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. diff --git a/models/sheets b/models/sheets index 8f6d623db..293d75b2f 100644 --- a/models/sheets +++ b/models/sheets @@ -10,8 +10,7 @@ Sheet -- exercise sheet for a given course activeTo UTCTime -- Submission is only permitted before hintFrom UTCTime Maybe -- Additional files are made available solutionFrom UTCTime Maybe -- Solution is made available - uploadMode UploadMode -- Take apart Zip-Archives or not? - submissionMode SheetSubmissionMode default='UserSubmissions' -- Submission upload by students or through tutors only? + submissionMode SubmissionMode -- Submission upload by students and/or through tutors? autoDistribute Bool default=false -- Should correctors be assigned submissions automagically? CourseSheet course name deriving Generic diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 22266fc3a..4914bac78 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -58,21 +58,3 @@ instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) Submission parseJSON = withText "CryptoFileNameSubmission" $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => FromJSONKey (E.CryptoID namespace (CI FilePath)) where fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece - - -newtype SubmissionMode = SubmissionMode (Maybe CryptoFileNameSubmission) - deriving (Show, Read, Eq) - -pattern NewSubmission :: SubmissionMode -pattern NewSubmission = SubmissionMode Nothing -pattern ExistingSubmission :: CryptoFileNameSubmission -> SubmissionMode -pattern ExistingSubmission cID = SubmissionMode (Just cID) - -instance PathPiece SubmissionMode where - fromPathPiece "new" = Just $ SubmissionMode Nothing - fromPathPiece s = SubmissionMode . Just <$> fromPathPiece s - - toPathPiece (SubmissionMode Nothing) = "new" - toPathPiece (SubmissionMode (Just x)) = toPathPiece x - - diff --git a/src/Database/Persist/TH/Directory.hs b/src/Database/Persist/TH/Directory.hs index 770b71d71..66966913c 100644 --- a/src/Database/Persist/TH/Directory.hs +++ b/src/Database/Persist/TH/Directory.hs @@ -2,26 +2,35 @@ module Database.Persist.TH.Directory ( persistDirectoryWith ) where -import ClassyPrelude hiding (mapM_, toList) +import ClassyPrelude import Database.Persist.TH (parseReferences) import Database.Persist.Quasi (PersistSettings) -import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Syntax hiding (lift) import qualified Data.Text as Text import qualified Data.Text.IO as Text import qualified System.IO as SIO +import System.FilePath import qualified System.Directory.Tree as DirTree -import Data.Foldable (Foldable(..), mapM_) +import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT) + +import Control.Lens + persistDirectoryWith :: PersistSettings -> FilePath -> Q Exp persistDirectoryWith settings dir = do - files <- runIO . flip DirTree.readDirectoryWith dir $ \fp -> do - h <- SIO.openFile fp SIO.ReadMode - SIO.hSetEncoding h SIO.utf8_bom - Text.hGetContents h - mapM_ (qAddDependentFile . fst) $ DirTree.zipPaths files + files <- runIO . flip DirTree.readDirectoryWith dir $ \fp -> runMaybeT $ do + fn <- MaybeT . return . fromNullable $ takeFileName fp + guard . not $ head fn == '.' + guard . not $ head fn == '#' && last fn == '#' + + lift $ do + h <- SIO.openFile fp SIO.ReadMode + SIO.hSetEncoding h SIO.utf8_bom + Text.hGetContents h + mapM_ qAddDependentFile . toListOf (traverse . filtered (has $ _2 . _Just) . _1) $ DirTree.zipPaths files - parseReferences settings . Text.intercalate "\n" . toList $ DirTree.dirTree files + parseReferences settings . Text.intercalate "\n" . toListOf (traverse . _Just) $ DirTree.dirTree files diff --git a/src/Foundation.hs b/src/Foundation.hs index 4dbbba963..46e176a19 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -253,9 +253,13 @@ embedRenderMessage ''UniWorX ''RatingException id embedRenderMessage ''UniWorX ''SubmissionSinkException ("SubmissionSinkException" <>) embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>) embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel -embedRenderMessage ''UniWorX ''SheetSubmissionMode ("Sheet" <>) embedRenderMessage ''UniWorX ''EncodedSecretBoxException id embedRenderMessage ''UniWorX ''LecturerType id +embedRenderMessage ''UniWorX ''SubmissionModeDescr + $ let verbMap [_, _, "None"] = "NoSubmissions" + verbMap [_, _, v] = v <> "Submissions" + verbMap _ = error "Invalid number of verbs" + in verbMap . splitCamel newtype SheetTypeHeader = SheetTypeHeader SheetType embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>) @@ -742,15 +746,15 @@ tagAccessPredicate AuthRated = APDB $ \_ route _ -> case route of tagAccessPredicate AuthUserSubmissions = APDB $ \_ route _ -> case route of CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn - guard $ sheetSubmissionMode == UserSubmissions + Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn + guard $ is _Just submissionModeUser return Authorized r -> $unsupportedAuthPredicate AuthUserSubmissions r tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn - guard $ sheetSubmissionMode == CorrectorSubmissions + Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn + guard submissionModeCorrector return Authorized r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r tagAccessPredicate AuthSelf = APHandler $ \mAuthId route _ -> exceptT return return $ do @@ -1891,7 +1895,7 @@ pageActions (CorrectionsR) = , menuItemModal = False , menuItemAccessCallback' = runDB . maybeT (return False) $ do uid <- MaybeT $ liftHandlerT maybeAuthId - [E.Value sheetCount] <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do + sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse let isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_ @@ -1900,10 +1904,9 @@ pageActions (CorrectionsR) = isLecturer = E.exists . E.from $ \lecturer -> E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId - E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions - E.&&. ( isCorrector' E.||. isLecturer ) - return E.countRows - return $ (sheetCount :: Int) /= 0 + E.where_ $ isCorrector' E.||. isLecturer + return $ sheet E.^. SheetSubmissionMode + return $ orOf (traverse . _Value . _submissionModeCorrector) sheets } , MenuItem { menuItemType = PageActionPrime @@ -1931,7 +1934,7 @@ pageActions (CorrectionsGradeR) = , menuItemModal = False , menuItemAccessCallback' = runDB . maybeT (return False) $ do uid <- MaybeT $ liftHandlerT maybeAuthId - [E.Value sheetCount] <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do + sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse let isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_ @@ -1940,10 +1943,9 @@ pageActions (CorrectionsGradeR) = isLecturer = E.exists . E.from $ \lecturer -> E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId - E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions - E.&&. ( isCorrector' E.||. isLecturer ) - return E.countRows - return $ (sheetCount :: Int) /= 0 + E.where_ $ isCorrector' E.||. isLecturer + return $ sheet E.^. SheetSubmissionMode + return $ orOf (traverse . _Value . _submissionModeCorrector) sheets } ] pageActions _ = [] diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index b82a85ea0..8f1049ad7 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -80,9 +80,6 @@ courseIs cid (( course `E.InnerJoin` _sheet `E.InnerJoin` _submission) `E.LeftO sheetIs :: Key Sheet -> CorrectionTableWhere sheetIs shid ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetId E.==. E.val shid -submissionModeIs :: SheetSubmissionMode -> CorrectionTableWhere -submissionModeIs sMode ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetSubmissionMode E.==. E.val sMode - -- Columns colTerm :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) @@ -731,7 +728,7 @@ getCorrectionsCreateR, postCorrectionsCreateR :: Handler Html getCorrectionsCreateR = postCorrectionsCreateR postCorrectionsCreateR = do uid <- requireAuthId - let sheetOptions = mkOptList <=< runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do + let sheetOptions = mkOptList . toListOf (traverse . filtered (view $ _1 . _Value . _submissionModeCorrector) . _2) <=< runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse let isCorrector = E.exists . E.from $ \sheetCorrector -> E.where_ @@ -740,10 +737,9 @@ postCorrectionsCreateR = do isLecturer = E.exists . E.from $ \lecturer -> E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId - E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions - E.&&. ( isCorrector E.||. isLecturer ) + E.where_ $ isCorrector E.||. isLecturer E.orderBy [E.desc $ course E.^. CourseTerm, E.asc $ course E.^. CourseShorthand, E.desc $ sheet E.^. SheetActiveFrom] - return (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName) + return (sheet E.^. SheetSubmissionMode, (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName)) mkOptList :: [(E.Value SheetId, E.Value TermId, E.Value CourseShorthand, E.Value SheetName)] -> Handler (OptionList SheetId) mkOptList opts = do opts' <- mapM (\v@(E.Value sid, _, _, _) -> (, v) <$> encrypt sid) opts diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index aa1593ea2..38f47c3e1 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -515,9 +515,9 @@ mkCorrectionsTable = , sortable (toNothing "cload") (i18nCell MsgCorProportion) $ correctorLoadCell <$> view (_dbrOutput . _3 . _entityVal) , sortable (toNothing "assigned") (i18nCell MsgCorProportion) $ - int64Cell <$> view (_dbrOutput . _4 . _1 . _unValue) + int64Cell <$> view (_dbrOutput . _4 . _1 . _Value) , sortable (toNothing "corrected") (i18nCell MsgCorProportion) $ - int64Cell <$> view (_dbrOutput . _4 . _2 . _unValue) + int64Cell <$> view (_dbrOutput . _4 . _2 . _Value) ] validator = def & defaultSorting [SortDescBy "term", SortAscBy "school", SortAscBy "course", SortAscBy "sheet"] diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index cf3f36b09..297708e5f 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -71,8 +71,7 @@ data SheetForm = SheetForm , sfVisibleFrom :: Maybe UTCTime , sfActiveFrom :: UTCTime , sfActiveTo :: UTCTime - , sfSubmissionMode :: SheetSubmissionMode - , sfUploadMode :: UploadMode + , sfSubmissionMode :: SubmissionMode , sfSheetF :: Maybe (Source Handler (Either FileId File)) , sfHintFrom :: Maybe UTCTime , sfHintF :: Maybe (Source Handler (Either FileId File)) @@ -112,8 +111,7 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do & setTooltip MsgSheetActiveFromTip) (sfActiveFrom <$> template) <*> areq utcTimeField (fslI MsgSheetActiveTo) (sfActiveTo <$> template) - <*> areq submissionModeField (fslI MsgSheetSubmissionMode) ((sfSubmissionMode <$> template) <|> pure UserSubmissions) - <*> areq uploadModeField (fslI MsgSheetUploadMode) ((sfUploadMode <$> template) <|> pure (Upload True)) + <*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ Upload True)) <*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template) <*> aopt utcTimeField (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren" & setTooltip MsgSheetHintFromTip) (sfHintFrom <$> template) @@ -464,7 +462,6 @@ getSheetNewR tid ssh csh = do , sfActiveFrom = addTime sheetActiveFrom , sfActiveTo = addTime sheetActiveTo , sfSubmissionMode = sheetSubmissionMode - , sfUploadMode = sheetUploadMode , sfSheetF = Nothing , sfHintFrom = addTime <$> sheetHintFrom , sfHintF = Nothing @@ -497,7 +494,6 @@ getSEditR tid ssh csh shn = do , sfActiveFrom = sheetActiveFrom , sfActiveTo = sheetActiveTo , sfSubmissionMode = sheetSubmissionMode - , sfUploadMode = sheetUploadMode , sfSheetF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise , sfHintFrom = sheetHintFrom , sfHintF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetHint @@ -539,7 +535,6 @@ handleSheetEdit tid ssh csh msId template dbAction = do , sheetActiveTo = sfActiveTo , sheetHintFrom = sfHintFrom , sheetSolutionFrom = sfSolutionFrom - , sheetUploadMode = sfUploadMode , sheetSubmissionMode = sfSubmissionMode , sheetAutoDistribute = fromMaybe False oldAutoDistribute } diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 978f02672..99149b23c 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -75,12 +75,12 @@ makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identifyForm FI getSubmissionNewR, postSubmissionNewR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSubmissionNewR = postSubmissionNewR -postSubmissionNewR tid ssh csh shn = submissionHelper tid ssh csh shn NewSubmission +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 $ ExistingSubmission cid +postSubShowR tid ssh csh shn cid = submissionHelper tid ssh csh shn $ Just cid getSubmissionOwnR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSubmissionOwnR tid ssh csh shn = do @@ -98,8 +98,8 @@ getSubmissionOwnR tid ssh csh shn = do cID <- encrypt sid redirect $ CSubmissionR tid ssh csh shn cID SubShowR -submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SubmissionMode -> Handler Html -submissionHelper tid ssh csh shn (SubmissionMode mcid) = do +submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe CryptoFileNameSubmission -> Handler Html +submissionHelper tid ssh csh shn mcid = do (Entity uid userData) <- requireAuth msmid <- traverse decrypt mcid actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute @@ -168,7 +168,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do 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 sheetUploadMode sheetGrouping (userEmail userData :| buddies) + ((res,formWidget'), formEnctype) <- runFormPost $ makeSubmissionForm msmid (fromMaybe (Upload True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping (userEmail userData :| buddies) let formWidget = wrapForm formWidget' def { formAction = Just $ SomeRoute actionUrl , formEncoding = formEnctype diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 9323e73a4..e552930d9 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -140,7 +140,47 @@ linkButton lbl cls url = do ^{lbl} |] +-------------------------- +-- Interactive fieldset -- +-------------------------- +multiAction :: forall action a. + ( RenderMessage UniWorX action, PathPiece action, Ord action, Eq action ) + => Map action (AForm (HandlerT UniWorX IO) a) + -> FieldSettings UniWorX + -> Maybe action + -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) +multiAction acts fs@FieldSettings{..} defAction csrf = do + mr <- getMessageRender + + let + options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece + (actionRes, actionView) <- mreq (selectField $ return options) fs defAction + results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts + + let actionResults = view _1 <$> results + actionViews = Map.foldrWithKey accViews [] results + + accViews :: forall b. action -> (b, [FieldView UniWorX]) -> [FieldView UniWorX] -> [FieldView UniWorX] + accViews act = flip mappend . over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/multi-action")) . snd + + return ((actionResults Map.!) =<< actionRes, over _fvInput (mappend $ toWidget csrf) actionView : actionViews) + +multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action) + => Map action (AForm (HandlerT UniWorX IO) a) + -> FieldSettings UniWorX + -> Maybe action + -> AForm Handler a +multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty + +multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action) + => Map action (AForm (HandlerT UniWorX IO) a) + -> FieldSettings UniWorX + -> Maybe action + -> (Html -> MForm Handler (FormResult a, Widget)) +multiActionM acts fSettings defAction = renderAForm FormStandard $ multiActionA acts fSettings defAction + + ------------ -- Fields -- ------------ @@ -277,8 +317,26 @@ studyFeaturesPrimaryFieldFor oldFeatures mbuid = selectField $ do uploadModeField :: Field Handler UploadMode uploadModeField = selectField optionsFinite -submissionModeField :: Field Handler SheetSubmissionMode -submissionModeField = selectField optionsFinite +submissionModeForm :: Maybe SubmissionMode -> AForm Handler SubmissionMode +submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ classifySubmissionMode <$> prev + where + uploadModeForm = apreq uploadModeField (fslI MsgSheetUploadMode) (preview (_Just . _submissionModeUser . _Just) $ prev) + + actions :: Map SubmissionModeDescr (AForm Handler SubmissionMode) + actions = Map.fromList + [ ( SubmissionModeNone + , pure $ SubmissionMode False Nothing + ) + , ( SubmissionModeCorrector + , pure $ SubmissionMode True Nothing + ) + , ( SubmissionModeUser + , SubmissionMode False . Just <$> uploadModeForm + ) + , ( SubmissionModeBoth + , SubmissionMode True . Just <$> uploadModeForm + ) + ] pseudonymWordField :: Field Handler PseudonymWord pseudonymWordField = checkMMap doCheck CI.original $ textField & addDatalist (return $ map CI.original pseudonymWordlist) @@ -605,42 +663,6 @@ optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a)) }) cPairs -multiAction :: forall action a. - ( RenderMessage UniWorX action, PathPiece action, Ord action, Eq action ) - => Map action (AForm (HandlerT UniWorX IO) a) - -> FieldSettings UniWorX - -> Maybe action - -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) -multiAction acts fs@FieldSettings{..} defAction csrf = do - mr <- getMessageRender - - let - options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece - (actionRes, actionView) <- mreq (selectField $ return options) fs defAction - results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts - - let actionResults = view _1 <$> results - actionViews = Map.foldrWithKey accViews [] results - - accViews :: forall b. action -> (b, [FieldView UniWorX]) -> [FieldView UniWorX] -> [FieldView UniWorX] - accViews act = flip mappend . over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/multi-action")) . snd - - return ((actionResults Map.!) =<< actionRes, over _fvInput (mappend $ toWidget csrf) actionView : actionViews) - -multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action) - => Map action (AForm (HandlerT UniWorX IO) a) - -> FieldSettings UniWorX - -> Maybe action - -> AForm Handler a -multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty - -multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action) - => Map action (AForm (HandlerT UniWorX IO) a) - -> FieldSettings UniWorX - -> Maybe action - -> (Html -> MForm Handler (FormResult a, Widget)) -multiActionM acts fSettings defAction = renderAForm FormStandard $ multiActionA acts fSettings defAction - formResultModal :: (MonadHandler m, RedirectUrl (HandlerSite m) route) => FormResult a -> route -> (a -> WriterT [Message] m ()) -> m () formResultModal res finalDest handler = maybeT_ $ do messages <- case res of diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 7b5fcc375..b8d960301 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -223,6 +223,23 @@ customMigrations = Map.fromListWith (>>) whenM (columnExists "study_terms" "shorthand") $ [executeQQ| UPDATE "study_terms" SET "shorthand" = NULL WHERE "shorthand" = '' |] whenM (columnExists "study_terms" "name") $ [executeQQ| UPDATE "study_terms" SET "name" = NULL WHERE "shorthand" = '' |] ) + , ( AppliedMigrationKey [migrationVersion|10.0.0|] [version|11.0.0|] + , whenM ((&&) <$> columnExists "sheet" "upload_mode" <*> columnExists "sheet" "submission_mode") $ do + sheetModes <- [sqlQQ| SELECT "id", "upload_mode", "submission_mode" FROM "sheet"; |] + [executeQQ| + ALTER TABLE "sheet" DROP COLUMN "upload_mode"; + ALTER TABLE "sheet" ALTER COLUMN "submission_mode" DROP DEFAULT; + ALTER TABLE "sheet" ALTER COLUMN "submission_mode" TYPE jsonb USING 'null'::jsonb; + |] + forM_ sheetModes $ \(shid :: SheetId, unSingle -> uploadMode :: Legacy.UploadMode, unSingle -> submissionMode :: Legacy.SheetSubmissionMode ) -> do + let submissionMode' = case (submissionMode, uploadMode) of + ( Legacy.NoSubmissions , _ ) -> SubmissionMode False Nothing + ( Legacy.CorrectorSubmissions, _ ) -> SubmissionMode True Nothing + ( Legacy.UserSubmissions , Legacy.NoUpload ) -> SubmissionMode False (Just NoUpload) + ( Legacy.UserSubmissions , Legacy.Upload True ) -> SubmissionMode False (Just $ Upload True) + ( Legacy.UserSubmissions , Legacy.Upload False ) -> SubmissionMode False (Just $ Upload False) + [executeQQ| UPDATE "sheet" SET "submission_mode" = #{submissionMode'} WHERE "id" = #{shid}; |] + ) ] diff --git a/src/Model/Migration/Types.hs b/src/Model/Migration/Types.hs index 5ec81cd81..4720bf099 100644 --- a/src/Model/Migration/Types.hs +++ b/src/Model/Migration/Types.hs @@ -1,11 +1,17 @@ module Model.Migration.Types where import ClassyPrelude.Yesod +import Data.Aeson import Data.Aeson.TH (deriveJSON, defaultOptions) +import Utils.PathPiece + import qualified Model as Current import qualified Model.Types.JSON as Current +import Data.Universe + + data SheetType = Bonus { maxPoints :: Current.Points } -- Erhöht nicht das Maximum, wird gutgeschrieben | Normal { maxPoints :: Current.Points } -- Erhöht das Maximum, wird gutgeschrieben @@ -19,6 +25,40 @@ sheetType Normal {..} = Current.Normal Current.Points {..} sheetType Pass {..} = Current.Normal Current.PassPoints {..} sheetType NotGraded = Current.NotGraded + +data UploadMode = NoUpload | Upload { unpackZips :: Bool } + deriving (Show, Read, Eq, Ord, Generic) + +deriveJSON defaultOptions ''UploadMode +Current.derivePersistFieldJSON ''UploadMode + +instance Universe UploadMode where + universe = NoUpload : (Upload <$> universe) +instance Finite UploadMode + +instance PathPiece UploadMode where + toPathPiece = \case + NoUpload -> "no-upload" + Upload True -> "unpack" + Upload False -> "no-unpack" + fromPathPiece = finiteFromPathPiece + +data SheetSubmissionMode = NoSubmissions + | CorrectorSubmissions + | UserSubmissions + deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece + } ''SheetSubmissionMode +derivePersistField "SheetSubmissionMode" + +instance Universe SheetSubmissionMode +instance Finite SheetSubmissionMode + +nullaryPathPiece ''SheetSubmissionMode camelToPathPiece + + {- TODO: * RenderMessage instance for newtype(SheetType) if needed -} diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 665fe9e69..527c748f1 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -16,6 +16,7 @@ import Utils import Control.Lens hiding (universe) import Utils.Lens.TH +import Data.Map ((!)) import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Map as Map @@ -24,6 +25,7 @@ import Data.Monoid (Sum(..)) import Data.Maybe (fromJust) import Data.Universe import Data.Universe.Helpers +import Data.Universe.TH import Data.UUID.Types (UUID) import qualified Data.UUID.Types as UUID @@ -289,12 +291,14 @@ instance DisplayAble DA where data UploadMode = NoUpload | Upload { unpackZips :: Bool } deriving (Show, Read, Eq, Ord, Generic) -deriveJSON defaultOptions ''UploadMode -derivePersistFieldJSON ''UploadMode +deriveFinite ''UploadMode -instance Universe UploadMode where - universe = NoUpload : (Upload <$> universe) -instance Finite UploadMode +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece + , fieldLabelModifier = camelToPathPiece + , sumEncoding = TaggedObject "mode" "settings" + }''UploadMode +derivePersistFieldJSON ''UploadMode instance PathPiece UploadMode where toPathPiece = \case @@ -303,20 +307,49 @@ instance PathPiece UploadMode where Upload False -> "no-unpack" fromPathPiece = finiteFromPathPiece -data SheetSubmissionMode = NoSubmissions - | CorrectorSubmissions - | UserSubmissions - deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) +data SubmissionMode = SubmissionMode + { submissionModeCorrector :: Bool + , submissionModeUser :: Maybe UploadMode + } + deriving (Show, Read, Eq, Ord, Generic) + +deriveFinite ''SubmissionMode deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece - } ''SheetSubmissionMode -derivePersistField "SheetSubmissionMode" + { fieldLabelModifier = camelToPathPiece' 2 + } ''SubmissionMode +derivePersistFieldJSON ''SubmissionMode -instance Universe SheetSubmissionMode -instance Finite SheetSubmissionMode +instance PathPiece SubmissionMode where + toPathPiece = (Map.fromList (zip universeF verbs) !) + where + verbs = [ "no-submissions" + , "no-upload" + , "no-unpack" + , "unpack" + , "correctors" + , "correctors+no-upload" + , "correctors+no-unpack" + , "correctors+unpack" + ] + fromPathPiece = finiteFromPathPiece -nullaryPathPiece ''SheetSubmissionMode camelToPathPiece +data SubmissionModeDescr = SubmissionModeNone + | SubmissionModeCorrector + | SubmissionModeUser + | SubmissionModeBoth + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe SubmissionModeDescr +instance Finite SubmissionModeDescr + +nullaryPathPiece ''SubmissionModeDescr $ camelToPathPiece' 2 + +classifySubmissionMode :: SubmissionMode -> SubmissionModeDescr +classifySubmissionMode (SubmissionMode False Nothing ) = SubmissionModeNone +classifySubmissionMode (SubmissionMode True Nothing ) = SubmissionModeCorrector +classifySubmissionMode (SubmissionMode False (Just _)) = SubmissionModeUser +classifySubmissionMode (SubmissionMode True (Just _)) = SubmissionModeBoth + data ExamStatus = Attended | NoShow | Voided deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index fc5bb1738..46087e831 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -11,9 +11,6 @@ import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..)) import qualified Database.Esqueleto as E (Value(..),InnerJoin(..)) -_unValue :: Lens' (E.Value a) a -_unValue f (E.Value a) = E.Value <$> f a - _PathPiece :: PathPiece v => Prism' Text v _PathPiece = prism' toPathPiece fromPathPiece @@ -102,6 +99,10 @@ makePrisms ''ErrorResponse makeLenses_ ''SheetCorrectorInvitation +makeLenses_ ''SubmissionMode + +makePrisms ''E.Value + -- makeClassy_ ''Load diff --git a/static/js/utils/form.js b/static/js/utils/form.js index ad87b3501..7a949c539 100644 --- a/static/js/utils/form.js +++ b/static/js/utils/form.js @@ -149,7 +149,7 @@ var INTERACTIVE_FIELDSET_UTIL_TARGET_SELECTOR = '.interactive-fieldset--target'; var INTERACTIVE_FIELDSET_INITIALIZED_CLASS = 'interactive-fieldset--initialized'; - var INTERACTIVE_FIELDSET_CHILD_SELECTOR = 'input:not([disabled])'; + var INTERACTIVE_FIELDSET_CHILD_SELECTOR = 'input:not([disabled]), select:not([disabled]), textarea:not([disabled]), button:not([disabled])'; var interactiveFieldsetUtil = function(element) { var conditionalInput; @@ -188,6 +188,10 @@ childInputs = Array.from(element.querySelectorAll(INTERACTIVE_FIELDSET_CHILD_SELECTOR)); // add event listener + var observer = new MutationObserver(function(mutationsList, observer) { + updateVisibility(); + }); + observer.observe(conditionalInput, { attributes: true, attributeFilter: ['disabled'] }); conditionalInput.addEventListener('input', updateVisibility); // initial visibility update @@ -204,12 +208,12 @@ } function updateVisibility() { - var active = matchesConditionalValue(); + var active = matchesConditionalValue() && !conditionalInput.disabled; target.classList.toggle('hidden', !active); childInputs.forEach(function(el) { - el.toggleAttribute('disabled', !active); + el.disabled = !active; }); } diff --git a/templates/sheetShow.hamlet b/templates/sheetShow.hamlet index 2cd90602b..994fbe52e 100644 --- a/templates/sheetShow.hamlet +++ b/templates/sheetShow.hamlet @@ -18,15 +18,15 @@ $maybe descr <- sheetDescription sheet
_{MsgSheetSolutionFrom}
#{solution}
_{MsgSheetSubmissionMode} -
_{sheetSubmissionMode sheet} +
_{classifySubmissionMode (sheetSubmissionMode sheet)} $case sheetSubmissionMode sheet - $of CorrectorSubmissions + $of SubmissionMode True _
_{MsgSheetCorrectorSubmissionsTip} $of _ $case sheetSubmissionMode sheet - $of CorrectorSubmissions + $of SubmissionMode True _
_{MsgSheetPseudonym}
$maybe pseudonym <- mPseudonym diff --git a/templates/submission.hamlet b/templates/submission.hamlet index 913322f79..b64a9a41c 100644 --- a/templates/submission.hamlet +++ b/templates/submission.hamlet @@ -1,7 +1,10 @@ $maybe cID <- mcid
- $case sheetUploadMode - $of Upload _ + $case sheetSubmissionMode + $of SubmissionMode False Nothing +

+ _{MsgSubmissionNoUploadExpected} + $of _

Archiv (Original) @@ -9,9 +12,6 @@ $maybe cID <- mcid $maybe fileTable <- mFileTable

_{MsgSubmissionFiles} ^{fileTable} - $of _ -

- _{MsgSubmissionNoUploadExpected} $if maySubmit && not (null lastEdits)

_{MsgLastEdits} diff --git a/test/Database.hs b/test/Database.hs index 3943263db..646539247 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -397,11 +397,11 @@ fillDb = do void . insert $ DegreeCourse ffp sdMst sdInf void . insert $ Lecturer jost ffp CourseLecturer void . insert $ Lecturer gkleen ffp CourseAssistant - adhoc <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions False + adhoc <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ Upload True) False insert_ $ SheetEdit gkleen now adhoc - feste <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions False + feste <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ Upload True) False insert_ $ SheetEdit gkleen now feste - keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions False + keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ Upload True) False insert_ $ SheetEdit gkleen now keine void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf) [(fhamann , Nothing) @@ -496,8 +496,7 @@ fillDb = do , sheetVisibleFrom = Just now , sheetActiveFrom = now , sheetActiveTo = (14 * nominalDay) `addUTCTime` now - , sheetSubmissionMode = CorrectorSubmissions - , sheetUploadMode = Upload True + , sheetSubmissionMode = SubmissionMode True Nothing , sheetHintFrom = Nothing , sheetSolutionFrom = Nothing , sheetAutoDistribute = True diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index d30237550..b042b2aa6 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -66,7 +66,11 @@ instance Arbitrary UploadMode where arbitrary = genericArbitrary shrink = genericShrink -instance Arbitrary SheetSubmissionMode where +instance Arbitrary SubmissionMode where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary SubmissionModeDescr where arbitrary = genericArbitrary shrink = genericShrink @@ -171,8 +175,10 @@ spec = do [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, pathPieceLaws, finiteLaws ] lawsCheckHspec (Proxy @UploadMode) [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, pathPieceLaws, finiteLaws ] - lawsCheckHspec (Proxy @SheetSubmissionMode) - [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, jsonLaws, persistFieldLaws, finiteLaws, pathPieceLaws ] + lawsCheckHspec (Proxy @SubmissionMode) + [ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, finiteLaws ] + lawsCheckHspec (Proxy @SubmissionModeDescr) + [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, finiteLaws, pathPieceLaws ] lawsCheckHspec (Proxy @ExamStatus) [ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, persistFieldLaws ] lawsCheckHspec (Proxy @Load)