diff --git a/.hlint.yaml b/.hlint.yaml index c499a227c..f6a6cd81c 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -183,6 +183,9 @@ - fixity: "infix 4 <<<.>=" - suggest: { lhs: maybeT (return ()), rhs: maybeT_ } + - suggest: { lhs: fromMaybe (return ()), rhs: maybeVoid } + - suggest: { lhs: maybe (return ()) void, rhs: maybeVoid } + - warn: { lhs: length xs >= n, rhs: minLength n xs, note: IncreasesLaziness } - warn: { lhs: n <= length xs, rhs: minLength n xs, note: IncreasesLaziness } - warn: { lhs: length xs > n, rhs: minLength (n + 1) xs, note: IncreasesLaziness } diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index e2a58c6f2..341acec97 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -402,6 +402,8 @@ SubmissionUserAlreadyAdded: Dieser Nutzer ist bereits als Mitabgebende(r) einget NoOpenSubmissions: Keine unkorrigierten Abgaben vorhanden SubmissionFilesCorrected: Abgegebene & Korrigierte Dateien RatingUpdatedFiles: Bei der Korrektur wurden Dateien angepasst oder hinzugefügt +SubmissionFilesUnchanged: Abgabedateien beibehalten +SubmissionFilesUnchangedTip: Sollen die bestehenden Abgabedateien beim Ersetzen der Abgabe unverändert übernommen werden? 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"} diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index 953f884e9..f92661d7a 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -400,6 +400,8 @@ SubmissionUserAlreadyAdded: This user is already configured as a submittor NoOpenSubmissions: No open submissions exist SubmissionFilesCorrected: Submitted & Corrected files RatingUpdatedFiles: During correction files were added or changed +SubmissionFilesUnchanged: Keep submission files +SubmissionFilesUnchangedTip: Should the existing submission files be retained unchanged while replacing the submission? SubmissionsDeleteQuestion n: Do you really want to delete the #{pluralEN n "submission" "submissions"} mentioned below? SubmissionsDeleted n: #{pluralEN n "Submission" "Submissions"} deleted diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs index 5ef12ca96..bbd7da7db 100644 --- a/src/Handler/Allocation/Application.hs +++ b/src/Handler/Allocation/Application.hs @@ -174,11 +174,12 @@ applicationForm maId@(is _Just -> isAlloc) cid muid ApplicationFormMode{..} mcsr (filesRes, filesView) <- let mkFs = bool MsgCourseApplicationFile MsgCourseApplicationArchive + prevAppFiles (Entity aId _) = runDBSource $ selectSource [CourseApplicationFileApplication ==. aId] [Asc CourseApplicationFileTitle] .| C.map (view $ _FileReference . _1) in if | not afmApplicantEdit || is _NoUpload courseApplicationsFiles -> return (FormSuccess Nothing, Nothing) | otherwise - -> fmap (over _2 $ Just . ($ [])) . aFormToForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles + -> fmap (over _2 $ Just . ($ [])) . aFormToForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles (prevAppFiles <$> mApp) (vetoRes, vetoView) <- if | afmLecturer diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 04acd6bd0..6ac51ebe7 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -303,7 +303,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB <*> allocationForm <*> apopt checkBoxField (fslI MsgCourseApplicationRequired & setTooltip MsgCourseApplicationRequiredTip) (cfAppRequired <$> template) <*> aopt htmlField (fslI MsgCourseApplicationInstructions & setTooltip MsgCourseApplicationInstructionsTip) (cfAppInstructions <$> template) - <*> aopt (multiFileField' . fromMaybe (return ()) $ cfAppInstructionFiles =<< template) (fslI MsgCourseApplicationTemplate & setTooltip MsgCourseApplicationTemplateTip) (cfAppInstructionFiles <$> template) + <*> aopt (multiFileField' . maybeVoid $ cfAppInstructionFiles =<< template) (fslI MsgCourseApplicationTemplate & setTooltip MsgCourseApplicationTemplateTip) (cfAppInstructionFiles <$> template) <*> apopt checkBoxField (fslI MsgCourseApplicationsText & setTooltip MsgCourseApplicationsTextTip) (cfAppText <$> template) <*> uploadModeForm (fslI MsgCourseApplicationsFiles & setTooltip MsgCourseApplicationsFilesTip) (fmap cfAppFiles template <|> pure NoUpload) <*> apopt checkBoxField (fslI MsgCourseApplicationRatingsVisible & setTooltip MsgCourseApplicationRatingsVisibleTip) (cfAppRatingsVisible <$> template) diff --git a/src/Handler/Course/News/Form.hs b/src/Handler/Course/News/Form.hs index 33e9a1938..f8cd56363 100644 --- a/src/Handler/Course/News/Form.hs +++ b/src/Handler/Course/News/Form.hs @@ -23,7 +23,7 @@ courseNewsForm :: Maybe CourseNewsForm -> Form CourseNewsForm courseNewsForm template = identifyForm FIDCourseNews . renderWForm FormStandard $ do now <- liftIO getCurrentTime - let oldFileIds = fromMaybe (return ()) $ template >>= cnfFiles + let oldFileIds = maybeVoid $ template >>= cnfFiles cTime = ceilingQuarterHour now visibleFromTip | Just vFrom <- template >>= cnfVisibleFrom diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index d173e1429..3affd85ee 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -132,11 +132,12 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do appFilesRes <- let mkFs | courseApplicationsRequired = bool MsgCourseApplicationFile MsgCourseApplicationArchive | otherwise = bool MsgCourseRegistrationFile MsgCourseRegistrationArchive + prevAppFiles (Entity aId _) = runDBSource $ selectSource [CourseApplicationFileApplication ==. aId] [Asc CourseApplicationFileTitle] .| C.map (view $ _FileReference . _1) in if | isRegistered -> return $ FormSuccess Nothing | otherwise - -> aFormToWForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles + -> aFormToWForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles (prevAppFiles <$> application) mayViewCourseAfterDeregistration <- liftHandler . runDB $ E.selectExists . E.from $ \course -> E.where_ $ course E.^. CourseId E.==. E.val cid diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 7dbb4cdf4..14902c5e9 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -87,7 +87,7 @@ postCUserR tid ssh csh uCId = do siteLayout headingLong $ do setTitleI headingShort - forM_ sections . fromMaybe $ return () + mapM_ maybeVoid sections courseUserProfileSection :: Entity Course -> Entity User -> MaybeT Handler Widget courseUserProfileSection course@(Entity cid Course{..}) (Entity uid User{ userShowSex = _, ..}) = do diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 46c313830..65c853db4 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -63,7 +63,7 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do (mfDescription <$> template) <*> aopt utcTimeField (fslI MsgMaterialVisibleFrom & setTooltip visibleToolTip) ((mfVisibleFrom <$> template) <|> pure (Just ctime)) - <*> aopt (multiFileField' . fromMaybe (return ()) $ mfFiles =<< template) + <*> aopt (multiFileField' . maybeVoid $ mfFiles =<< template) (fslI MsgMaterialFiles) (mfFiles <$> template) fetchMaterial :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Entity Material) @@ -326,7 +326,7 @@ handleMaterialEdit tid ssh csh cid template dbMaterial = do case mbmid of Nothing -> False <$ addMessageI Error (MsgMaterialNameDup tid ssh csh mfName) (Just mid) -> do -- save files in DB - insertMaterialFile' mid $ fromMaybe (return ()) mfFiles + insertMaterialFile' mid $ maybeVoid mfFiles addMessageI Success $ MsgMaterialSaveOk tid ssh csh mfName -- more info/warnings could go here return True diff --git a/src/Handler/Sheet/Edit.hs b/src/Handler/Sheet/Edit.hs index 6e3977fbd..5ac173421 100644 --- a/src/Handler/Sheet/Edit.hs +++ b/src/Handler/Sheet/Edit.hs @@ -92,10 +92,10 @@ handleSheetEdit tid ssh csh msId template dbAction = do case mbsid of Nothing -> False <$ addMessageI Error (MsgSheetNameDup tid ssh csh sfName) (Just sid) -> do -- save files in DB: - insertSheetFile' sid SheetExercise $ fromMaybe (return ()) sfSheetF - insertSheetFile' sid SheetHint $ fromMaybe (return ()) sfHintF - insertSheetFile' sid SheetSolution $ fromMaybe (return ()) sfSolutionF - insertSheetFile' sid SheetMarking $ fromMaybe (return ()) sfMarkingF + insertSheetFile' sid SheetExercise $ maybeVoid sfSheetF + insertSheetFile' sid SheetHint $ maybeVoid sfHintF + insertSheetFile' sid SheetSolution $ maybeVoid sfSolutionF + insertSheetFile' sid SheetMarking $ maybeVoid sfMarkingF runConduit $ maybe (return ()) (transPipe liftHandler) (spffFiles =<< sfPersonalF) .| sinkPersonalisedSheetFiles cid sid (maybe False spffFilesKeepExisting sfPersonalF) diff --git a/src/Handler/Submission/Correction.hs b/src/Handler/Submission/Correction.hs index 059606809..aee1db9fa 100644 --- a/src/Handler/Submission/Correction.hs +++ b/src/Handler/Submission/Correction.hs @@ -149,7 +149,7 @@ postCorrectionR tid ssh csh shn cid = do setTitleI heading urlArchive <- toTextUrl . CSubmissionR tid ssh csh shn cid $ SubArchiveR SubmissionCorrected let userCorrection = $(widgetFile "correction-user") - fromMaybe (return ()) invisibleWidget + maybeVoid invisibleWidget $(widgetFile "correction") _ -> notFound getCorrectionUserR tid ssh csh shn cid = do diff --git a/src/Handler/Submission/Helper.hs b/src/Handler/Submission/Helper.hs index f0fe0f853..3044c2d2c 100644 --- a/src/Handler/Submission/Helper.hs +++ b/src/Handler/Submission/Helper.hs @@ -29,12 +29,21 @@ import Data.Aeson.Lens import Handler.Submission.SubmissionUserInvite +import qualified Data.Conduit.Combinators as C -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 + +makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Maybe FileUploads -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe FileUploads, Set (Either UserEmail UserId)) +makeSubmissionForm cid msmid uploadMode grouping mPrev isLecturer prefillUsers = identifyForm FIDsubmission . renderAForm FormStandard $ (,) + <$> uploadForm <*> wFormToAForm submittorsForm' where + uploadForm + | is _NoUpload uploadMode = pure Nothing + | is _Nothing msmid = uploadForm' + | otherwise = join <$> optionalActionNegatedA uploadForm' (fslI MsgSubmissionFilesUnchanged & setTooltip MsgSubmissionFilesUnchangedTip) (Just False) + + uploadForm' = fileUploadForm (not isLecturer) (fslI . bool MsgSubmissionFile MsgSubmissionArchive) uploadMode mPrev + miCell' :: Markup -> Either UserEmail UserId -> Widget miCell' csrf (Left email) = do invWarnMsg <- messageIconI Info IconEmail $ if @@ -311,7 +320,8 @@ submissionHelper tid ssh csh shn mcid = do -- Therefore we do not restrict upload behaviour in any way in that case ((res,formWidget'), formEnctype) <- do (Entity _ Sheet{..}, buddies, _, _, isLecturer, isOwner, _, _) <- runDB getSheetInfo - runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (UploadAny True Nothing True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (maybe id (Set.insert . Right) muid) isOwner buddies + let mPrevUploads = msmid <&> \smid -> runDBSource $ selectSource [SubmissionFileSubmission ==. smid, SubmissionFileIsUpdate ==. False] [Asc SubmissionFileTitle] .| C.map (view $ _FileReference . _1) + runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (UploadAny True Nothing True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping mPrevUploads isLecturer $ bool id (maybe id (Set.insert . Right) muid) isOwner buddies let formWidget = wrapForm' BtnHandIn formWidget' def { formAction = Just $ SomeRoute actionUrl , formEncoding = formEnctype diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index ff9d9f601..c02e5841e 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -181,6 +181,20 @@ linkButton defWdgt lbl cls url = do -- Interactive fieldset -- -------------------------- +optionalAction'' :: Bool -- ^ negated? + -> (Field Handler Bool -> FieldSettings UniWorX -> Maybe Bool -> MForm Handler (FormResult Bool, FieldView UniWorX)) + -> AForm Handler a + -> FieldSettings UniWorX + -> Maybe Bool + -> (Html -> MForm Handler (FormResult (Maybe a), [FieldView UniWorX])) +optionalAction'' negated minp justAct fs@FieldSettings{..} defActive csrf = do + (doRes, doView) <- minp (bool id (isoField _not) negated checkBoxField) fs defActive + (actionRes, actionViews') <- over _2 ($ []) <$> aFormToForm justAct + + let actionViews = over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/optional-action")) actionViews' + + return (doRes >>= bool (pure Nothing) (Just <$> actionRes), over _fvInput (mappend $ toWidget csrf) doView : actionViews) + optionalAction :: AForm Handler a -> FieldSettings UniWorX -> Maybe Bool @@ -192,19 +206,19 @@ optionalAction' :: (Field Handler Bool -> FieldSettings UniWorX -> Maybe Bool -> -> FieldSettings UniWorX -> Maybe Bool -> (Html -> MForm Handler (FormResult (Maybe a), [FieldView UniWorX])) -optionalAction' minp justAct fs@FieldSettings{..} defActive csrf = do - (doRes, doView) <- minp checkBoxField fs defActive - (actionRes, actionViews') <- over _2 ($ []) <$> aFormToForm justAct - - let actionViews = over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/optional-action")) actionViews' - - return (doRes >>= bool (pure Nothing) (Just <$> actionRes), over _fvInput (mappend $ toWidget csrf) doView : actionViews) +optionalAction' = optionalAction'' False optionalActionA :: AForm Handler a -> FieldSettings UniWorX -> Maybe Bool -> AForm Handler (Maybe a) optionalActionA = optionalActionA' mpopt + +optionalActionNegatedA :: AForm Handler a + -> FieldSettings UniWorX + -> Maybe Bool + -> AForm Handler (Maybe a) +optionalActionNegatedA = optionalActionA'' True mpopt optionalActionA' :: (Field Handler Bool -> FieldSettings UniWorX -> Maybe Bool -> MForm Handler (FormResult Bool, FieldView UniWorX)) -> AForm Handler a @@ -213,6 +227,14 @@ optionalActionA' :: (Field Handler Bool -> FieldSettings UniWorX -> Maybe Bool - -> AForm Handler (Maybe a) optionalActionA' minp justAct fs defActive = formToAForm $ optionalAction' minp justAct fs defActive mempty +optionalActionA'' :: Bool + -> (Field Handler Bool -> FieldSettings UniWorX -> Maybe Bool -> MForm Handler (FormResult Bool, FieldView UniWorX)) + -> AForm Handler a + -> FieldSettings UniWorX + -> Maybe Bool + -> AForm Handler (Maybe a) +optionalActionA'' negated minp justAct fs defActive = formToAForm $ optionalAction'' negated minp justAct fs defActive mempty + optionalActionW :: AForm Handler a -> FieldSettings UniWorX -> Maybe Bool @@ -921,13 +943,15 @@ genericFileField mkOpts = Field{..} fieldEnctype = Multipart fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe FileUploads)) - fieldParse vals files = runExceptT $ do + fieldParse vals files' = runExceptT $ do + let files = filter (not . null . fileName) files' + opts@FileField{..} <- liftHandler mkOpts mIdent <- fmap getFirst . flip foldMapM vals $ \v -> fmap First . runMaybeT . exceptTMaybe $ encodedSecretBoxOpen v - let uploadedFilenames = fileName <$> bool (take 1) id fieldMultiple files + let uploadedFilenames = fileName <$> files let doUnpack @@ -974,7 +998,7 @@ genericFileField mkOpts = Field{..} .| C.mapMaybe (\fTitle -> fmap (fTitle, ) . assertM (views _3 $ not . fieldOptionForce) $ Map.lookup fTitle permittedFiles) .| C.filter (\(fTitle, _) -> fieldMultiple - || ( bool (\n h -> h == pure n) elem fieldMultiple fTitle (mapMaybe (preview _FileTitle) vals) + || ( fTitle `elem` mapMaybe (preview _FileTitle) vals && null files ) ) @@ -1092,47 +1116,67 @@ singleFileField prev = genericFileField $ do , fieldAllEmptyOk = True } -specificFileField :: UploadSpecificFile -> Field Handler FileUploads -specificFileField UploadSpecificFile{..} = convertField (.| fixupFileTitles) id . genericFileField $ return FileField - { fieldIdent = Nothing - , fieldUnpackZips = FileFieldUserOption True False - , fieldMultiple = False - , fieldRestrictExtensions = fromNullable . maybe Set.empty (Set.singleton . view _2) . Map.lookupMin . Map.fromList . map (length &&& id) $ fileNameExtensions specificFileName - , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty - , fieldMaxFileSize = specificFileMaxSize - , fieldAllEmptyOk = specificFileEmptyOk - } +specificFileField :: UploadSpecificFile -> Maybe FileUploads -> Field Handler FileUploads +specificFileField UploadSpecificFile{..} mPrev = convertField (.| fixupFileTitles) id . genericFileField $ do + previous <- runConduit $ maybeVoid mPrev .| C.foldMap Set.singleton + return FileField + { fieldIdent = Nothing + , fieldUnpackZips = FileFieldUserOption True False + , fieldMultiple = False + , fieldRestrictExtensions = fromNullable . maybe Set.empty (Set.singleton . view _2) . Map.lookupMin . Map.fromList . map (length &&& id) $ fileNameExtensions specificFileName + , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.fromList + [ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True)) + | FileReference{..} <- Set.toList previous + ] + , fieldMaxFileSize = specificFileMaxSize + , fieldAllEmptyOk = specificFileEmptyOk + } where fixupFileTitles = C.map $ set _fileReferenceTitle (unpack specificFileName) zipFileField :: Bool -- ^ Unpack zips? - -> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions - -> Bool -- ^ Empty files ok? - -> Field Handler FileUploads -zipFileField doUnpack permittedExtensions emptyOk = genericFileField $ return FileField - { fieldIdent = Nothing - , fieldUnpackZips = FileFieldUserOption True doUnpack - , fieldMultiple = doUnpack - , fieldRestrictExtensions = permittedExtensions - , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty - , fieldMaxFileSize = Nothing - , fieldAllEmptyOk = emptyOk - } + -> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions + -> Bool -- ^ Empty files ok? + -> Field Handler FileUploads +zipFileField doUnpack permittedExtensions emptyOk = zipFileField' doUnpack permittedExtensions emptyOk Nothing + +zipFileField' :: Bool -- ^ Unpack zips? + -> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions + -> Bool -- ^ Empty files ok? + -> Maybe FileUploads + -> Field Handler FileUploads +zipFileField' doUnpack permittedExtensions emptyOk mPrev = genericFileField $ do + previous <- runConduit $ maybeVoid mPrev .| C.foldMap Set.singleton + return FileField + { fieldIdent = Nothing + , fieldUnpackZips = FileFieldUserOption True doUnpack + , fieldMultiple = doUnpack + , fieldRestrictExtensions = permittedExtensions + , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.fromList + [ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True)) + | FileReference{..} <- Set.toList previous + ] + , fieldMaxFileSize = Nothing + , fieldAllEmptyOk = emptyOk + } fileUploadForm :: Bool -- ^ Required? -> (Bool -> FieldSettings UniWorX) -- ^ given @unpackZips@ generate `FieldSettings` in the case of `UploadAny` - -> UploadMode -> AForm Handler (Maybe FileUploads) -fileUploadForm isReq mkFs = \case + -> UploadMode + -> Maybe FileUploads + -> AForm Handler (Maybe FileUploads) +fileUploadForm isReq mkFs uMode mPrev = case uMode of NoUpload -> pure Nothing UploadAny{..} - -> bool aopt (\f fs _ -> Just <$> areq f fs Nothing) isReq (zipFileField uploadUnpackZips uploadExtensionRestriction uploadEmptyOk) (mkFs uploadUnpackZips) Nothing + -> bool (\f fs d -> aopt f fs $ Just <$> d) (\f fs d -> Just <$> apreq f fs d) isReq (zipFileField' uploadUnpackZips uploadExtensionRestriction uploadEmptyOk mPrev) (mkFs uploadUnpackZips) mPrev UploadSpecific{..} -> mergeFileSources <$> traverse specificFileForm (Set.toList $ toNullable uploadSpecificFiles) where specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe FileUploads) specificFileForm spec@UploadSpecificFile{..} - = bool (\f fs d -> aopt f fs $ fmap Just d) (\f fs d -> Just <$> areq f fs d) (specificFileRequired && isReq) (specificFileField spec) (fsl specificFileLabel) Nothing + = bool (\f fs d -> aopt f fs $ Just <$> d) (\f fs d -> Just <$> apreq f fs d) (specificFileRequired && isReq) (specificFileField spec mPrev') (fsl specificFileLabel) mPrev' + where mPrev' = flip (.|) (C.filter . has $ _fileReferenceTitle . only (unpack specificFileName)) <$> mPrev mergeFileSources :: [Maybe FileUploads] -> Maybe FileUploads mergeFileSources (catMaybes -> sources) = case sources of diff --git a/src/Utils.hs b/src/Utils.hs index c78b3e337..6a1fed5f9 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -700,6 +700,9 @@ hoistMaybe = maybe mzero return hoistMaybeM :: MonadPlus m => m (Maybe a) -> m a hoistMaybeM = (=<<) hoistMaybe +maybeVoid :: Monad m => Maybe (m a) -> m () +maybeVoid = maybe (return ()) void + catchIfMaybeT :: (MonadCatch m, Exception e) => (e -> Bool) -> m a -> MaybeT m a catchIfMaybeT p act = catchIf p (lift act) (const mzero) diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index b1e194d7d..7605d1e0e 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -82,6 +82,8 @@ _SqlKey = _SqlKey' . _Unwrapped _Integral :: (Integral a, Integral b) => Iso' a b _Integral = iso fromIntegral fromIntegral +_not :: Iso' Bool Bool +_not = iso not not ----------------------------------- -- Lens Definitions for our Types diff --git a/templates/widgets/multi-action/optional-action.hamlet b/templates/widgets/multi-action/optional-action.hamlet index dc9a96532..7afac8a50 100644 --- a/templates/widgets/multi-action/optional-action.hamlet +++ b/templates/widgets/multi-action/optional-action.hamlet @@ -1,4 +1,4 @@ -
+
_{fsLabel} ^{w}