1144 lines
47 KiB
Haskell
1144 lines
47 KiB
Haskell
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.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 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 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
|
|
<a href=#{url'} class=#{unwords $ map toPathPiece cls} role=button>
|
|
^{lbl}
|
|
|]
|
|
|
|
--------------------------
|
|
-- Interactive fieldset --
|
|
--------------------------
|
|
|
|
optionalAction :: AForm Handler a
|
|
-> FieldSettings UniWorX
|
|
-> Maybe Bool
|
|
-> (Html -> MForm Handler (FormResult (Maybe a), [FieldView UniWorX]))
|
|
optionalAction justAct fs@FieldSettings{..} defActive csrf = do
|
|
(doRes, doView) <- mpopt 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 justAct fs defActive = formToAForm $ optionalAction justAct fs defActive mempty
|
|
|
|
optionalActionW :: AForm Handler a
|
|
-> FieldSettings UniWorX
|
|
-> Maybe Bool
|
|
-> WForm Handler (FormResult (Maybe a))
|
|
optionalActionW justAct fs defAction = aFormToWForm $ optionalActionA justAct fs defAction
|
|
|
|
|
|
multiAction :: forall action a.
|
|
( RenderMessage UniWorX action, PathPiece action, Ord action, Eq action )
|
|
=> Map action (AForm Handler 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 = 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 E.^. StudyFeaturesId, degree, field)
|
|
MsgRenderer mr <- getMsgRenderer
|
|
mkOptionList . nonEmptyOptions (mr MsgNoStudyField) <$> mapM (procOptions 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 :: (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 = "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
|
|
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)
|
|
)
|
|
]
|
|
|
|
data ExamBonusRule' = ExamNoBonus'
|
|
| 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
|
|
ExamNoBonus -> ExamNoBonus'
|
|
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
|
|
[ ( ExamNoBonus'
|
|
, pure ExamNoBonus
|
|
)
|
|
, ( ExamBonusPoints'
|
|
, ExamBonusPoints
|
|
<$> apreq (checkBool (> 0) MsgExamBonusMaxPointsNonPositive pointsField) (fslI MsgExamBonusMaxPoints) (preview _bonusMaxPoints =<< prev)
|
|
<*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamBonusOnlyPassed) (Just <$> preview _bonusOnlyPassed =<< prev))
|
|
)
|
|
]
|
|
|
|
data ExamOccurrenceRule' = ExamRoomManual'
|
|
| 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'
|
|
|
|
examOccurrenceRuleForm :: Maybe ExamOccurrenceRule -> AForm Handler ExamOccurrenceRule
|
|
examOccurrenceRuleForm = fmap reverseClassify . areq (selectField optionsFinite) (fslI MsgExamOccurrenceRule) . fmap classifyExamOccurrenceRule
|
|
where
|
|
reverseClassify = \case
|
|
ExamRoomManual' -> ExamRoomManual
|
|
ExamRoomSurname' -> ExamRoomSurname
|
|
ExamRoomMatriculation' -> ExamRoomMatriculation
|
|
ExamRoomRandom' -> ExamRoomRandom
|
|
|
|
data ExamGradingRule' = ExamGradingManual'
|
|
| 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
|
|
ExamGradingManual -> ExamGradingManual'
|
|
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
|
|
[ ( ExamGradingManual'
|
|
, pure ExamGradingManual
|
|
)
|
|
, ( 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 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 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 (Source Handler File))
|
|
fileUploadForm isReq mkFs = \case
|
|
NoUpload
|
|
-> pure Nothing
|
|
UploadAny{..}
|
|
-> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt isReq) (zipFileField unpackZips extensionRestriction) (mkFs unpackZips) Nothing
|
|
UploadSpecific{..}
|
|
-> mergeFileSources <$> sequenceA (map specificFileForm . Set.toList $ toNullable specificFiles)
|
|
where
|
|
specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe (Source Handler File))
|
|
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 (Source Handler File)] -> Maybe (Source Handler File)
|
|
mergeFileSources (catMaybes -> sources) = case sources of
|
|
[] -> Nothing
|
|
fs -> Just $ sequence_ fs
|
|
|
|
multiFileField' :: Source Handler (Either FileId File) -- ^ Permitted files in same format as produced by `multiFileField`
|
|
-> Field Handler (Source Handler (Either FileId File))
|
|
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 (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' = 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
|
|
<input id="#{theId}" name="#{name}" *{attrs} type="datetime-local" :isReq:required value="#{val'}">
|
|
|]
|
|
, 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 (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 [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 = liftWidgetT [whamlet|
|
|
<input id=#{theId} name=#{name} *{attrs} type=#{inputType} :isReq:required value=#{either fromStrict encodeToLazyText val}>
|
|
|]
|
|
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, 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)
|
|
|
|
|
|
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) (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
|
|
|
|
examOccurrenceField :: ( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> ExamId
|
|
-> Field m ExamOccurrenceId
|
|
examOccurrenceField eid
|
|
= hoistField liftHandlerT . 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
|
|
|
|
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
|
|
<input id="#{theId}" name="#{name}" *{attrs} type="email" multiple :isReq:required="" value="#{val'}" :isJust suggestions:list=#{datalistId}>
|
|
|]
|
|
|
|
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
|
|
<datalist id=#{datalistId}>
|
|
$forall email <- suggestedEmails
|
|
<option value=#{email}>
|
|
|]
|
|
fieldParse (all Text.null -> True) _ = return $ Right Nothing
|
|
fieldParse ts _ = runExceptT . fmap Just $ do
|
|
let ts' = concatMap (Text.splitOn ",") ts
|
|
emails <- forM ts' $ \t -> either (\errStr -> throwE . SomeMessage $ MsgInvalidEmail [st|#{t} (#{errStr})|]) (return . decodeUtf8 . Email.toByteString) $ Email.validate (encodeUtf8 t)
|
|
fmap Set.fromList . forM emails $ \(CI.mk -> email) -> case lookupExpr of
|
|
Nothing -> return $ Left email
|
|
Just lookupExpr' -> do
|
|
dbRes <- liftHandlerT . runDB . E.select $ do
|
|
user <- lookupExpr'
|
|
E.where_ $ user E.^. UserEmail E.==. E.val email
|
|
return $ user E.^. UserId
|
|
case dbRes of
|
|
[] -> return $ Left email
|
|
[E.Value uid] -> return $ Right uid
|
|
_other -> fail "Ambiguous e-mail addr"
|
|
|
|
examResultField :: forall m res.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, PathPiece res
|
|
)
|
|
=> Field m res -> Field m (ExamResult' res)
|
|
examResultField innerField = Field
|
|
{ fieldEnctype = UrlEncoded <> fieldEnctype innerField
|
|
, fieldParse = \ts fs -> if
|
|
| [t] <- ts
|
|
, Just res <- fromPathPiece t
|
|
, is _ExamNoShow res || is _ExamVoided res
|
|
-> return . Right $ Just res
|
|
| otherwise
|
|
-> fmap (fmap ExamAttended) <$> fieldParse innerField (filter (not . (`elem` ["attended", "no-show", "voided"])) ts) fs
|
|
, fieldView = \theId name attrs val isReq -> do
|
|
innerId <- newIdent
|
|
let
|
|
val' :: ExamResult' (Either Text res)
|
|
val' = either (ExamAttended . Left) (fmap Right) val
|
|
innerVal :: Either Text res
|
|
innerVal = val >>= maybe (Left "") return . preview _ExamAttended
|
|
[whamlet|
|
|
$newline never
|
|
<div>
|
|
<select id=#{theId} name=#{name} *{attrs} :isReq:required style="display: inline-block">
|
|
<option value="attended" :is _ExamAttended val':selected>_{MsgExamResultAttended}
|
|
<option value="no-show" :is _ExamNoShow val':selected>_{MsgExamResultNoShow}
|
|
<option value="voided" :is _ExamVoided val':selected>_{MsgExamResultVoided}
|
|
<fieldset uw-interactive-fieldset .interactive-fieldset__target data-conditional-input=#{theId} data-conditional-value="attended" style="display: inline-block">
|
|
^{fieldView innerField innerId name attrs innerVal False}
|
|
|]
|
|
}
|
|
|
|
examGradeField :: forall m.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> Field m ExamGrade
|
|
examGradeField = hoistField liftHandlerT $ selectField optionsFinite
|
|
|
|
examPassedField :: forall m.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> Field m ExamPassed
|
|
examPassedField = hoistField liftHandlerT $ selectField optionsFinite
|