fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Dispatch async-massinput by custom ident

Browse Source
This commit is contained in:
Gregor Kleen 2019-05-05 15:21:47 +02:00
parent ab2b187b63
commit aa36bd88b7
10 changed files with 36 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Handler/Admin.hs
View File

@ -205,7 +205,7 @@ postAdminTestR = do
-- The actual call to @massInput@ is comparatively simple:
((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd (\_ _ _ -> Set.empty) buttonAction defaultMiLayout) "" True Nothing
((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd (\_ _ _ -> Set.empty) buttonAction defaultMiLayout ("massinput" :: Text)) "" True Nothing
let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]

3
src/Handler/Course.hs
View File

@ -763,6 +763,9 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
-> Widget
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout")
miIdent :: Text
miIdent = "lecturers"
lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) (map liftEither . Map.elems) $ massInput

3
src/Handler/Sheet.hs
View File

@ -730,6 +730,9 @@ correctorForm shid = wFormToAForm $ do
-> Widget
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "sheetCorrectors/layout")
miIdent :: Text
miIdent = "correctors"
postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Set (Either SheetCorrectorInvitation SheetCorrector)
postProcess = Set.fromList . map postProcess' . Map.elems
where

2
src/Handler/Term.hs
View File

@ -256,7 +256,7 @@ newTermForm template html = do
= aforced termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) tid
| otherwise
= areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) Nothing
holidayForm = formToAForm . over (mapped._2) pure $ massInputList dayField (const $ "" & addPlaceholder (mr MsgTermHolidayPlaceholder)) (const Nothing) (fslI MsgTermHolidays & setTooltip MsgMassInputTip) True (tftHolidays template) mempty
holidayForm = formToAForm . over (mapped._2) pure $ massInputList dayField (const $ "" & addPlaceholder (mr MsgTermHolidayPlaceholder)) (const Nothing) ("holidays" :: Text) (fslI MsgTermHolidays & setTooltip MsgMassInputTip) True (tftHolidays template) mempty
(result, widget) <- flip (renderAForm FormStandard) html $ Term
<$> tidForm
<*> areq dayField (fslI MsgTermStartDay & setTooltip MsgTermStartDayTooltip) (tftStart template)

4
src/Handler/Tutorial.hs
View File

