From bbeb0e70be2b3db7dea3b6f1f3886bc2c7fde5dd Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 19 Mar 2019 13:46:11 +0100 Subject: [PATCH] Identifiers for DBTable-Forms --- src/Handler/Corrections.hs | 1 + src/Handler/SystemMessage.hs | 1 + src/Handler/Utils/Table/Pagination.hs | 25 ++++++++++++++++++++++++- src/Utils/Form.hs | 17 +++++++++++------ 4 files changed, 37 insertions(+), 7 deletions(-) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 8f802798f..222052f85 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -353,6 +353,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) , dbParamsFormEvaluate = liftHandlerT . runFormPost , dbParamsFormResult = _1 + , dbParamsFormIdent = def } -- -- Similar Query for Statistics over alle possible Table elements (not just the ones shown) -- gradingSummary <- do diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index c219b394a..34ab467ac 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -215,6 +215,7 @@ postMessageListR = do return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) , dbParamsFormEvaluate = liftHandlerT . runFormPost , dbParamsFormResult = id + , dbParamsFormIdent = def } , dbtIdent = "messages" :: Text } diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index ca3408316..741117297 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -461,6 +461,19 @@ instance Monoid x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x instance Default (DBParams (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where def = DBParamsDB +data DBParamsFormIdent where + DBParamsFormTableIdent :: DBParamsFormIdent + DBParamsFormOverrideIdent :: forall t. PathPiece t => t -> DBParamsFormIdent + DBParamsFormNoIdent :: DBParamsFormIdent + +instance Default DBParamsFormIdent where + def = DBParamsFormTableIdent + +unDBParamsFormIdent :: DBTable m x -> DBParamsFormIdent -> Maybe Text +unDBParamsFormIdent DBTable{dbtIdent} DBParamsFormTableIdent = Just $ toPathPiece dbtIdent +unDBParamsFormIdent _ (DBParamsFormOverrideIdent x) = Just $ toPathPiece x +unDBParamsFormIdent _ DBParamsFormNoIdent = Nothing + instance Monoid x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x where data DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = forall a. DBParamsForm { dbParamsFormMethod :: StdMethod @@ -470,6 +483,7 @@ instance Monoid x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc , dbParamsFormAdditional :: Form a , dbParamsFormEvaluate :: forall m' a' x'. (MonadHandler m', HandlerSite m' ~ UniWorX, MonadResource m') => (Html -> MForm (HandlerT UniWorX IO) (FormResult a', x')) -> m' ((FormResult a', x'), Enctype) , dbParamsFormResult :: Lens' x (FormResult a) + , dbParamsFormIdent :: DBParamsFormIdent } type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = (x, Widget) -- type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = (FormResult a, Enctype) @@ -492,7 +506,15 @@ instance Monoid x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc dbWidget _ _ = return . snd dbHandler _ _ f = return . over _2 f -- runDBTable :: forall m' k'. (MonadHandler m', HandlerSite m' ~ UniWorX, ToJSON k') => DBTable (MForm (HandlerT UniWorX IO)) x -> PaginationInput -> [k'] -> (MForm (HandlerT UniWorX IO)) (x, Widget) -> ReaderT SqlBackend m' (x, Widget) - runDBTable dbtable@(DBTable{ dbtParams = dbtParams@DBParamsForm{..} }) pi pKeys = fmap ((\(res, (wdgt, x)) -> (x & dbParamsFormResult .~ res, wdgt)) . view _1) . dbParamsFormEvaluate . fmap (fmap $ \(x, wdgt) -> (x ^. dbParamsFormResult, (wdgt, x))) . dbParamsFormWrap dbtParams . addPIHiddenField dbtable pi . addPreviousHiddenField dbtable pKeys . withFragment + runDBTable dbtable@(DBTable{ dbtParams = dbtParams@DBParamsForm{..} }) pi pKeys + = fmap ((\(res, (wdgt, x)) -> (x & dbParamsFormResult .~ res, wdgt)) . view _1) + . dbParamsFormEvaluate + . fmap (fmap $ \(x, wdgt) -> (x ^. dbParamsFormResult, (wdgt, x))) + . dbParamsFormWrap dbtParams + . maybe id (identifyForm' dbParamsFormResult) (unDBParamsFormIdent dbtable dbParamsFormIdent) + . addPIHiddenField dbtable pi + . addPreviousHiddenField dbtable pKeys + . withFragment dbInvalidateResult DBParamsForm{..} reason result = do reasonTxt <- getMessageRender <*> pure reason @@ -510,6 +532,7 @@ instance Monoid x => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [La , dbParamsFormAdditional = \_ -> return (pure (), mempty) , dbParamsFormEvaluate = liftHandlerT . runFormPost , dbParamsFormResult = lens (\_ -> pure ()) (\s _ -> s) + , dbParamsFormIdent = def } dbParamsFormWrap :: Monoid x => DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget)) -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget)) diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 625d1c570..be58ce97b 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -213,6 +213,7 @@ data FormIdentifier | FIDSystemMessageAddTranslation | FIDDBTableFilter | FIDDBTablePagesize + | FIDDBTable | FIDDelete | FIDCourseRegister deriving (Eq, Ord, Read, Show) @@ -222,11 +223,12 @@ instance PathPiece FormIdentifier where toPathPiece = showToPathPiece -identifyForm :: (Monad m, PathPiece ident, Eq ident) - => ident -- ^ Form identification - -> (Html -> MForm m (FormResult a, widget)) - -> (Html -> MForm m (FormResult a, widget)) -identifyForm identVal form fragment = do +identifyForm' :: (Monad m, PathPiece ident, Eq ident) + => Lens' x (FormResult a) + -> ident -- ^ Form identification + -> (Html -> MForm m (x, widget)) + -> (Html -> MForm m (x, widget)) +identifyForm' resLens identVal form fragment = do -- Create hidden . let fragment' = [shamlet| @@ -243,7 +245,10 @@ identifyForm identVal form fragment = do -- doing this avoids having lots of fields with red errors. let eraseParams | not hasIdent = local (\(_, h, l) -> (Nothing, h, l)) | otherwise = id - fmap (over _1 $ bool (const FormMissing) id hasIdent) . eraseParams $ form fragment' + fmap (over (_1 . resLens) $ bool (const FormMissing) id hasIdent) . eraseParams $ form fragment' + +identifyForm :: (Monad m, PathPiece ident, Eq ident) => ident -> (Html -> MForm m (FormResult a, widget)) -> (Html -> MForm m (FormResult a, widget)) +identifyForm = identifyForm' id {- Hinweise zur Erinnerung: - identForm primär, wenn es mehr als ein Formular pro Handler gibt