module Handler.Utils.Form ( module Handler.Utils.Form , module Handler.Utils.Form.MassInput , module Handler.Utils.Pandoc , module Utils.Form , MonadWriter(..) ) where import Utils.Form import Utils.Files import Handler.Utils.Form.Types import Handler.Utils.Pandoc import Handler.Utils.DateTime import Handler.Utils.I18n import Handler.Utils.Files import Handler.Utils.Exam import Utils.Term import Import import Data.Char ( chr, ord, isDigit ) import qualified Data.Char as Char import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI -- import Yesod.Core import qualified Data.Text as T -- import Yesod.Form.Types import Yesod.Form.Bootstrap3 import Handler.Utils.Zip import qualified Data.Conduit.Combinators as C import qualified Data.Conduit.List as C (mapMaybe, mapMaybeM) import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Internal.Internal as E (SqlSelect) import qualified Data.Set as Set import qualified Data.Sequence as Seq import Data.Map ((!), (!?)) import qualified Data.Map as Map import qualified Data.Vector as Vector import qualified Data.HashMap.Lazy as HashMap import Control.Monad.Error.Class (MonadError(..)) import Data.Aeson (eitherDecodeStrict') import Data.Aeson.Text (encodeToLazyText) import qualified Text.Email.Validate as Email import Data.Text.Lens (unpacked) import Text.Blaze (toMarkup) import Handler.Utils.Form.MassInput import qualified Data.Binary as Binary import qualified Data.ByteString.Base64.URL as Base64 import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder) import qualified Data.Text.Lazy.Builder as Builder import qualified Data.Yaml as Yaml import Control.Monad.Catch.Pure (runCatch) {-# ANN module ("HLint: ignore Use const" :: String) #-} ---------------------------- -- Buttons (new version ) -- ---------------------------- -- NOTE: ButtonSubmit is defined in Utils.Form ! data ButtonDelete = BtnDelete deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Universe ButtonDelete instance Finite ButtonDelete nullaryPathPiece ''ButtonDelete $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''ButtonDelete id instance Button UniWorX ButtonDelete where btnClasses BtnDelete = [BCIsButton, BCDanger] data ButtonSave = BtnSave deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Universe ButtonSave instance Finite ButtonSave -- | Save-Button as AForm saveButton :: (Button (HandlerSite m) ButtonSave, MonadHandler m) => AForm m () saveButton = combinedButtonFieldF_ (Proxy @ButtonSave) "" nullaryPathPiece ''ButtonSave $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''ButtonSave id instance Button UniWorX ButtonSave where btnClasses BtnSave = [BCIsButton, BCPrimary] data ButtonHandIn = BtnHandIn deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Universe ButtonHandIn instance Finite ButtonHandIn nullaryPathPiece ''ButtonHandIn $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''ButtonHandIn id instance Button UniWorX ButtonHandIn where btnClasses BtnHandIn = [BCIsButton, BCPrimary] data ButtonRegister = BtnRegister | BtnDeregister deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Universe ButtonRegister instance Finite ButtonRegister nullaryPathPiece ''ButtonRegister $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''ButtonRegister id instance Button UniWorX ButtonRegister where btnClasses BtnRegister = [BCIsButton, BCPrimary] btnClasses BtnDeregister = [BCIsButton, BCDanger] data ButtonHijack = BtnHijack deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Universe ButtonHijack instance Finite ButtonHijack nullaryPathPiece ''ButtonHijack $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''ButtonHijack id instance Button UniWorX ButtonHijack where btnClasses BtnHijack = [BCIsButton, BCDefault] data ButtonSubmitDelete = BtnSubmit' | BtnDelete' deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Universe ButtonSubmitDelete instance Finite ButtonSubmitDelete embedRenderMessage ''UniWorX ''ButtonSubmitDelete $ dropSuffix "'" instance Button UniWorX ButtonSubmitDelete where btnClasses BtnSubmit' = [BCIsButton, BCPrimary] btnClasses BtnDelete' = [BCIsButton, BCDanger] btnValidate _ BtnSubmit' = True btnValidate _ BtnDelete' = False nullaryPathPiece ''ButtonSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'" -- | Looks like a button, but is just a link (e.g. for create course, etc.) linkButton :: Widget -- ^ Widget to display if unauthorized -> Widget -- ^ Button label -> [ButtonClass UniWorX] -> SomeRoute UniWorX -> Widget -- Alternative: Handler.Utils.simpleLink linkButton defWdgt lbl cls url = do access <- hasReadAccessTo $ urlRoute url if | not access -> defWdgt | otherwise -> do url' <- toTextUrl url [whamlet| $newline never ^{lbl} |] -------------------------- -- 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 -> (Html -> MForm Handler (FormResult (Maybe a), [FieldView UniWorX])) optionalAction = optionalAction' mpopt optionalAction' :: (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' = 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 -> 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 -> WForm Handler (FormResult (Maybe a)) optionalActionW = optionalActionW' mpopt optionalActionW' :: (Field Handler Bool -> FieldSettings UniWorX -> Maybe Bool -> MForm Handler (FormResult Bool, FieldView UniWorX)) -> AForm Handler a -> FieldSettings UniWorX -> Maybe Bool -> WForm Handler (FormResult (Maybe a)) optionalActionW' minp justAct fs defAction = aFormToWForm $ optionalActionA' minp justAct fs defAction multiAction :: forall action a. ( RenderMessage UniWorX action, PathPiece action, Ord action ) => Map action (AForm Handler a) -> FieldSettings UniWorX -> Maybe action -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) multiAction = multiAction' mpopt multiActionOpts :: forall action a. Ord action => Map action (AForm Handler a) -> Handler (OptionList action) -> FieldSettings UniWorX -> Maybe action -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) multiActionOpts = multiActionOpts' mpopt multiAction' :: forall action a. ( RenderMessage UniWorX action, PathPiece action, Ord action ) => (Field Handler action -> FieldSettings UniWorX -> Maybe action -> MForm Handler (FormResult action, FieldView UniWorX)) -> Map action (AForm Handler a) -> FieldSettings UniWorX -> Maybe action -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) multiAction' minp acts = multiActionOpts' minp acts (optionsF $ Map.keysSet acts) multiActionField :: forall action a. Ord action => (Field Handler action -> FieldSettings UniWorX -> Maybe action -> MForm Handler (FormResult action, FieldView UniWorX)) -> Map action (AForm Handler a) -> (Field Handler action, action -> Maybe Text, action -> Maybe (SomeMessage UniWorX)) -> FieldSettings UniWorX -> Maybe action -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) multiActionField minp acts (actField, actExternal, actMessage) fs defAction csrf = do (actionRes, actionView) <- minp (checkBool (`Map.member` acts) MsgMultiActionUnknownAction actField) fs defAction results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts MsgRenderer mr <- getMsgRenderer let actionResults = view _1 <$> results actionViews = Map.foldrWithKey accViews [] results accViews :: forall b. action -> (b, [FieldView UniWorX]) -> [FieldView UniWorX] -> [FieldView UniWorX] accViews act | Just optionExternalValue <- actExternal act , Just (mr -> optionDisplay) <- actMessage act = flip mappend . over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/multi-action")) . snd | otherwise = const id return ((actionResults Map.!) =<< actionRes, over _fvInput (mappend $ toWidget csrf) actionView : actionViews) multiActionOpts' :: forall action a. Ord action => (Field Handler action -> FieldSettings UniWorX -> Maybe action -> MForm Handler (FormResult action, FieldView UniWorX)) -> Map action (AForm Handler a) -> Handler (OptionList action) -> FieldSettings UniWorX -> Maybe action -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) multiActionOpts' minp acts mActsOpts fs defAction csrf = do actsOpts <- liftHandler mActsOpts let actsOpts' = OptionList { olOptions = filter (flip Map.member acts . optionInternalValue) $ olOptions actsOpts , olReadExternal = assertM (`Map.member` acts) . olReadExternal actsOpts } acts' = Map.filterWithKey (\a _ -> any ((== a) . optionInternalValue) $ olOptions actsOpts') acts actOption act = find (\Option{..} -> optionInternalValue == act) $ olOptions actsOpts' actExternal = fmap optionExternalValue . actOption actMessage = fmap (SomeMessage . optionDisplay) . actOption multiActionField minp acts' (selectField $ return actsOpts', actExternal, actMessage) fs defAction csrf multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action) => Map action (AForm Handler a) -> FieldSettings UniWorX -> Maybe action -> AForm Handler a multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty multiActionAOpts :: Ord action => Map action (AForm Handler a) -> Handler (OptionList action) -> FieldSettings UniWorX -> Maybe action -> AForm Handler a multiActionAOpts acts opts fSettings defAction = formToAForm $ multiActionOpts acts opts fSettings defAction mempty multiActionW :: (RenderMessage UniWorX action, PathPiece action, Ord action) => Map action (AForm Handler a) -> FieldSettings UniWorX -> Maybe action -> WForm Handler (FormResult a) multiActionW acts fSettings defAction = aFormToWForm $ multiActionA acts fSettings defAction multiActionWOpts :: Ord action => Map action (AForm Handler a) -> Handler (OptionList action) -> FieldSettings UniWorX -> Maybe action -> WForm Handler (FormResult a) multiActionWOpts acts opts fSettings defAction = aFormToWForm $ multiActionAOpts acts opts fSettings defAction multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action) => Map action (AForm Handler a) -> FieldSettings UniWorX -> Maybe action -> (Html -> MForm Handler (FormResult a, Widget)) multiActionM acts fSettings defAction = renderAForm FormStandard $ multiActionA acts fSettings defAction multiActionMOpts :: Ord action => Map action (AForm Handler a) -> Handler (OptionList action) -> FieldSettings UniWorX -> Maybe action -> (Html -> MForm Handler (FormResult a, Widget)) multiActionMOpts acts opts fSettings defAction = renderAForm FormStandard $ multiActionAOpts acts opts fSettings defAction ------------------------- -- Explained selection -- ------------------------- explainedSelectionField :: forall m a. ( MonadHandler m , HandlerSite m ~ UniWorX , Eq a ) => Maybe (SomeMessage UniWorX, Maybe Widget) -- ^ Label for none option -> Handler ([(Option a, Maybe Widget)], Text -> Maybe a) -> Field m a explainedSelectionField optMsg' mkOpts = Field{..} where fieldEnctype = UrlEncoded fieldParse ts _ = do (_, parser) <- liftHandler mkOpts if | t : _ <- ts , Just t' <- parser t -> return . Right $ Just t' | t : _ <- ts , null t -> return $ Right Nothing | t : _ <- ts -> return . Left . SomeMessage $ MsgInvalidEntry t | otherwise -> return $ Right Nothing fieldView theId name attrs val isReq = do (opts, _) <- liftHandler mkOpts let optMsg = guardOnM (not isReq) optMsg' inputId optExternal = [st|#{theId}__input--#{optExternal}|] matchesVal Nothing = is _Left val matchesVal (Just x) = val == Right x $(widgetFile "widgets/explained-selection-field") explainOptionList :: forall a. Handler (OptionList a) -> (a -> MaybeT Handler Widget) -> Handler ([(Option a, Maybe Widget)], Text -> Maybe a) explainOptionList ol mkExplanation = do OptionList{..} <- ol olOptions' <- forM olOptions $ \opt@Option{..} -> (opt, ) <$> runMaybeT (mkExplanation optionInternalValue) return (olOptions', olReadExternal) explainedMultiAction' :: forall action a. Ord action => (Field Handler action -> FieldSettings UniWorX -> Maybe action -> MForm Handler (FormResult action, FieldView UniWorX)) -> Map action (AForm Handler a) -> Handler ([(Option action, Maybe Widget)], Text -> Maybe action) -> FieldSettings UniWorX -> Maybe action -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) explainedMultiAction' minp acts mActsOpts fs defAction csrf = do (actsOpts, actsReadExternal) <- liftHandler mActsOpts let actsOpts' = filter (flip Map.member acts . optionInternalValue . view _1) actsOpts actsReadExternal' = assertM (`Map.member` acts) . actsReadExternal acts' = Map.filterWithKey (\a _ -> any ((== a) . optionInternalValue . view _1) actsOpts') acts actOption act = find (\Option{..} -> optionInternalValue == act) $ view _1 <$> actsOpts' actExternal = fmap optionExternalValue . actOption actMessage = fmap (SomeMessage . optionDisplay) . actOption multiActionField minp acts' (explainedSelectionField Nothing $ return (actsOpts', actsReadExternal'), actExternal, actMessage) fs defAction csrf explainedMultiAction :: forall action a. Ord action => Map action (AForm Handler a) -> Handler ([(Option action, Maybe Widget)], Text -> Maybe action) -> FieldSettings UniWorX -> Maybe action -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) explainedMultiAction = explainedMultiAction' mpopt explainedMultiActionA :: forall action a. Ord action => Map action (AForm Handler a) -> Handler ([(Option action, Maybe Widget)], Text -> Maybe action) -> FieldSettings UniWorX -> Maybe action -> AForm Handler a explainedMultiActionA acts mActsOpts fSettings defAction = formToAForm $ explainedMultiAction acts mActsOpts fSettings defAction mempty ------------ -- Fields -- ------------ -- | add some additional text immediately after the field widget; probably not a good idea to use annotateField :: ToWidget (HandlerSite m) wgt => wgt -> Field m a -> Field m a annotateField ann field@Field{fieldView=fvf} = let fvf' idt nmt atts ei bl = [whamlet| $newline never ^{fvf idt nmt atts ei bl} ^{ann} |] in field { fieldView=fvf'} -- ciField moved to Utils.Form routeField :: ( Monad m , HandlerSite m ~ UniWorX ) => Field m (Route UniWorX) routeField = checkMMap (return . maybe (Left MsgInvalidRoute) Right . fromPathPiece) toPathPiece textField natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i natFieldI msg = convertField fromInteger toInteger $ checkBool (>= 0) msg $ intMinField 0 posIntFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i posIntFieldI msg = convertField fromInteger toInteger $ checkBool (> 0) msg $ intMinField 0 -- | Field to request integral number > 'm' minIntFieldI :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage, RenderMessage (HandlerSite m) msg) => i -> msg -> Field m i minIntFieldI m msg = checkBool (> m) msg $ intMinField m pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points pointsField = pointsFieldMinMax (Just 0) Nothing pointsFieldMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Field m Points pointsFieldMax = pointsFieldMinMax (Just 0) pointsFieldMinMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Maybe Points -> Field m Points pointsFieldMinMax lower upper = checklower $ checkupper $ fixedPrecMinMaxField lower upper -- NOTE: fixedPrecMinMaxField uses HTML5 input attributes min & max for better browser supprt, but may not be supported by all browsers yet where checklower | Just 0 <- lower = checkBool (>= 0) MsgPointsNotPositive | Just minp <- lower = checkBool (>= minp) $ MsgPointsTooLow minp | otherwise = id checkupper | Just maxp <- upper = checkBool (<= maxp) $ MsgPointsTooHigh maxp | otherwise = id matriculationField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text matriculationField = textField -- no restrictions, since not everyone has a matriculation and pupils need special tags here termsActiveField :: Field Handler TermId termsActiveField = selectField . fmap (fmap entityKey) $ do now <- liftIO getCurrentTime muid <- maybeAuthId flip optionsE termName . E.from $ \t -> do E.where_ $ termIsActiveE (E.val now) (E.val muid) (t E.^. TermId) E.orderBy [E.desc $ t E.^. TermStart] return t termsAllowedField :: Field Handler TermId termsAllowedField = selectField . fmap (fmap entityKey) $ do mayEditTerm <- hasWriteAccessTo TermEditR now <- liftIO getCurrentTime muid <- maybeAuthId flip optionsE termName . E.from $ \t -> do unless mayEditTerm $ E.where_ $ termIsActiveE (E.val now) (E.val muid) (t E.^. TermId) E.orderBy [E.desc $ t E.^. TermStart] return t termField :: Field Handler TermId termField = selectField $ optionsPersistKey [] [Desc TermStart] termName termsSetField :: [TermId] -> Field Handler TermId termsSetField tids = selectField $ optionsPersistKey [TermName <-. (unTermKey <$> tids)] [Desc TermStart] termName -- termsSetField tids = selectFieldList [(unTermKey t, t)| t <- tids ] termsActiveOrSetField :: [TermId] -> Field Handler TermId termsActiveOrSetField tids = selectField . fmap (fmap entityKey) $ do now <- liftIO getCurrentTime muid <- maybeAuthId flip optionsE termName . E.from $ \t -> do E.where_ $ termIsActiveE (E.val now) (E.val muid) (t E.^. TermId) E.||. t E.^. TermId `E.in_` E.valList tids E.orderBy [E.desc $ t E.^. TermStart] return t -- termActiveOld :: Field Handler TermIdentifier -- termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName termNewField :: Field Handler TermIdentifier termNewField = checkMMap (return.termFromText) termToText textField schoolField :: Field Handler SchoolId schoolField = selectField $ optionsPersistKey [] [Asc SchoolName] schoolName schoolFieldEnt :: Field Handler (Entity School) schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName schoolFieldFor :: [SchoolId] -> Field Handler SchoolId schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName degreeField :: Field Handler StudyDegreeId degreeField = selectField $ optionsPersistKey [] [Asc StudyDegreeName, Asc StudyDegreeShorthand, Asc StudyDegreeKey] id degreeFieldEnt :: Field Handler (Entity StudyDegree) degreeFieldEnt = selectField $ optionsPersist [] [Asc StudyDegreeName, Asc StudyDegreeShorthand, Asc StudyDegreeKey] id -- | Select one of the user's primary active study features, or from a given list of StudyFeatures (regardless of user) studyFeaturesPrimaryFieldFor :: Bool -- ^ Allow user to select `Nothing` (only applies if set of options is nonempty)? -> [StudyFeaturesId] -> Maybe UserId -> Field Handler (Maybe StudyFeaturesId) {-# DEPRECATED studyFeaturesPrimaryFieldFor "Use studyFeaturesFieldFor" #-} studyFeaturesPrimaryFieldFor = studyFeaturesFieldFor . Just $ Set.singleton FieldPrimary -- | Select one of the user's active study features, or from a given list of StudyFeatures (regardless of user) studyFeaturesFieldFor :: Maybe (Set StudyFieldType) -- ^ Optionally restrict fields to only given types -> Bool -- ^ Allow user to select `Nothing` (only applies if set of options is nonempty)? -> [StudyFeaturesId] -> Maybe UserId -> Field Handler (Maybe StudyFeaturesId) studyFeaturesFieldFor mRestr isOptional oldFeatures mbuid = selectField $ do -- we need a join, so we cannot just use optionsPersistCryptoId rawOptions <- runDB $ E.select $ E.from $ \(feature `E.InnerJoin` degree `E.InnerJoin` field) -> do E.on $ feature E.^. StudyFeaturesField E.==. field E.^. StudyTermsId E.on $ feature E.^. StudyFeaturesDegree E.==. degree E.^. StudyDegreeId E.where_ $ ((feature E.^. StudyFeaturesId) `E.in_` E.valList oldFeatures) E.||. (isActiveUserStudyFeature feature E.&&. isCorrectType feature) return (feature, degree, field) MsgRenderer mr <- getMsgRenderer let showTypes | length rawOptions <= 1 = False | Just restr <- mRestr , Set.size restr == 1 = False | otherwise = True mkOptionList . nonEmptyOptions (mr MsgNoStudyField) <$> mapM (procOptions showTypes mr) rawOptions where isActiveUserStudyFeature feature = case mbuid of Nothing -> E.false Just uid -> feature E.^. StudyFeaturesUser E.==. E.val uid E.&&. feature E.^. StudyFeaturesValid isCorrectType feature = case mRestr of Nothing -> E.true Just restr -> feature E.^. StudyFeaturesType `E.in_` E.valList (Set.toList restr) procOptions :: Bool -> (forall msg. RenderMessage UniWorX msg => msg -> Text) -> (Entity StudyFeatures, Entity StudyDegree, Entity StudyTerms) -> Handler (Option (Maybe StudyFeaturesId)) procOptions showTypes mr (Entity sfid sfeat, Entity _dgid sdegree, Entity _stid sterm) = do cfid <- encrypt sfid return Option { optionDisplay = if | showTypes -> mr $ StudyDegreeTermType sdegree sterm (studyFeaturesType sfeat) | otherwise -> mr $ StudyDegreeTerm sdegree sterm , optionInternalValue = Just sfid , optionExternalValue = toPathPiece (cfid :: CryptoID UUID StudyFeaturesId) } nonEmptyOptions :: Text -> [Option (Maybe StudyFeaturesId)] -> [Option (Maybe StudyFeaturesId)] nonEmptyOptions emptyOpt opts | null opts = pure nullOption | isOptional = nullOption : opts | otherwise = opts where nullOption = Option { optionDisplay = emptyOpt , optionInternalValue = Nothing , optionExternalValue = "NoStudyField" } uploadModeForm :: FieldSettings UniWorX -> Maybe UploadMode -> AForm Handler UploadMode uploadModeForm fs prev = multiActionA actions fs (classifyUploadMode <$> prev) where actions :: Map UploadModeDescr (AForm Handler UploadMode) actions = Map.fromList [ ( UploadModeNone, pure NoUpload) , ( UploadModeAny , UploadAny <$> (fromMaybe False <$> aopt checkBoxField (fslI MsgUploadModeUnpackZips & setTooltip MsgUploadModeUnpackZipsTip) (Just $ prev ^? _Just . _uploadUnpackZips)) <*> aopt extensionRestrictionField (fslI MsgUploadModeExtensionRestriction & setTooltip MsgUploadModeExtensionRestrictionTip) ((prev ^? _Just . _uploadExtensionRestriction) <|> fmap Just defaultExtensionRestriction) <*> apopt checkBoxField (fslI MsgUploadAnyEmptyOk & setTooltip MsgUploadAnyEmptyOkTip) (preview (_Just . _uploadEmptyOk) prev <|> Just False) ) , ( UploadModeSpecific , UploadSpecific <$> specificFileForm ) ] 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 | Just nExt <- Text.stripPrefix "." ext = nExt | otherwise = ext specificFileForm :: AForm Handler (NonNull (Set UploadSpecificFile)) specificFileForm = wFormToAForm $ do currentRoute' <- getCurrentRoute let miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction frag = do currentRoute <- currentRoute' return . SomeRoute $ currentRoute :#: frag miIdent <- ("specific-files--" <>) <$> newIdent postProcess =<< massInputW MassInput{..} (fslI MsgUploadSpecificFiles) True (preProcess <$> prev ^? _Just . _uploadSpecificFiles) where preProcess :: NonNull (Set UploadSpecificFile) -> Map ListPosition (UploadSpecificFile, UploadSpecificFile) preProcess = Map.fromList . zip [0..] . map (\x -> (x, x)) . Set.toList . toNullable postProcess :: FormResult (Map ListPosition (UploadSpecificFile, UploadSpecificFile)) -> WForm Handler (FormResult (NonNull (Set UploadSpecificFile))) postProcess mapResult = do MsgRenderer mr <- getMsgRenderer return $ do mapResult' <- Set.fromList . map snd . Map.elems <$> mapResult case fromNullable mapResult' of Nothing -> throwError [mr MsgNoUploadSpecificFilesConfigured] Just lResult -> do let names = Set.map specificFileName mapResult' labels = Set.map specificFileLabel mapResult' if | Set.size names /= Set.size mapResult' -> throwError [mr MsgUploadSpecificFilesDuplicateNames] | Set.size labels /= Set.size mapResult' -> throwError [mr MsgUploadSpecificFilesDuplicateLabels] | otherwise -> return lResult sFileForm :: (Text -> Text) -> Maybe UploadSpecificFile -> Form UploadSpecificFile sFileForm nudge mPrevUF csrf = do (labelRes, labelView) <- mpreq textField (fslI MsgUploadSpecificFileLabel & addName (nudge "label")) $ specificFileLabel <$> mPrevUF (nameRes, nameView) <- mpreq textField (fslI MsgUploadSpecificFileName & addName (nudge "name")) $ specificFileName <$> mPrevUF (emptyOkRes, emptyOkView) <- mpopt checkBoxField (fslI MsgUploadSpecificFileEmptyOk & addName (nudge "empty-ok")) $ fmap specificFileEmptyOk mPrevUF <|> Just False (maxSizeRes, maxSizeView) <- mopt (natFieldI MsgUploadSpecificFileMaxSizeNegative) (fslI MsgUploadSpecificFileMaxSize & addName (nudge "max-size")) $ specificFileMaxSize <$> mPrevUF (reqRes, reqView) <- mpreq checkBoxField (fslI MsgUploadSpecificFileRequired & addName (nudge "required")) $ specificFileRequired <$> mPrevUF return ( UploadSpecificFile <$> labelRes <*> nameRes <*> reqRes <*> emptyOkRes <*> maxSizeRes , $(widgetFile "widgets/massinput/uploadSpecificFiles/form") ) miAdd _ _ nudge submitView = Just $ \csrf -> do (formRes, formWidget) <- sFileForm nudge Nothing csrf let formWidget' = $(widgetFile "widgets/massinput/uploadSpecificFiles/add") addRes' = formRes <&> \fileRes oldRess -> let iStart = maybe 0 (succ . fst) $ Map.lookupMax oldRess in pure $ Map.singleton iStart fileRes return (addRes', formWidget') miCell _ initFile _ nudge csrf = sFileForm nudge (Just initFile) csrf miDelete :: MassInputDelete ListLength miDelete = miDeleteList miAllowAdd _ _ _ = True miAddEmpty _ _ _ = Set.empty miLayout :: MassInputLayout ListLength UploadSpecificFile UploadSpecificFile miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/uploadSpecificFiles/layout") submissionModeForm :: Maybe SubmissionMode -> AForm Handler SubmissionMode submissionModeForm prev = explainedMultiActionA actions opts (fslI MsgUtilSheetSubmissionMode) $ classifySubmissionMode <$> prev where actions :: Map SubmissionModeDescr (AForm Handler SubmissionMode) actions = Map.fromList [ ( SubmissionModeNone , pure $ SubmissionMode False Nothing ) , ( SubmissionModeCorrector , pure $ SubmissionMode True Nothing ) , ( SubmissionModeUser , SubmissionMode False . Just <$> uploadModeForm (fslI MsgSheetUploadMode) (prev ^? _Just . _submissionModeUser . _Just) ) , ( SubmissionModeBoth , SubmissionMode True . Just <$> uploadModeForm (fslI MsgSheetUploadMode) (prev ^? _Just . _submissionModeUser . _Just) ) ] opts = explainOptionList optionsFinite $ \case SubmissionModeNone -> mzero SubmissionModeCorrector -> return $(i18nWidgetFile "submission-mode-explanation/corrector") SubmissionModeUser -> return $(i18nWidgetFile "submission-mode-explanation/user") SubmissionModeBoth -> return $ i18n MsgBothSubmissionsTip data ExamBonusRule' = ExamBonusManual' | ExamBonusPoints' deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe ExamBonusRule' instance Finite ExamBonusRule' nullaryPathPiece ''ExamBonusRule' $ camelToPathPiece' 1 . dropSuffix "'" embedRenderMessage ''UniWorX ''ExamBonusRule' id classifyBonusRule :: ExamBonusRule -> ExamBonusRule' classifyBonusRule = \case ExamBonusManual{} -> ExamBonusManual' ExamBonusPoints{} -> ExamBonusPoints' examBonusRuleForm :: Maybe ExamBonusRule -> AForm Handler ExamBonusRule examBonusRuleForm prev = multiActionA actions (fslI MsgUtilExamBonusRule) $ classifyBonusRule <$> prev where actions :: Map ExamBonusRule' (AForm Handler ExamBonusRule) actions = Map.fromList [ ( ExamBonusManual' , ExamBonusManual <$> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamBonusOnlyPassed) (Just <$> preview _bonusOnlyPassed =<< prev)) ) , ( ExamBonusPoints' , ExamBonusPoints <$ wFormToAForm (pure () <$ (wformMessage =<< messageI Info MsgExamBonusInfoPoints)) <*> apreq (checkBool (> 0) MsgExamBonusMaxPointsNonPositive pointsField) (fslI MsgExamBonusMaxPoints & setTooltip MsgExamBonusMaxPointsTip) (preview _bonusMaxPoints =<< prev) <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamBonusOnlyPassed) (Just <$> preview _bonusOnlyPassed =<< prev)) <*> areq (checkBool (> 0) MsgExamBonusRoundNonPositive pointsField) (fslI MsgExamBonusRound & setTooltip MsgExamBonusRoundTip) (preview _bonusRound =<< prev) ) ] data ExamOccurrenceRule' = ExamRoomManual' | ExamRoomFifo' | ExamRoomSurname' | ExamRoomMatriculation' | ExamRoomRandom' deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe ExamOccurrenceRule' instance Finite ExamOccurrenceRule' nullaryPathPiece ''ExamOccurrenceRule' $ camelToPathPiece' 1 . dropSuffix "'" embedRenderMessage ''UniWorX ''ExamOccurrenceRule' id classifyExamOccurrenceRule :: ExamOccurrenceRule -> ExamOccurrenceRule' classifyExamOccurrenceRule = \case ExamRoomManual -> ExamRoomManual' ExamRoomSurname -> ExamRoomSurname' ExamRoomMatriculation -> ExamRoomMatriculation' ExamRoomRandom -> ExamRoomRandom' ExamRoomFifo -> ExamRoomFifo' examOccurrenceRuleForm :: Maybe ExamOccurrenceRule -> AForm Handler ExamOccurrenceRule examOccurrenceRuleForm = fmap reverseClassify . areq (selectField optionsFinite) (fslI MsgExamAutomaticOccurrenceAssignment & setTooltip MsgExamAutomaticOccurrenceAssignmentTip) . fmap classifyExamOccurrenceRule where reverseClassify = \case ExamRoomManual' -> ExamRoomManual ExamRoomFifo' -> ExamRoomFifo ExamRoomSurname' -> ExamRoomSurname ExamRoomMatriculation' -> ExamRoomMatriculation ExamRoomRandom' -> ExamRoomRandom data ExamGradingRule' = ExamGradingKey' deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe ExamGradingRule' instance Finite ExamGradingRule' nullaryPathPiece ''ExamGradingRule' $ camelToPathPiece' 2 . dropSuffix "'" embedRenderMessage ''UniWorX ''ExamGradingRule' id classifyExamGradingRule :: ExamGradingRule -> ExamGradingRule' classifyExamGradingRule = \case ExamGradingKey{} -> ExamGradingKey' examGradingRuleForm :: Maybe ExamGradingRule -> AForm Handler ExamGradingRule examGradingRuleForm prev = multiActionA actions (fslI MsgUtilExamGradingRule) $ classifyExamGradingRule <$> prev where actions :: Map ExamGradingRule' (AForm Handler ExamGradingRule) actions = Map.fromList [ ( ExamGradingKey' , ExamGradingKey <$> gradingKeyForm (fslI MsgExamGradingKey & setTooltip MsgExamGradingKeyTip) (preview _examGradingKey =<< prev) ) ] gradingKeyForm :: FieldSettings UniWorX -> Maybe [Points] -> AForm Handler [Points] gradingKeyForm FieldSettings{..} template = formToAForm . over (mapped . _2) pure $ do MsgRenderer mr <- getMsgRenderer fvId <- maybe newIdent return fsId fvName <- maybe newFormIdent return fsName let grades :: [ExamGrade] grades = universeF let boundsFS (Text.filter isDigit . toPathPiece -> g) = "" & addPlaceholder (mr MsgPoints) & addName (fvName <> "__" <> g) & addId (fvId <> "__" <> g) bounds <- forM grades $ \case g@Grade50 -> mforced pointsField (boundsFS g) 0 grade -> mpreq pointsField (boundsFS grade) $ preview (ix . pred $ fromEnum grade) =<< template let errors | anyOf (folded . _1 . _FormSuccess) (< 0) bounds = [mr MsgPointsMustBeNonNegative] | FormSuccess bounds' <- mapM (view _1) bounds , not $ monotone bounds' = [mr MsgPointsMustBeMonotonic] | otherwise = [] return ( if | null errors -> sequence . unsafeTail $ map fst bounds | otherwise -> FormFailure errors , FieldView { fvLabel = toMarkup $ mr fsLabel , fvTooltip = toMarkup . mr <$> fsTooltip , fvId , fvInput = let boundWidgets = map (fvInput . snd) bounds in $(widgetFile "widgets/gradingKey") , fvErrors = if | (e : _) <- errors -> Just $ toMarkup e | otherwise -> Nothing , fvRequired = True } ) where monotone (x1:x2:xs) = x1 <= x2 && monotone (x2:xs) monotone _ = True pseudonymWordField :: Field Handler PseudonymWord pseudonymWordField = checkMMap doCheck id $ ciField & addDatalist (return $ mkOptionList [ Option w' w w' | w <- pseudonymWordlist, let w' = CI.original w ]) where doCheck w | Just w' <- find (== w) pseudonymWordlist = return $ Right w' | otherwise = return . Left $ MsgUnknownPseudonymWord (CI.original w) uploadContents :: (MonadHandler m, HandlerSite m ~ UniWorX) => ConduitT FileReference ByteString m () uploadContents = transPipe (liftHandler . runDB) sourceFiles .| C.mapMaybeM fileContent' where fileContent' f = runMaybeT $ do File{fileContent = Just fc} <- return f liftHandler . runDB . runConduit $ fc .| C.fold genericFileField :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX ) => Handler (FileField FileReference) -> Field m FileUploads genericFileField mkOpts = Field{..} where permittedExtension :: FileField FileReference -> FileName -> Bool permittedExtension FileField{..} fTitle | unpack fTitle `Map.member` view _FileReferenceFileReferenceTitleMap fieldAdditionalFiles = True | Just exts <- fieldRestrictExtensions = anyOf (re _nullable . folded . unpacked) ((flip isExtensionOf `on` CI.foldCase) $ unpack fTitle) exts | otherwise = True getIdent :: forall m'. (MonadHandler m', RenderRoute (HandlerSite m')) => FileField FileReference -> m' (Maybe Text) getIdent FileField{..} = do ident <- case fieldIdent of Just ident -> return $ Just ident Nothing -> runMaybeT $ do cRoute <- MaybeT getCurrentRoute pos <- newIdent $logDebugS "genericFileField.getIdent" pos return $ hash (cRoute, pos) & toStrict . Binary.encode & decodeUtf8 . Base64.encodeUnpadded $logDebugS "genericFileField.getIdent" $ tshow ident return ident getPermittedFiles :: Maybe Text -> FileField FileReference -> DB (Map FilePath (Maybe FileContentReference, UTCTime, FileFieldUserOption Bool)) getPermittedFiles mIdent opts@FileField{..} = do sessionFiles <- for mIdent $ \fieldIdent' -> foldMap (HashMap.findWithDefault mempty fieldIdent' . unMergeHashMap) <$> lookupSessionJson @_ @(MergeHashMap Text (Map FilePath (SessionFileId, UTCTime))) @_ SessionFiles sessionFiles' <- flip foldMapM sessionFiles $ \sFiles -> flip foldMapM (Map.toList sFiles) $ \(fTitle, (sfId, fModified)) -> maybeT (return Map.empty) $ do SessionFile{..} <- MaybeT $ get sfId guard $ is _Nothing sessionFileContent || permittedExtension opts (pack fTitle) return $ Map.singleton fTitle (sessionFileContent, fModified, FileFieldUserOption False True) $logDebugS "genericFileField.getPermittedFiles" $ "Additional: " <> tshow fieldAdditionalFiles $logDebugS "genericFileField.getPermittedFiles" $ "Session: " <> tshow sessionFiles' return $ mconcat [ Map.filter (views _3 $ (||) <$> not . fieldOptionForce <*> not . fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap , sessionFiles' , Map.filter (views _3 $ (&&) <$> fieldOptionForce <*> fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap ] handleUpload :: FileField FileReference -> Maybe Text -> ConduitT (File Handler) FileReference (YesodDB UniWorX) () handleUpload FileField{fieldMaxFileSize} mIdent = C.map (transFile liftHandler) .| C.mapMaybeM (\f@File{..} -> maybeT (return $ Just f) $ do maxSize <- fromIntegral <$> hoistMaybe fieldMaxFileSize fc <- hoistMaybe fileContent let peekNE n = do str <- C.takeE n .| C.fold leftover str yield str (unsealConduitT -> fc', size) <- lift $ fc $$+ peekNE (succ maxSize) .| C.lengthE return . guardOn (size <= maxSize) $ f { fileContent = Just fc' } ) .| sinkFiles .| C.mapM mkSessionFile where mkSessionFile fRef@FileReference{..} = fRef <$ do now <- liftIO getCurrentTime sfId <- insert $ SessionFile fileReferenceContent now whenIsJust mIdent $ \ident -> modifySessionJson SessionFiles $ \(fromMaybe mempty -> MergeHashMap old) -> Just . MergeHashMap $ HashMap.insert ident (Map.insert fileReferenceTitle (sfId, fileReferenceModified) $ HashMap.findWithDefault mempty ident old) old _FileTitle :: Prism' Text FilePath _FileTitle = prism' (("f." <>) . pack) $ fmap unpack . Text.stripPrefix "f." fieldEnctype = Multipart fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe FileUploads)) 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 <$> files let doUnpack | fieldOptionForce fieldUnpackZips = fieldOptionDefault fieldUnpackZips | otherwise = unpackZips `elem` vals handleFile :: FileInfo -> ConduitT () (File Handler) Handler () handleFile | doUnpack = receiveFiles | otherwise = yieldM . acceptFile invalidUploadExtension fName = not (permittedExtension opts fName) && (not doUnpack || ((/=) `on` simpleContentType) (mimeLookup fName) typeZip) whenIsJust fieldMaxFileSize $ \maxSize -> forM_ files $ \fInfo -> do fLength <- runConduit $ fileSource fInfo .| C.takeE (fromIntegral $ succ maxSize) .| C.lengthE when (fLength > maxSize) $ do when (is _Just mIdent) $ liftHandler . runDB . runConduit $ mapM_ (transPipe lift . handleFile) files .| handleUpload opts mIdent .| C.sinkNull throwE . SomeMessage . MsgGenericFileFieldFileTooLarge . unpack $ fileName fInfo if | invExt : _ <- filter invalidUploadExtension uploadedFilenames -> do when (is _Just mIdent) $ liftHandler . runDB . runConduit $ mapM_ (transPipe lift . handleFile) files .| handleUpload opts mIdent .| C.sinkNull throwE . SomeMessage . MsgGenericFileFieldInvalidExtension $ unpack invExt | otherwise -> do let fSrc = do permittedFiles <- liftHandler . runDB $ getPermittedFiles mIdent opts yieldMany [ FileReference{..} | ( fileReferenceTitle , (fileReferenceContent, fileReferenceModified, FileFieldUserOption{..}) ) <- Map.toList permittedFiles , fieldOptionForce, fieldOptionDefault ] yieldMany vals .| C.mapMaybe (preview _FileTitle) .| C.mapMaybe (\fTitle -> fmap (fTitle, ) . assertM (views _3 $ not . fieldOptionForce) $ Map.lookup fTitle permittedFiles) .| C.filter (\(fTitle, _) -> fieldMultiple || ( fTitle `elem` mapMaybe (preview _FileTitle) vals && null files ) ) .| C.map (\(fileReferenceTitle, (fileReferenceContent, fileReferenceModified, _)) -> FileReference{..}) mapM_ handleFile (bool (take 1) id fieldMultiple files) .| transPipe runDB (handleUpload opts mIdent) (fSrc'', allEmpty) <- if | fieldAllEmptyOk -> return (fSrc, False) | otherwise -> let checkEmpty = do (peeked, failed) <- go [] mapM_ leftover $ peeked ++ hoistMaybe failed return $ is _Nothing failed go acc = do next <- await case next of Nothing -> return (reverse acc, Nothing) Just x | isEmptyFileReference x -> go $ x : acc | otherwise -> return (reverse acc, Just x) in liftHandler . over (mapped . _1) unsealConduitT $ fSrc $$+ checkEmpty (fSrc', length -> nFiles) <- liftHandler $ runPeekN 2 fSrc'' $logDebugS "genericFileField.fieldParse" $ tshow nFiles if | nFiles <= 0 -> return Nothing | allEmpty -> throwE $ SomeMessage MsgUploadAtLeastOneNonemptyFile | nFiles <= 1 -> return $ Just fSrc' | not fieldMultiple -> do liftHandler . runDB . runConduit $ mapM_ (transPipe lift . handleFile) files .| handleUpload opts mIdent .| sinkNull throwE $ SomeMessage MsgOnlyUploadOneFile | otherwise -> return $ Just fSrc' fieldView :: FieldViewFunc m FileUploads fieldView fieldId fieldName _attrs val req = do opts@FileField{..} <- liftHandler mkOpts mIdent <- getIdent opts identSecret <- for mIdent $ encodedSecretBox SecretBoxShort fileInfos <- liftHandler $ do references <- for val $ fmap (Map.fromList . map (\FileReference{..} -> (fileReferenceTitle, (fileReferenceContent, fileReferenceModified)))) . sourceToList permittedFiles <- runDB $ getPermittedFiles mIdent opts let sentVals :: Either Text (Set FilePath) sentVals = references <&> (`Set.intersection` Map.keysSet permittedFiles) . Map.keysSet let toFUI fuiTitle = let fuiHtmlId = [st|#{fieldId}--#{fuiTitle}|] fuiChecked | Right sentVals' <- sentVals = fuiTitle `Set.member` sentVals' | Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap = fieldOptionDefault | otherwise = False fuiSession = fuiTitle `Map.notMember` view _FileReferenceFileReferenceTitleMap fieldAdditionalFiles fuiForced | Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle permittedFiles = fieldOptionForce | otherwise = False in FileUploadInfo{..} fileInfos' = map toFUI . Set.toList $ fold sentVals <> Map.keysSet permittedFiles return $ sortOn (splitPath . fuiTitle) fileInfos' let mayUnpack = not (fieldOptionForce fieldUnpackZips) || fieldOptionDefault fieldUnpackZips zipExtensions = mimeExtensions typeZip acceptRestricted = isJust fieldRestrictExtensions accept = Text.intercalate "," . map ("." <>) $ bool [] (Set.toList zipExtensions) mayUnpack ++ toListOf (_Just . re _nullable . folded) fieldRestrictExtensions uploadOnlySessionMessage <- messageIconI Warning IconFileUploadSession MsgFileUploadOnlySessionTip $(widgetFile "widgets/genericFileField") unpackZips :: Text unpackZips = "unpack-zip" fileFieldMultiple :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m FileUploads fileFieldMultiple = genericFileField $ return FileField { fieldIdent = Nothing , fieldUnpackZips = FileFieldUserOption True False , fieldMultiple = True , fieldRestrictExtensions = Nothing , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty , fieldMaxFileSize = Nothing , fieldAllEmptyOk = True } fileField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m FileUploads fileField = singleFileField $ return () singleFileField :: (MonadHandler m, HandlerSite m ~ UniWorX) => FileUploads -> Field m FileUploads singleFileField prev = genericFileField $ do permitted <- runConduit $ prev .| C.foldMap Set.singleton return FileField { fieldIdent = Nothing , fieldUnpackZips = FileFieldUserOption True False , fieldMultiple = False , fieldRestrictExtensions = Nothing , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.fromList [ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True)) | FileReference{..} <- Set.toList permitted ] , fieldMaxFileSize = Nothing , fieldAllEmptyOk = True } 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 = 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 -> Maybe FileUploads -> AForm Handler (Maybe FileUploads) fileUploadForm isReq mkFs uMode mPrev = case uMode of NoUpload -> pure Nothing UploadAny{..} -> 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 $ 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 [] -> Nothing fs -> Just $ sequence_ fs multiFileField' :: FileUploads -- ^ Permitted files in same format as produced by `multiFileField` -> Field Handler FileUploads multiFileField' permittedFiles = multiFileField . runConduit $ permittedFiles .| C.foldMap Set.singleton multiFileField :: Handler (Set FileReference) -- ^ Set of files that may be submitted by id-reference -> Field Handler FileUploads multiFileField mkPermitted = genericFileField $ mkField <$> mkPermitted where mkField permitted = FileField { fieldIdent = Nothing , fieldUnpackZips = FileFieldUserOption False False , fieldMultiple = True , fieldRestrictExtensions = Nothing , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.fromList [ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True)) | FileReference{..} <- Set.toList permitted ] , fieldMaxFileSize = Nothing , fieldAllEmptyOk = True } data SheetGrading' = Points' | PassPoints' | PassBinary' | PassAlways' deriving (Eq, Ord, Read, Show, Enum, Bounded) instance Universe SheetGrading' instance Finite SheetGrading' nullaryPathPiece ''SheetGrading' (camelToPathPiece . dropSuffix "'") embedRenderMessage ''UniWorX ''SheetGrading' ("SheetGrading" <>) data SheetGroup' = Arbitrary' | RegisteredGroups' | NoGroups' deriving (Eq, Ord, Read, Show, Enum, Bounded) instance Universe SheetGroup' instance Finite SheetGroup' nullaryPathPiece ''SheetGroup' (camelToPathPiece . dropSuffix "'") embedRenderMessage ''UniWorX ''SheetGroup' (("SheetGroup" <>) . dropSuffix "'") sheetGradingAFormReq :: FieldSettings UniWorX -> Maybe SheetGrading -> AForm Handler SheetGrading sheetGradingAFormReq fs template = multiActionA selOptions fs (classify' <$> template) where selOptions = Map.fromList [ ( Points', Points <$> maxPointsReq ) , ( PassPoints', PassPoints <$> maxPointsReq <*> passPointsReq ) , ( PassBinary', pure PassBinary) , ( PassAlways', pure PassAlways) ] classify' :: SheetGrading -> SheetGrading' classify' = \case Points {} -> Points' PassPoints {} -> PassPoints' PassBinary {} -> PassBinary' PassAlways {} -> PassAlways' maxPointsReq = apreq pointsField (fslI MsgSheetGradingMaxPoints) (template >>= preview _maxPoints) passPointsReq = apreq pointsField (fslI MsgSheetGradingPassingPoints) (template >>= preview _passingPoints) sheetTypeAFormReq :: CourseId -> FieldSettings UniWorX -> Maybe (SheetType ExamPartId) -> AForm Handler (SheetType ExamPartId) sheetTypeAFormReq cId fs template = wFormToAForm $ do (examParts'', editableExams) <- liftHandler . runDB $ do examParts'' <- E.select . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examPart) -> do E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse E.where_ $ exam E.^. ExamCourse E.==. E.val cId return (exam, course, examPart) editableExams <- fmap Map.keysSet . flip mapFilterM (foldMap (\(Entity eId exam, Entity _ course, _) -> Map.singleton eId (exam, course)) examParts'') $ \(Exam{..}, Course{..}) -> hasWriteAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EEditR return (examParts'', editableExams) let examParts' = flip foldMap examParts'' $ \(eEnt@(Entity eId _), _, epEnt) -> guardOn @[] (eId `Set.member` editableExams) (eEnt, epEnt) examParts = flip sortOn examParts' $ \(Entity _ Exam{..}, Entity _ ExamPart{..}) -> (examName, examPartNumber) doExamPartPoints = fmap classifySheetType template == Just ExamPartPoints' || not (null examParts) acts = Map.fromList $ catMaybes [ pure ( Normal', Normal <$> gradingReq ) , pure ( Bonus' , Bonus <$> gradingReq ) , pure ( Informational', Informational <$> gradingReq ) , pure ( NotGraded', pure NotGraded ) , guardOn doExamPartPoints ( ExamPartPoints', ExamPartPoints <$> examPartReq <*> weightReq <*> gradingReq ) ] gradingReq = sheetGradingAFormReq (fslI MsgSheetGrading & setTooltip MsgSheetGradingInfo) $ template >>= preview _grading weightReq = apreq (checkBool (>= 0) MsgSheetTypeExamPartPointsWeightNegative rationalField) (fslI MsgSheetTypeExamPartPointsWeight) $ preview (_Just . _weight) template examPartReq = apreq examPartField (fslI MsgSheetTypeExamPartPointsExamPart) $ preview (_Just . _examPart) template >>= assertM' (\epId -> any (\(_, Entity epId' _) -> epId == epId') examParts) examPartField = selectField' Nothing . fmap (fmap $ \(_, Entity epId _) -> epId) $ optionsCryptoIdF examParts (\(_, Entity epId _) -> return epId) (\(Entity _ Exam{..}, Entity _ ExamPart{..}) -> return $ MsgSheetTypeExamPartPointsExamPartOption examName examPartNumber) opts = explainOptionList optionsFinite $ \case Normal' -> return $ i18n MsgSheetTypeInfoNormalLecturer Bonus' -> return $ i18n MsgSheetTypeInfoBonus Informational' -> return $ i18n MsgSheetTypeInfoInformational NotGraded' -> return $ i18n MsgSheetTypeInfoNotGraded ExamPartPoints' -> return $ i18n MsgSheetTypeInfoExamPartPoints aFormToWForm . explainedMultiActionA acts opts fs $ classifySheetType <$> template sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup sheetGroupAFormReq fs template = explainedMultiActionA acts opts fs (classify' <$> template) where acts = Map.fromList [ ( Arbitrary', Arbitrary <$> apreq (natFieldI MsgGroupSizeNotNatural) (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template) ) , ( RegisteredGroups', pure RegisteredGroups ) , ( NoGroups', pure NoGroups ) ] opts = explainOptionList optionsFinite $ \case Arbitrary' -> return $(i18nWidgetFile "sheet-grouping-explanation/arbitrary") RegisteredGroups' -> return $(i18nWidgetFile "sheet-grouping-explanation/registered") NoGroups' -> mzero classify' :: SheetGroup -> SheetGroup' classify' = \case Arbitrary _ -> Arbitrary' RegisteredGroups -> RegisteredGroups' NoGroups -> NoGroups' {- dayTimeField :: FieldSettings UniWorX -> Maybe UTCTime -> Form Handler UTCTime dayTimeField fs mutc = do let (mbDay,mbTime) = case mutcs of Nothing -> return (Nothing,Nothing) (Just utc) -> (dayResult, dayView) <- mreq dayField fs (result, view) <- (,) <$> dayField <*> timeField where (mbDay,mbTime) | (Just utc) <- mutc = let lt = utcToLocalTime ??? utcs in (Just $ localDay lt, Just $ localTimeOfDay lt) | otherwise = (Nothing,Nothing) -} fieldTimeFormat :: String -- fieldTimeFormat = "%e.%m.%y %k:%M" fieldTimeFormat = "%Y-%m-%dT%H:%M:%S" localTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m LocalTime localTimeField = Field { fieldParse = parseHelperGen readTime , fieldView = \theId name attrs val isReq -> do val' <- either id id <$> traverse (formatTime' fieldTimeFormat) val [whamlet| $newline never |] , fieldEnctype = UrlEncoded } where -- `defaultTimeLocale` is okay here, since `fieldTimeFormat` does not contain any words readTime :: Text -> Either (SomeMessage UniWorX) LocalTime readTime t = case parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of Just lTime -> Right lTime Nothing -> Left (SomeMessage MsgInvalidDateTimeFormat) utcTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m UTCTime utcTimeField = checkMMap (return . localTimeToUTC') utcToLocalTime localTimeField where localTimeToUTC' l = case localTimeToUTC l of LTUUnique{_ltuResult} -> Right _ltuResult LTUNone{} -> Left MsgIllDefinedUTCTime LTUAmbiguous{} -> Left MsgAmbiguousUTCTime langField :: Bool -- ^ Only allow values from `appLanguages` -> Field Handler Lang langField False = checkBool langCheck MsgInvalidLangFormat $ textField & addDatalist appLanguagesOpts & cfStrip where langCheck (T.splitOn "-" -> lParts) = all ((&&) <$> not . null <*> T.all Char.isAlpha) lParts && not (null lParts) langField True = selectField appLanguagesOpts data JsonFieldKind = JsonFieldNormal | JsonFieldLarge | JsonFieldHidden deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) deriving anyclass (Universe, Finite) jsonField :: ( ToJSON a, FromJSON a , MonadHandler m , RenderMessage (HandlerSite m) FormMessage , RenderMessage (HandlerSite m) UniWorXTablePaginationMessage ) => JsonFieldKind -> Field m a jsonField fieldKind = Field{..} where inputType :: Text inputType = case fieldKind of JsonFieldHidden -> "hidden" _other -> "text" fieldParse [encodeUtf8 -> v] [] = return . bimap (SomeMessage . MsgJSONFieldDecodeFailure) Just $ eitherDecodeStrict' v <|> eitherDecodeStrict' (urlDecode True v) fieldParse [] [] = return $ Right Nothing fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired fieldView theId name attrs val isReq = case fieldKind of JsonFieldLarge -> liftWidget [whamlet| $newline never