@ -213,7 +213,7 @@ tutorialForm cid template html = do
uid <- liftHandlerT requireAuthId
let
tutorForm = Set.fromList <$> massInputAccumA miAdd' miCell' (\p -> Just . SomeRoute $ cRoute :#: p) miLayout' (fslI MsgTutorialTutors & setTooltip MsgMassInputTip) True (Set.toList . tfTutors <$> template)
tutorForm = Set.fromList <$> massInputAccumA miAdd' miCell' (\p -> Just . SomeRoute $ cRoute :#: p) miLayout' ("tutors" :: Text) (fslI MsgTutorialTutors & setTooltip MsgMassInputTip) True (Set.toList . tfTutors <$> template)
where
miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([UserId] -> FormResult [UserId])
miAdd' nudge submitView csrf = do
@ -245,7 +245,7 @@ tutorialForm cid template html = do
<*> areq (ciField & addDatalist tutTypeDatalist) (fslpI MsgTutorialType $ mr MsgTutorialType) (tfType <$> template)
<*> aopt (natFieldI MsgTutorialCapacityNonPositive) (fslpI MsgTutorialCapacity (mr MsgTutorialCapacity) & setTooltip MsgTutorialCapacityTip) (tfCapacity <$> template)
<*> areq textField (fslpI MsgTutorialRoom $ mr MsgTutorialRoomPlaceholder) (tfRoom <$> template)
<*> occurencesAForm (tfTime <$> template)
<*> occurencesAForm ("occurences" :: Text) (tfTime <$> template)
<*> fmap (assertM (not . Text.null . CI.original) . fmap (CI.map Text.strip)) (aopt ciField (fslI MsgTutorialRegGroup & setTooltip MsgTutorialRegGroupTip) ((tfRegGroup <$> template) <|> Just (Just "tutorial")))
<*> aopt utcTimeField (fslpI MsgRegisterFrom (mr MsgDate)
& setTooltip MsgCourseRegisterFromTip

2
src/Handler/Utils/Communication.hs
View File

@ -165,6 +165,8 @@ commR CommunicationRoute{..} = do
miDelete :: MapLiveliness (EnumLiveliness RecipientCategory) ListLength -> (EnumPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (EnumPosition RecipientCategory, ListPosition) (EnumPosition RecipientCategory, ListPosition))
-- miDelete liveliness@(MapLiveliness lMap) (EnumPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(EnumPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (EnumPosition RecipientCustom, ) . Map.mapKeysMonotonic (EnumPosition RecipientCustom, ) <$> miDeleteList (lMap ! EnumPosition RecipientCustom) delPos
miDelete _ _ = mzero
miIdent :: Text
miIdent = "recipients"
postProcess :: Map (EnumPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId)
postProcess = Set.fromList . map fst . filter snd . Map.elems

28
src/Handler/Utils/Form/MassInput.hs
View File

@ -234,7 +234,7 @@ data MassInputException = MassInputInvalidShape
instance Exception MassInputException
data MassInput handler liveliness cellData cellResult = MassInput
data MassInput handler liveliness cellData cellResult = forall i. PathPiece i => MassInput
{ miAdd :: BoxCoord liveliness -- Position (dimensions after @dimIx@ are zero)
-> Natural -- Zero-based dimension index @dimIx@
-> (Text -> Text) -- Nudge deterministic field ids
@ -258,6 +258,7 @@ data MassInput handler liveliness cellData cellResult = MassInput
-> Set (BoxCoord liveliness) -- ^ Usually addition widgets are only provided for dimension 0 and all _lines_ that have at least one live coordinate. `miAddEmpty` allows specifying when to provide additional widgets
, miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) -- ^ Override form-tag route for `massInput`-Buttons to keep the user closer to the Widget, the `PathPiece` Argument is to be used for constructiong a `Fragment`
, miLayout :: MassInputLayout liveliness cellData cellResult
, miIdent :: i
}
type MassInputLayout liveliness cellData cellResult
@ -279,7 +280,7 @@ massInput :: forall handler cellData cellResult liveliness.
-> Bool -- ^ Required?
-> Maybe (Map (BoxCoord liveliness) (cellData, cellResult))
-> (Markup -> MForm handler (FormResult (Map (BoxCoord liveliness) (cellData, cellResult)), FieldView UniWorX))
massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvRequired initialResult csrf = do
let initialShape = fmap fst <$> initialResult
miName <- maybe newFormIdent return fsName
@ -415,7 +416,7 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
MsgRenderer mr <- getMsgRenderer
whenM ((== Just fvId) <$> lookupCustomHeader HeaderMassInputShortcircuit) . liftHandlerT $ do
whenM ((== Just miIdent) <$> lookupCustomHeader HeaderMassInputShortcircuit) . liftHandlerT $ do
PageContent{..} <- widgetToPageContent $(widgetFile "widgets/massinput/massinput-standalone")
ur <- getUrlRenderParams
@ -454,18 +455,20 @@ listMiLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/mas
-- | Wrapper around `massInput` for the common case, that we just want an arbitrary list of single fields without any constraints
massInputList :: forall handler cellResult.
massInputList :: forall handler cellResult ident.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, MonadLogger handler
, PathPiece ident
)
=> Field handler cellResult
-> (ListPosition -> FieldSettings UniWorX)
-> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
-> ident
-> FieldSettings UniWorX
-> Bool
-> Maybe [cellResult]
-> (Markup -> MForm handler (FormResult [cellResult], FieldView UniWorX))
massInputList field fieldSettings miButtonAction miSettings miRequired miPrevResult = over (mapped . _1 . mapped) (map snd . Map.elems) . massInput
massInputList field fieldSettings miButtonAction miIdent miSettings miRequired miPrevResult = over (mapped . _1 . mapped) (map snd . Map.elems) . massInput
MassInput { miAdd = \_ _ _ submitBtn -> Just $ \csrf ->
return (FormSuccess $ \pRes -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax pRes) (), toWidget csrf >> fvInput submitBtn)
, miCell = \pos () iRes nudge csrf ->
@ -475,26 +478,29 @@ massInputList field fieldSettings miButtonAction miSettings miRequired miPrevRes
, miAddEmpty = \_ _ _ -> Set.empty
, miButtonAction
, miLayout = listMiLayout
, miIdent
}
miSettings
miRequired
(Map.fromList . zip [0..] . map ((), ) <$> miPrevResult)
-- | Wrapper around `massInput` for the common case, that we just want a list of data with no option to modify it except deletion and addition
massInputAccum :: forall handler cellData.
massInputAccum :: forall handler cellData ident.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, MonadLogger handler
, ToJSON cellData, FromJSON cellData
, PathPiece ident
)
=> ((Text -> Text) -> FieldView UniWorX -> (Markup -> MForm handler (FormResult ([cellData] -> FormResult [cellData]), Widget)))
-> (cellData -> Widget)
-> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
-> MassInputLayout ListLength cellData ()
-> ident
-> FieldSettings UniWorX
-> Bool
-> Maybe [cellData]
-> (Markup -> MForm handler (FormResult [cellData], FieldView UniWorX))
massInputAccum miAdd' miCell' miButtonAction miLayout fSettings fRequired mPrev csrf
massInputAccum miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequired mPrev csrf
= over (_1 . mapped) (map fst . Map.elems) <$> massInput MassInput{..} fSettings fRequired (Map.fromList . zip [0..] . map (, ()) <$> mPrev) csrf
where
miAdd :: ListPosition -> Natural
@ -518,21 +524,23 @@ massInputAccum miAdd' miCell' miButtonAction miLayout fSettings fRequired mPrev
miAddEmpty _ _ _ = Set.empty
massInputAccumA :: forall handler cellData.
massInputAccumA :: forall handler cellData ident.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, MonadLogger handler
, ToJSON cellData, FromJSON cellData
, PathPiece ident
)
=> ((Text -> Text) -> FieldView UniWorX -> (Markup -> MForm handler (FormResult ([cellData] -> FormResult [cellData]), Widget)))
-> (cellData -> Widget)
-> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
-> MassInputLayout ListLength cellData ()
-> ident
-> FieldSettings UniWorX
-> Bool
-> Maybe [cellData]
-> AForm handler [cellData]
massInputAccumA miAdd' miCell' miButtonAction' miLayout' fSettings fRequired mPrev
= formToAForm $ over _2 pure <$> massInputAccum miAdd' miCell' miButtonAction' miLayout' fSettings fRequired mPrev mempty
massInputAccumA miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev
= formToAForm $ over _2 pure <$> massInputAccum miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev mempty
massInputA :: forall handler cellData cellResult liveliness.

