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 Handler.Utils.Form.Types import Handler.Utils.Pandoc import Handler.Utils.DateTime import Handler.Utils.Widgets import Handler.Utils.I18n import Import import Data.Char (chr, ord) 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.List as C import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E import qualified Data.Set as Set import Data.Map ((!), (!?)) import qualified Data.Map as Map import qualified Data.HashMap.Lazy as HashMap import Control.Monad.Writer.Class 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 Data.Char (isDigit) 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.Time.Clock.System (systemEpochDay) ---------------------------- -- 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.) -- data LinkButton = LinkButton (Route UniWorX) -- deriving (Enum, Eq, Ord, Bounded, Read, Show) -- -- instance PathPiece LinkButton where -- LinkButton route = ??? linkButton :: Widget -> Widget -> [ButtonClass UniWorX] -> SomeRoute UniWorX -> Widget -- Alternative: Handler.Utils.simpleLink linkButton defWdgt lbl cls url = do access <- evalAccess (urlRoute url) False case access of Unauthorized _ -> defWdgt _other -> do url' <- toTextUrl url [whamlet| $newline never ^{lbl} |] -------------------------- -- Interactive fieldset -- -------------------------- 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' 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) optionalActionA :: AForm Handler a -> FieldSettings UniWorX -> Maybe Bool -> AForm Handler (Maybe a) optionalActionA = optionalActionA' 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 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@FieldSettings{..} 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 = flip const 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@FieldSettings{..} defAction csrf = do actsOpts <- liftHandler mActsOpts let actsOpts' = OptionList { olOptions = filter (flip Map.member acts . optionInternalValue) $ olOptions actsOpts , olReadExternal = assertM (flip Map.member acts) . olReadExternal actsOpts } acts' = Map.filterWithKey (\a _ -> any ((== a) . optionInternalValue) $ olOptions actsOpts') acts actOption act = listToMaybe . filter (\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@FieldSettings{..} defAction csrf = do (actsOpts, actsReadExternal) <- liftHandler mActsOpts let actsOpts' = filter (flip Map.member acts . optionInternalValue . view _1) actsOpts actsReadExternal' = assertM (flip Map.member acts) . actsReadExternal acts' = Map.filterWithKey (\a _ -> any ((== a) . optionInternalValue . view _1) actsOpts') acts actOption act = listToMaybe . filter (\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 limit = pointsFieldMinMax (Just 0) limit 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 $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName termsAllowedField :: Field Handler TermId termsAllowedField = selectField $ do mayEditTerm <- isAuthorized TermEditR True let termFilter | Authorized <- mayEditTerm = [] | otherwise = [TermActive ==. True] optionsPersistKey termFilter [Desc TermStart] termName termField :: Field Handler TermId termField = selectField $ optionsPersistKey [] [Asc TermName] 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 $ optionsPersistKey ([TermActive ==.True] ||. [TermName <-. terms]) [Desc TermStart] termName where terms = map unTermKey tids -- 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 :: Maybe UploadMode -> AForm Handler UploadMode uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (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 . _unpackZips)) <*> aopt extensionRestrictionField (fslI MsgUploadModeExtensionRestriction & setTooltip MsgUploadModeExtensionRestrictionTip) ((prev ^? _Just . _extensionRestriction) <|> fmap Just defaultExtensionRestriction) ) , ( 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 . _specificFiles) 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 ("" & addName (nudge "label")) $ specificFileLabel <$> mPrevUF (nameRes, nameView) <- mpreq textField ("" & addName (nudge "name")) $ specificFileName <$> mPrevUF (reqRes, reqView) <- mpreq checkBoxField ("" & addName (nudge "required")) $ specificFileRequired <$> mPrevUF return ( UploadSpecificFile <$> labelRes <*> nameRes <*> reqRes , $(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 MsgSheetSubmissionMode) $ 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 (prev ^? _Just . _submissionModeUser . _Just) ) , ( SubmissionModeBoth , SubmissionMode True . Just <$> uploadModeForm (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 MsgExamBonusRule) $ 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 <$> 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 MsgExamGradingRule) $ 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' <- sequence $ map (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) type FileUploads = ConduitT () (Either FileId File) Handler () uploadContents :: (MonadHandler m, HandlerSite m ~ UniWorX) => ConduitT (Either FileId File) ByteString m () uploadContents = C.mapMaybeM $ either dbContents (return . fileContent) where dbContents = fmap (fileContent =<<) . liftHandler . runDB . get data FileFieldUserOption a = FileFieldUserOption { fieldOptionForce :: Bool , fieldOptionDefault :: a } deriving (Eq, Ord, Read, Show, Generic, Typeable) data FileField = FileField { fieldIdent :: Maybe Text , fieldUnpackZips :: FileFieldUserOption Bool , fieldMultiple :: Bool , fieldRestrictExtensions :: Maybe (NonNull (Set Extension)) , fieldAdditionalFiles :: Map FileId (FileFieldUserOption Bool) } deriving (Eq, Ord, Read, Show, Generic, Typeable) genericFileField :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX ) => Handler FileField -> Field m FileUploads genericFileField mkOpts = Field{..} where permittedExtension :: FileField -> FileName -> Bool permittedExtension FileField{..} fTitle | 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 -> 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.encode & Text.dropWhileEnd (== '=') $logDebugS "genericFileField.getIdent" $ tshow ident return ident getPermittedFiles :: Maybe Text -> FileField -> DB (Map FileId (FileFieldUserOption Bool)) getPermittedFiles mIdent opts@FileField{..} = do sessionFiles <- fmap fold . for mIdent $ \fieldIdent' -> fold . (HashMap.lookup fieldIdent' . unMergeHashMap =<<) <$> lookupSessionJson @_ @(MergeHashMap Text (Set SessionFileId)) @_ SessionFiles sessionFiles' <- flip foldMapM sessionFiles $ \sfId -> maybeT (return Map.empty) $ do SessionFile{..} <- MaybeT $ get sfId when (is _Just fieldRestrictExtensions) $ do (fTitle, isDirectory) <- MaybeT . fmap (getFirst . foldMap (First . Just . $(E.unValueN 2))) . E.select . E.from $ \file -> do E.where_ $ file E.^. FileId E.==. E.val sessionFileFile return $ (file E.^. FileTitle, E.isNothing $ file E.^. FileContent) guard $ isDirectory || permittedExtension opts (pack fTitle) return . Map.singleton sessionFileFile $ FileFieldUserOption False True $logDebugS "genericFileField.getPermittedFiles" $ "Additional: " <> tshow fieldAdditionalFiles $logDebugS "genericFileField.getPermittedFiles" $ "Session: " <> tshow sessionFiles' return $ fieldAdditionalFiles <> sessionFiles' handleUpload :: Maybe Text -> File -> DB (Maybe FileId) handleUpload mIdent file = do for mIdent $ \ident -> do now <- liftIO getCurrentTime oldSFIds <- fmap (Set.fromList . map E.unValue) . E.select . E.from $ \sessionFile -> do E.where_ $ E.subSelectForeign sessionFile SessionFileFile (E.^. FileTitle) E.==. E.val (fileTitle file) E.&&. sessionFile E.^. SessionFileTouched E.<=. E.val now return $ sessionFile E.^. SessionFileId fId <- insert file sfId <- insert $ SessionFile fId now modifySessionJson SessionFiles $ \(fromMaybe mempty -> MergeHashMap old) -> Just . MergeHashMap $ HashMap.insert ident (Set.insert sfId . maybe Set.empty (`Set.difference` oldSFIds) $ HashMap.lookup ident old) old return fId fieldEnctype = Multipart fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe FileUploads)) fieldParse vals files = do opts@FileField{..} <- liftHandler mkOpts mIdent <- fmap getFirst . flip foldMapM vals $ \v -> fmap First . runMaybeT . exceptTMaybe $ encodedSecretBoxOpen v let decrypt' :: CryptoUUIDFile -> Handler (Maybe FileId) decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt let uploadedFilenames = fileName <$> bool (take 1) id fieldMultiple files let doUnpack | fieldOptionForce fieldUnpackZips = fieldOptionDefault fieldUnpackZips | otherwise = unpackZips `elem` vals handleFile :: FileInfo -> ConduitT () File Handler () handleFile | doUnpack = sourceFiles | otherwise = yieldM . acceptFile if | invExt : _ <- filter (not . permittedExtension opts) uploadedFilenames -> do liftHandler . runDB . runConduit $ mapM_ (transPipe lift . handleFile) files .| C.mapM_ (void . handleUpload mIdent) return . Left . SomeMessage . MsgGenericFileFieldInvalidExtension $ unpack invExt | otherwise -> do let fSrc = do permittedFiles <- liftHandler . runDB $ getPermittedFiles mIdent opts yieldMany [ Left fId | (fId, FileFieldUserOption{..}) <- Map.toList permittedFiles , fieldOptionForce, fieldOptionDefault ] yieldMany vals .| C.mapMaybe fromPathPiece .| C.mapMaybeM (\enc -> fmap (, enc) <$> decrypt' enc) .| C.filter (\(fId, _) -> maybe False (not . fieldOptionForce) $ Map.lookup fId permittedFiles) .| C.filter (\(_, enc) -> fieldMultiple || ( (bool (\n h -> [n] == h) elem fieldMultiple) enc (mapMaybe fromPathPiece vals) && null files ) ) .| C.map (\(fId, _) -> Left fId) mapM_ handleFile (bool (take 1) id fieldMultiple files) .| C.map Right (unsealConduitT -> fSrc', length -> nFiles) <- liftHandler $ fSrc $$+ peekN 2 $logDebugS "genericFileField.fieldParse" $ tshow nFiles if | nFiles <= 0 -> return $ Right Nothing | nFiles <= 1 -> return . Right $ Just fSrc' | not fieldMultiple -> do liftHandler . runDB . runConduit $ mapM_ (transPipe lift . handleFile) files .| C.mapM_ (void . handleUpload mIdent) return . Left $ SomeMessage MsgOnlyUploadOneFile | otherwise -> return . Right $ 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 . runDB $ do (uploads, references) <- runWriterT . for val $ \src -> do fmap Set.fromList . sourceToList $ transPipe (lift . lift) src .| C.mapMaybeM (either (\fId -> Nothing <$ tell (Set.singleton fId)) $ lift . handleUpload mIdent) permittedFiles <- getPermittedFiles mIdent opts let sentVals :: Either Text (Set FileId) sentVals = uploads <&> Set.union (references `Set.intersection` Map.keysSet permittedFiles) let toFUI (E.Value fuiId', E.Value fuiTitle) = do fuiId <- encrypt fuiId' let fuiHtmlId = [st|#{fieldId}--#{toPathPiece fuiId}|] fuiChecked | Right sentVals' <- sentVals = fuiId' `Set.member` sentVals' | Just FileFieldUserOption{..} <- Map.lookup fuiId' fieldAdditionalFiles = fieldOptionDefault | otherwise = False fuiSession = fuiId' `Map.notMember` fieldAdditionalFiles fuiForced | Just FileFieldUserOption{..} <- Map.lookup fuiId' permittedFiles = fieldOptionForce | otherwise = False return FileUploadInfo{..} fileInfos' <- mapM toFUI <=< E.select . E.from $ \file -> do E.where_ $ file E.^. FileId `E.in_` E.valList (Set.toList $ fold sentVals <> Map.keysSet permittedFiles) E.orderBy [E.asc $ file E.^. FileTitle] return (file E.^. FileId, file E.^. FileTitle) 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 = Map.empty } fileField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m FileUploads fileField = genericFileField $ return FileField { fieldIdent = Nothing , fieldUnpackZips = FileFieldUserOption True False , fieldMultiple = False , fieldRestrictExtensions = Nothing , fieldAdditionalFiles = Map.empty } 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 = Map.empty } where fixupFileTitles = flip (.|) . C.mapM $ either (fmap Left . updateFileReference) (fmap Right . updateFile) where updateFileReference fId = runDB . maybeT (return fId) $ do oldTitle <- MaybeT . fmap (getFirst . foldMap (First . Just)) . E.select . E.from $ \file -> do E.where_ $ file E.^. FileId E.==. E.val fId return $ file E.^. FileTitle if | oldTitle == E.Value (unpack specificFileName) -> return fId | otherwise -> lift $ do fId' <- insert $ File (unpack specificFileName) Nothing (toMidnight systemEpochDay) {- temporary -} E.update $ \file' -> do let newModified = E.subSelect . E.from $ \file -> do E.where_ $ file E.^. FileId E.==. E.val fId return $ file E.^. FileModified newContent = E.subSelect . E.from $ \file -> do E.where_ $ file E.^. FileId E.==. E.val fId return $ file E.^. FileContent E.set file' [ FileModified E.=. E.maybe (E.val $ toMidnight systemEpochDay) id newModified, FileContent E.=. E.joinV newContent ] return fId' updateFile = return . set _fileTitle (unpack specificFileName) zipFileField :: Bool -- ^ Unpack zips? -> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions -> Field Handler FileUploads zipFileField doUnpack permittedExtensions = genericFileField $ return FileField { fieldIdent = Nothing , fieldUnpackZips = FileFieldUserOption True doUnpack , fieldMultiple = doUnpack , fieldRestrictExtensions = permittedExtensions , fieldAdditionalFiles = Map.empty } fileUploadForm :: Bool -- ^ Required? -> (Bool -> FieldSettings UniWorX) -- ^ given @unpackZips@ generate `FieldSettings` in the case of `UploadAny` -> UploadMode -> AForm Handler (Maybe FileUploads) fileUploadForm isReq mkFs = \case NoUpload -> pure Nothing UploadAny{..} -> bool aopt (\f fs _ -> Just <$> areq f fs Nothing) isReq (zipFileField unpackZips extensionRestriction) (mkFs unpackZips) Nothing UploadSpecific{..} -> mergeFileSources <$> sequenceA (map specificFileForm . Set.toList $ toNullable specificFiles) 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 (specificFileField spec) (fsl specificFileLabel) Nothing 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.mapMaybe (preview _Left) .| C.foldMap Set.singleton multiFileField :: Handler (Set FileId) -- ^ 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 = Map.fromSet (const $ FileFieldUserOption False True) permitted } data SheetGrading' = Points' | PassPoints' | PassBinary' deriving (Eq, Ord, Read, Show, Enum, Bounded) instance Universe SheetGrading' instance Finite SheetGrading' nullaryPathPiece ''SheetGrading' (camelToPathPiece . dropSuffix "'") embedRenderMessage ''UniWorX ''SheetGrading' ("SheetGrading" <>) data SheetType' = Normal' | Bonus' | Informational' | NotGraded' deriving (Eq, Ord, Read, Show, Enum, Bounded) instance Universe SheetType' instance Finite SheetType' nullaryPathPiece ''SheetType' (camelToPathPiece . dropSuffix "'") embedRenderMessage ''UniWorX ''SheetType' ("SheetType" <>) 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) ] classify' :: SheetGrading -> SheetGrading' classify' = \case Points {} -> Points' PassPoints {} -> PassPoints' PassBinary {} -> PassBinary' maxPointsReq = apreq pointsField (fslI MsgSheetGradingMaxPoints) (template >>= preview _maxPoints) passPointsReq = apreq pointsField (fslI MsgSheetGradingPassingPoints) (template >>= preview _passingPoints) sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType sheetTypeAFormReq fs template = explainedMultiActionA acts opts fs (classify' <$> template) where acts = Map.fromList [ ( Normal', Normal <$> gradingReq ) , ( Bonus' , Bonus <$> gradingReq ) , ( Informational', Informational <$> gradingReq ) , ( NotGraded', pure NotGraded ) ] gradingReq = sheetGradingAFormReq (fslI MsgSheetGrading & setTooltip MsgSheetGradingInfo) (template >>= preview _grading) opts = explainOptionList optionsFinite $ \case Normal' -> return $ i18n MsgSheetTypeInfoNormalLecturer Bonus' -> return $ i18n MsgSheetTypeInfoBonus Informational' -> return $ i18n MsgSheetTypeInfoInformational NotGraded' -> return $ i18n MsgSheetTypeInfoNotGraded classify' :: SheetType -> SheetType' classify' = \case Bonus {} -> Bonus' Normal {} -> Normal' Informational {} -> Informational' NotGraded -> NotGraded' 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 UniWorXMessage LocalTime readTime t = case parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of Just lTime -> Right lTime Nothing -> Left 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 where langCheck (T.splitOn "-" -> lParts) = all ((&&) <$> not . null <*> T.all Char.isAlpha) lParts && not (null lParts) langField True = selectField appLanguagesOpts jsonField :: ( ToJSON a, FromJSON a , MonadHandler m , RenderMessage (HandlerSite m) UniWorXMessage , RenderMessage (HandlerSite m) FormMessage ) => Bool {-^ Hidden? -} -> Field m a jsonField hide = Field{..} where inputType :: Text inputType | hide = "hidden" | otherwise = "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 = liftWidget [whamlet| |] fieldEnctype = UrlEncoded boolField :: ( MonadHandler m , HandlerSite m ~ UniWorX ) => Maybe (SomeMessage UniWorX) -> Field m Bool boolField mkNone = radioGroupField mkNone $ do mr <- getMessageRender return OptionList { olOptions = [ Option (mr MsgBoolNo ) False "no" , Option (mr MsgBoolYes) True "yes" ] , olReadExternal = \case "yes" -> Just True "on" -> Just True "no" -> Just False "true" -> Just True "false" -> Just False _other -> Nothing } sectionedFuncForm :: forall k v m sec. ( Finite k, Ord k , MonadHandler m , HandlerSite m ~ UniWorX , RenderMessage UniWorX sec , Ord sec ) => (k -> Maybe sec) -> (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v) sectionedFuncForm mkSection mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAForm $ funcFieldView =<< renderAForm FormStandard funcForm' mempty where funcForm' :: AForm m (k -> v) funcForm' = Set.fromList universeF & foldr (\v -> Map.unionWith Set.union $ Map.singleton (mkSection v) (Set.singleton v)) Map.empty & fmap (Map.fromSet mkForm) & fmap sequenceA & Map.foldrWithKey accSections (pure Map.empty) & fmap (!) accSections mSection optsForm acc = wFormToAForm $ do (res, fs) <- wFormFields $ aFormToWForm optsForm if | not $ null fs , Just section <- mSection -> wformSection section | otherwise -> return () lift $ tell fs aFormToWForm $ Map.union <$> wFormToAForm (pure res) <*> acc funcFieldView :: (FormResult (k -> v), Widget) -> MForm m (FormResult (k -> v), [FieldView UniWorX]) funcFieldView (res, formView) = do mr <- getMessageRender fvId <- maybe newIdent return fsId let fvLabel = toHtml $ mr fsLabel fvTooltip = fmap (toHtml . mr) fsTooltip fvRequired = isRequired fvErrors | FormFailure (err:_) <- res = Just $ toHtml err | otherwise = Nothing fvInput = $(widgetFile "widgets/fields/funcField") return (res, pure FieldView{..}) -- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template) funcForm :: forall k v m. ( Finite k, Ord k , MonadHandler m , HandlerSite m ~ UniWorX ) => (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v) funcForm = sectionedFuncForm $ const (Nothing :: Maybe Text) fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -- DEPRECATED fsm = bfs -- TODO: get rid of Bootstrap fsb :: Text -> FieldSettings site -- DEPRECATED fsb = bfs -- Just to avoid annoying Ambiguous Type Errors fsUniq :: (Text -> Text) -> Text -> FieldSettings site fsUniq mkUnique seed = "" { fsName = Just $ mkUnique seed } optionsPersistCryptoId :: forall site backend a msg. ( YesodPersist site , PersistQueryRead backend , HasCryptoUUID (Key a) (HandlerFor site) , KnownSymbol (CryptoIDNamespace UUID (Key a)) , RenderMessage site msg , YesodPersistBackend site ~ backend , PersistRecordBackend a backend , PathPiece (Key a) ) => [Filter a] -> [SelectOpt a] -> (a -> msg) -> HandlerFor site (OptionList (Entity a)) optionsPersistCryptoId filts ords toDisplay = do ents <- runDB $ selectList filts ords optionsCryptoIdF ents (return . entityKey) (return . toDisplay . entityVal) optionsCryptoIdE :: forall site backend a msg. ( YesodPersist site , PersistQueryRead backend, PersistUniqueRead backend , HasCryptoUUID (Key a) (HandlerFor site) , KnownSymbol (CryptoIDNamespace UUID (Key a)) , RenderMessage site msg , YesodPersistBackend site ~ backend , PersistRecordBackend a backend , BackendCompatible SqlBackend backend , PathPiece (Key a) ) => E.SqlQuery (E.SqlExpr (Entity a)) -> (a -> msg) -> HandlerFor site (OptionList (Entity a)) optionsCryptoIdE query toDisplay = do ents <- runDB $ E.select query optionsCryptoIdF ents (return . entityKey) (return . toDisplay . entityVal) optionsCryptoIdF :: forall m mono k msg. ( HasCryptoUUID k m , KnownSymbol (CryptoIDNamespace UUID k) , RenderMessage (HandlerSite m) msg , MonoFoldable mono , MonadHandler m , PathPiece k ) => mono -> (Element mono -> m k) -> (Element mono -> m msg) -> m (OptionList (Element mono)) optionsCryptoIdF (otoList -> iVals) toExtVal toMsg = fmap mkOptionList . forM iVals $ \optionInternalValue -> do cID <- encrypt =<< toExtVal optionInternalValue optionDisplay <- getMessageRender <*> toMsg optionInternalValue return Option { optionDisplay , optionExternalValue = toPathPiece (cID :: CryptoUUID k) , optionInternalValue } examOccurrenceField :: ( MonadHandler m , HandlerSite m ~ UniWorX ) => ExamId -> Field m ExamOccurrenceId examOccurrenceField eid = hoistField liftHandler . selectField . (fmap $ fmap entityKey) $ optionsPersistCryptoId [ ExamOccurrenceExam ==. eid ] [ Asc ExamOccurrenceName ] examOccurrenceName 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 FormMissing -> mzero FormFailure errs -> mapM_ (addMessage Error . toHtml) errs >> mzero FormSuccess val -> lift . execWriterT $ handler val isModal <- hasCustomHeader HeaderIsModal if | isModal -> sendResponse $ toJSON messages | otherwise -> do forM_ messages $ \Message{..} -> addMessage messageStatus messageContent redirect finalDest userMatriculationField :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX ) => Field m [Entity User] userMatriculationField = Field{..} where fieldEnctype = UrlEncoded fieldView theId name attrs val isReq = do let val' = val <&> Text.intercalate ", " . mapMaybe (userMatrikelnummer . entityVal) [whamlet| $newline never |] fieldParse (all Text.null -> True) _ = return $ Right Nothing fieldParse ts _ = runExceptT . fmap Just $ do let ts' = concatMap (Text.splitOn ",") ts forM ts' $ \matr -> do dbRes <- liftHandler . runDB . E.select . E.from $ \user -> do E.where_ $ E.strip (user E.^. UserMatrikelnummer) `E.ciEq` E.just (E.val $ Text.strip matr) return user case dbRes of [user] -> return user [] -> throwE . SomeMessage $ MsgUserMatriculationNotFound matr _other -> throwE . SomeMessage $ MsgUserMatriculationAmbiguous matr multiUserField :: forall m. ( MonadHandler m , HandlerSite m ~ UniWorX ) => Bool -- ^ Only resolve suggested users? -> Maybe (E.SqlQuery (E.SqlExpr (Entity User))) -- ^ Suggested users -> Field m (Set (Either UserEmail UserId)) multiUserField onlySuggested suggestions = Field{..} where lookupExpr | onlySuggested = suggestions | otherwise = Just $ E.from return fieldEnctype = UrlEncoded fieldView theId name attrs val isReq = do val' <- case val of Left t -> return t Right vs -> Text.intercalate ", " . map CI.original <$> do let (emails, uids) = partitionEithers $ Set.toList vs rEmails <- case lookupExpr of Nothing -> return [] Just lookupExpr' -> fmap concat . forM uids $ \uid -> do dbRes <- liftHandler . runDB . E.select $ do user <- lookupExpr' E.where_ $ user E.^. UserId E.==. E.val uid return $ user E.^. UserEmail case dbRes of [E.Value email] -> return [email] _other -> return [] return $ emails ++ rEmails datalistId <- maybe (return $ error "Not to be used") (const newIdent) suggestions [whamlet| $newline never |] whenIsJust suggestions $ \suggestions' -> do suggestedEmails <- fmap (Map.assocs . Map.fromListWith min . map (over _2 E.unValue . over _1 E.unValue)) . liftHandler . runDB . E.select $ do user <- suggestions' return $ ( E.case_ [ E.when_ (unique UserDisplayEmail user) E.then_ (user E.^. UserDisplayEmail) , E.when_ (unique UserEmail user) E.then_ (user E.^. UserEmail) ] ( E.else_ $ user E.^. UserIdent) , user E.^. UserDisplayName ) [whamlet| $newline never $forall (email, dName) <- suggestedEmails