diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 1ab2e4bf5..d7a6a484b 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -525,6 +525,7 @@ UploadModeUnpackZipsTip: Wenn die Abgabe mehrerer Dateien erlaubt ist, werden au UploadModeExtensionRestriction: Zulässige Dateiendungen UploadModeExtensionRestrictionTip: Komma-separiert. Wenn keine Dateiendungen angegeben werden erfolgt keine Einschränkung. +UploadModeExtensionRestrictionEmpty: Liste von zulässigen Dateiendungen darf nicht leer sein UploadSpecificFiles: Vorgegebene Dateinamen NoUploadSpecificFilesConfigured: Wenn der Abgabemodus vorgegebene Dateinamen vorsieht, muss mindestens ein vorgegebener Dateiname konfiguriert werden. diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index a9dbe1ede..12fdc847c 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -359,15 +359,15 @@ uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUp , ( UploadModeAny , UploadAny <$> apreq checkBoxField (fslI MsgUploadModeUnpackZips & setTooltip MsgUploadModeUnpackZipsTip) (prev ^? _Just . _unpackZips) - <*> apreq extensionRestrictionField (fslI MsgUploadModeExtensionRestriction & setTooltip MsgUploadModeExtensionRestrictionTip) ((prev ^? _Just . _extensionRestriction) <|> fmap Just defaultExtensionRestriction) + <*> aopt extensionRestrictionField (fslI MsgUploadModeExtensionRestriction & setTooltip MsgUploadModeExtensionRestrictionTip) ((prev ^? _Just . _extensionRestriction) <|> fmap Just defaultExtensionRestriction) ) , ( UploadModeSpecific , UploadSpecific <$> specificFileForm ) ] - extensionRestrictionField :: Field Handler (Maybe (NonNull (Set Extension))) - extensionRestrictionField = convertField (fromNullable . toSet) (maybe "" $ intercalate ", " . Set.toList . toNullable) textField + extensionRestrictionField :: Field Handler (NonNull (Set Extension)) + extensionRestrictionField = checkMMap (return . maybe (Left MsgUploadModeExtensionRestrictionEmpty) Right . fromNullable . toSet) (intercalate ", " . Set.toList . toNullable) textField where toSet = Set.fromList . filter (not . Text.null) . map (stripDot . Text.strip) . Text.splitOn "," stripDot ext diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index c2797980d..2c04192ec 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -690,23 +690,32 @@ mforced Field{..} FieldSettings{..} val = do aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) => Field m a -> FieldSettings site -> a -> AForm m a -aforced field settings val = formToAForm $ second pure <$> mforced field settings val - -apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) - => Field m a -> FieldSettings site -> Maybe a -> AForm m a --- ^ Pseudo required -apreq f fs mx = formToAForm $ do - mr <- getMessageRender - over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } )) <$> mopt f fs (Just <$> mx) +aforced field settings val = formToAForm $ over _2 pure <$> mforced field settings val mpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) => Field m a -> FieldSettings site -> Maybe a -> MForm m (FormResult a, FieldView site) +-- ^ Pseudo required +-- +-- `FieldView` has `fvRequired` set to `True` and @FormSuccess Nothing@ is cast to `FormFailure`. +-- Otherwise acts exactly like `mopt`. mpreq f fs mx = do mr <- getMessageRender - over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> mx) + (res, fv) <- mopt f fs (Just <$> mx) + let fv' = fv { fvRequired = True } + return $ case res of + FormSuccess (Just res') + -> (FormSuccess res', fv') + FormSuccess Nothing + -> (FormFailure [mr MsgValueRequired], fv' { fvErrors = Just . toHtml $ mr MsgValueRequired }) + FormFailure errs + -> (FormFailure errs, fv') + FormMissing + -> (FormMissing, fv') + +apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) + => Field m a -> FieldSettings site -> Maybe a -> AForm m a +apreq f fs mx = formToAForm $ over _2 pure <$> mpreq f fs mx wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) => Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a) -wpreq f fs mx = mFormToWForm $ do - mr <- getMessageRender - over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> mx) +wpreq f fs mx = mFormToWForm $ mpreq f fs mx