6
src/Handler/Utils/Form/Occurences.hs
View File

@ -34,8 +34,8 @@ nullaryPathPiece ''OccurenceExceptionKind $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''OccurenceExceptionKind id
occurencesAForm :: Maybe Occurences -> AForm Handler Occurences
occurencesAForm mPrev = wFormToAForm $ do
occurencesAForm :: PathPiece ident => ident -> Maybe Occurences -> AForm Handler Occurences
occurencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do
Just cRoute <- getCurrentRoute
let
@ -45,6 +45,7 @@ occurencesAForm mPrev = wFormToAForm $ do
miCell'
(\p -> Just . SomeRoute $ cRoute :#: p)
miLayout'
(miIdent' <> "__scheduled" :: Text)
(fslI MsgScheduleRegular & setTooltip MsgMassInputTip)
False
(Set.toList . occurencesScheduled <$> mPrev)
@ -80,6 +81,7 @@ occurencesAForm mPrev = wFormToAForm $ do
miCell'
(\p -> Just . SomeRoute $ cRoute :#: p)
miLayout'
(miIdent' <> "__exceptions" :: Text)
(fslI MsgScheduleExceptions & setTooltip (UniWorXMessages [SomeMessage MsgScheduleExceptionsTip, SomeMessage MsgMassInputTip]))
False
(Set.toList . occurencesExceptions <$> mPrev)

2
static/js/utils/massInput.js
View File

@ -38,7 +38,7 @@
throw new Error('Mass Input utility cannot be setup without an element!');
}
massInputId = element.id;
massInputId = element.dataset.massInputIdent || '_';
massInputForm = element.closest('form');
if (!massInputForm) {

2
templates/widgets/massinput/massinput.hamlet
View File

@ -1,5 +1,5 @@
$newline never
<div .massinput uw-mass-input ##{fvId}>
<div .massinput uw-mass-input data-mass-input-ident=#{miIdent} ##{fvId}>
#{csrf}
^{shapeInput}
^{miWidget}