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 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.Functions (parseHelper) import Yesod.Form.Bootstrap3 import Handler.Utils.Zip import qualified Data.Conduit.List as C import qualified Database.Esqueleto 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.Scientific (Scientific) import Text.Read (readMaybe) import Data.Either (partitionEithers) import Utils.Lens import Data.Aeson (eitherDecodeStrict') import Data.Aeson.Text (encodeToLazyText) import Data.Proxy import qualified Text.Email.Validate as Email import Yesod.Core.Types (FileInfo(..)) import System.FilePath (isExtensionOf) import Data.Text.Lens (unpacked) 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 -- -------------------------- multiAction :: forall action a. ( RenderMessage UniWorX action, PathPiece action, Ord action, Eq action ) => Map action (AForm (HandlerT UniWorX IO) a) -> FieldSettings UniWorX -> Maybe action -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX])) multiAction acts fs@FieldSettings{..} defAction csrf = do mr <- getMessageRender let options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece (actionRes, actionView) <- mreq (selectField $ return options) 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, Eq action) => Map action (AForm (HandlerT UniWorX IO) 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, Eq 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, Eq action) => Map action (AForm (HandlerT UniWorX IO) 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 (HandlerT UniWorX IO) 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 = checkBool (>= 0) msg intField natField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i natField d = checkBool (>= 0) (T.append d " muss eine natürliche Zahl sein.") intField 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 = checkBool (> 0) (T.append d " muss eine positive Zahl sein.") intField -- | 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."]) intField pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points --TODO allow fractions pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..} where fieldEnctype = UrlEncoded fieldView theId name attrs val isReq = [whamlet| $newline never |] fieldParse = parseHelper $ \t -> do sci <- maybe (Left $ MsgInvalidNumber t) Right (readMaybe $ unpack t :: Maybe Scientific) return . fromRational $ round (sci * 100) % 100 pointsFieldMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Field m Points --TODO allow fractions pointsFieldMax Nothing = pointsField pointsFieldMax (Just maxp) = checkBool (<= maxp) (MsgPointsTooHigh maxp) pointsField 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 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 courses, 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) studyFeaturesPrimaryFieldFor 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.||. isPrimaryActiveUserStudyFeature feature return (feature E.^. StudyFeaturesId, degree, field) MsgRenderer mr <- getMsgRenderer mkOptionList . nonEmptyOptions (mr MsgNoPrimaryStudyField) <$> mapM (procOptions mr) rawOptions where isPrimaryActiveUserStudyFeature feature = case mbuid of Nothing -> E.val False (Just uid) -> feature E.^. StudyFeaturesUser E.==. E.val uid E.&&. feature E.^. StudyFeaturesValid E.==. E.val True E.&&. feature E.^. StudyFeaturesType E.==. E.val FieldPrimary procOptions :: (StudyDegreeTerm -> Text) -> (E.Value StudyFeaturesId, Entity StudyDegree, Entity StudyTerms) -> Handler (Option (Maybe StudyFeaturesId)) procOptions mr (E.Value sfid, Entity _dgid sdegree, Entity _stid sterm) = do cfid <- encrypt sfid return Option { optionDisplay = 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 = "NoPrimaryStudyField" } 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 <$> apreq checkBoxField (fslI MsgUploadModeUnpackZips & setTooltip MsgUploadModeUnpackZipsTip) (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 Just currentRoute <- getCurrentRoute let miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction frag = Just . 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) ) ] pseudonymWordField :: Field Handler PseudonymWord pseudonymWordField = checkMMap doCheck CI.original $ textField & addDatalist (return $ map CI.original pseudonymWordlist) where doCheck (CI.mk -> w) | Just w' <- find (== w) pseudonymWordlist = return $ Right w' | otherwise = return . Left $ MsgUnknownPseudonymWord (CI.original w) specificFileField :: UploadSpecificFile -> Field Handler (Source Handler File) 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 (Source Handler File) 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 "application/zip" acceptRestricted = isJust permittedExtensions accept = Text.intercalate "," . map ("." <>) $ bool [] (Set.toList zipExtensions) doUnpack ++ toListOf (_Just . re _nullable . folded) permittedExtensions multiFileField :: Handler (Set FileId) -> Field Handler (Source Handler (Either FileId File)) 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 -> Source Handler File 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{..} 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' = NotGraded' | Normal' | Bonus' | Informational' 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" -- `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 (HandlerT UniWorX IO) Lang langField False = checkBool (all ((&&) <$> not . null <*> T.all Char.isAlpha) . T.splitOn "-") MsgInvalidLangFormat $ textField & addDatalist (return $ toList appLanguages) langField True = selectField . optionsPairs . map (MsgLanguage &&& id) $ toList appLanguages 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 [v] [] = return . bimap (SomeMessage . MsgJSONFieldDecodeFailure) Just . eitherDecodeStrict' $ encodeUtf8 v fieldParse [] [] = return $ Right Nothing fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired fieldView theId name attrs val isReq = liftWidgetT [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 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 mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAForm $ funcFieldView =<< renderAForm FormStandard funcForm' mempty where funcForm' :: AForm m (k -> v) funcForm' = fmap (!) . sequenceA . Map.fromSet mkForm $ Set.fromList universeF funcFieldView :: (FormResult (k -> v), Widget) -> MForm m (FormResult (k -> v), [FieldView UniWorX]) funcFieldView (res, fvInput) = do mr <- getMessageRender let fvLabel = toHtml $ mr fsLabel fvTooltip = fmap (toHtml . mr) fsTooltip fvRequired = isRequired fvErrors | FormFailure (err:_) <- res = Just $ toHtml err | otherwise = Nothing fvId <- maybe newIdent return fsId return (res, pure FieldView{..}) -- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template) 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) (HandlerT site IO) , RenderMessage site msg , YesodPersistBackend site ~ backend , PersistRecordBackend a backend ) => [Filter a] -> [SelectOpt a] -> (a -> msg) -> HandlerT site IO (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 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 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 <- liftHandlerT . 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) . liftHandlerT . runDB . E.select $ do user <- suggestions' return $ user E.^. UserEmail [whamlet| $newline never $forall email <- suggestedEmails