Fix sheetForm

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.

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

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