module Handler.Utils.Form ( module Handler.Utils.Form , module Handler.Utils.Form.MassInput , module Utils.Form , MonadWriter(..) ) where import Utils.Form import Handler.Utils.Form.Types import Handler.Utils.DateTime 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 Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map, (!)) import qualified Data.Map as Map import Control.Monad.Trans.Writer (execWriterT, WriterT) import Control.Monad.Trans.Except (throwE, runExceptT) import Control.Monad.Writer.Class import Control.Monad.Error.Class (MonadError(..)) import Data.Either (partitionEithers) import Data.Aeson (eitherDecodeStrict') import Data.Aeson.Text (encodeToLazyText) import qualified Text.Email.Validate as Email import Yesod.Core.Types (FileInfo(..)) import System.FilePath (isExtensionOf) import Data.Text.Lens (unpacked) import Data.Char (isDigit) import Text.Blaze (toMarkup) import Handler.Utils.Form.MassInput ---------------------------- -- 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 acts fs@FieldSettings{..} defAction csrf = do (actionRes, actionView) <- mreq (selectField . optionsF $ Map.keysSet acts) fs defAction results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts let actionResults = view _1 <$> results actionViews = Map.foldrWithKey accViews [] results accViews :: forall b. action -> (b, [FieldView UniWorX]) -> [FieldView UniWorX] -> [FieldView UniWorX] accViews act = flip mappend . over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/multi-action")) . snd return ((actionResults Map.!) =<< actionRes, over _fvInput (mappend $ toWidget csrf) actionView : actionViews) 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 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 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 ------------ -- 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| ^{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 -- | Variant that simply removes leading and trailing white space htmlField' :: Field Handler Html htmlField' = htmlField { fieldParse = \vs fis -> fieldParse htmlField (map Text.strip vs) fis } 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 natField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i natField d = convertField fromInteger toInteger $ checkBool (>= 0) (T.append d " muss eine natürliche Zahl sein.") $ intMinField 0 natIntField ::(Monad m, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m Integer natIntField = natField posIntField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i posIntField d = convertField fromInteger toInteger $ checkBool (> 0) (T.append d " muss eine positive Zahl sein.") $ intMinField 1 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' minIntField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Text -> Field m i minIntField m d = checkBool (> m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) $ 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 -- | 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 & setTooltip MsgMassInputTip) 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 = 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 = multiActionA actions (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) ) ] 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' = 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 ExamRoomSurname -> ExamRoomSurname' ExamRoomMatriculation -> ExamRoomMatriculation' ExamRoomRandom -> ExamRoomRandom' examOccurrenceRuleForm :: Maybe ExamOccurrenceRule -> AForm Handler ExamOccurrenceRule examOccurrenceRuleForm = fmap reverseClassify . areq (selectField optionsFinite) (fslI MsgExamOccurrenceRule) . fmap classifyExamOccurrenceRule where reverseClassify = \case 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) specificFileField :: UploadSpecificFile -> Field Handler (ConduitT () File Handler ()) specificFileField UploadSpecificFile{..} = Field{..} where fieldEnctype = Multipart fieldParse _ files | [f] <- files = return . Right . Just $ yieldM (acceptFile f) .| modifyFileTitle (const $ unpack specificFileName) | null files = return $ Right Nothing | otherwise = return . Left $ SomeMessage MsgOnlyUploadOneFile fieldView fieldId fieldName attrs _ req = $(widgetFile "widgets/specificFileField") extensions = fileNameExtensions specificFileName acceptRestricted = not $ null extensions accept = Text.intercalate "," . map ("." <>) $ extensions zipFileField :: Bool -- ^ Unpack zips? -> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions -> Field Handler (ConduitT () File Handler ()) zipFileField doUnpack permittedExtensions = Field{..} where fieldEnctype = Multipart fieldParse _ files | [f@FileInfo{..}] <- files , maybe True (anyOf (re _nullable . folded . unpacked) (`isExtensionOf` unpack fileName)) permittedExtensions || doUnpack = return . Right . Just $ bool (yieldM . acceptFile) sourceFiles doUnpack f | null files = return $ Right Nothing | otherwise = return . Left $ SomeMessage MsgOnlyUploadOneFile fieldView fieldId fieldName attrs _ req = $(widgetFile "widgets/zipFileField") zipExtensions = mimeExtensions typeZip acceptRestricted = isJust permittedExtensions accept = Text.intercalate "," . map ("." <>) $ bool [] (Set.toList zipExtensions) doUnpack ++ toListOf (_Just . re _nullable . folded) permittedExtensions fileUploadForm :: Bool -- ^ Required? -> (Bool -> FieldSettings UniWorX) -- ^ given @unpackZips@ generate `FieldSettings` in the case of `UploadAny` -> UploadMode -> AForm Handler (Maybe (ConduitT () File Handler ())) 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 (ConduitT () File Handler ())) 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 (ConduitT () File Handler ())] -> Maybe (ConduitT () File Handler ()) mergeFileSources (catMaybes -> sources) = case sources of [] -> Nothing fs -> Just $ sequence_ fs multiFileField' :: ConduitT () (Either FileId File) Handler () -- ^ Permitted files in same format as produced by `multiFileField` -> Field Handler (ConduitT () (Either FileId File) Handler ()) 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 (ConduitT () (Either FileId File) Handler ()) multiFileField permittedFiles' = Field{..} where fieldEnctype = Multipart fieldParse vals files = return . Right . Just $ do pVals <- lift permittedFiles' let decrypt' :: CryptoUUIDFile -> Handler (Maybe FileId) decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt yieldMany vals .| C.filter (/= unpackZips) .| C.map fromPathPiece .| C.catMaybes .| C.mapMaybeM decrypt' .| C.filter (`elem` pVals) .| C.map Left let handleFile :: FileInfo -> ConduitT () File Handler () handleFile | doUnpack = sourceFiles | otherwise = yieldM . acceptFile mapM_ handleFile files .| C.map Right where doUnpack = unpackZips `elem` vals fieldView fieldId fieldName _attrs val req = do pVals <- handlerToWidget permittedFiles' sentVals <- for val $ \src -> handlerToWidget . sourceToList $ src .| takeLefts let toFUI (E.Value fuiId', E.Value fuiTitle) = do fuiId <- encrypt fuiId' fuiHtmlId <- newIdent let fuiChecked | Right sentVals' <- sentVals = fuiId' `elem` sentVals' | otherwise = True return FileUploadInfo{..} autoUnzipInfo = [whamlet| _{MsgAutoUnzipInfo} |] fileInfos <- mapM toFUI <=< handlerToWidget . runDB . E.select . E.from $ \file -> do E.where_ $ file E.^. FileId `E.in_` E.valList (setToList pVals) E.orderBy [E.asc $ file E.^. FileTitle] return (file E.^. FileId, file E.^. FileTitle) $(widgetFile "widgets/multiFileField") unpackZips :: Text unpackZips = "unpack-zip" takeLefts :: Monad m => ConduitM (Either b a) b m () takeLefts = awaitForever $ \case Right _ -> return () Left r -> yield r 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' = NoGroups' | Arbitrary' | RegisteredGroups' 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 = multiActionA selOptions fs (classify' <$> template) where selOptions = Map.fromList [ ( Normal', Normal <$> gradingReq ) , ( Bonus' , Bonus <$> gradingReq ) , ( Informational', Informational <$> gradingReq ) , ( NotGraded', pure NotGraded ) ] gradingReq = sheetGradingAFormReq (fslI MsgSheetGrading & setTooltip MsgSheetGradingInfo) (template >>= preview _grading) classify' :: SheetType -> SheetType' classify' = \case Bonus {} -> Bonus' Normal {} -> Normal' Informational {} -> Informational' NotGraded -> NotGraded' sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup sheetGroupAFormReq fs template = multiActionA selOptions fs (classify' <$> template) where selOptions = Map.fromList [ ( Arbitrary', Arbitrary <$> apreq (natField "Gruppengröße") (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template) ) , ( RegisteredGroups', pure RegisteredGroups ) , ( NoGroups', pure NoGroups ) ] 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) -} 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 fieldTimeFormat :: String --fieldTimeFormat = "%e.%m.%y %k:%M" fieldTimeFormat = "%Y-%m-%dT%H:%M:%S" -- `defaultTimeLocale` is okay here, since `fieldTimeFormat` does not contain any 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 ) => Field m Bool boolField = Field { fieldParse = \e _ -> return $ boolParser e , fieldView = \theId name attrs val isReq -> $(widgetFile "widgets/fields/bool") , fieldEnctype = UrlEncoded } where boolParser [] = Right Nothing boolParser (x:_) = case x of "" -> Right Nothing "none" -> Right Nothing "yes" -> Right $ Just True "on" -> Right $ Just True "no" -> Right $ Just False "true" -> Right $ Just True "false" -> Right $ Just False t -> Left $ SomeMessage $ MsgInvalidBool t showVal = either $ const False 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) , RenderMessage site msg , YesodPersistBackend site ~ backend , PersistRecordBackend a backend ) => [Filter a] -> [SelectOpt a] -> (a -> msg) -> HandlerFor site (OptionList (Entity a)) optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do mr <- getMessageRender pairs <- runDB $ selectList filts ords cPairs <- forM pairs $ \e@(Entity key _) -> (,) <$> encrypt key <*> pure e return $ map (\(cId, e@(Entity _key value)) -> Option { optionDisplay = mr (toDisplay value) , optionInternalValue = e , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a)) }) cPairs 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 (Set.fromList . map E.unValue) . liftHandler . runDB . E.select $ do user <- suggestions' return $ user E.^. UserEmail [whamlet| $newline never $forall email <- suggestedEmails