From a4862b692aa9ac7a10c4796ac11c1d5d1271dede Mon Sep 17 00:00:00 2001 From: SJost Date: Mon, 1 Oct 2018 09:10:37 +0200 Subject: [PATCH 1/6] Minor; fixes a warning --- src/Import/NoFoundation.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 19d0bb34d..8db4ec779 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} module Import.NoFoundation ( module Import - , addMessage, addMessageI ) where import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI) From a6afd02a158e54d4dde0892181ab7aa87f1a06d9 Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 11 Oct 2018 10:19:25 +0200 Subject: [PATCH 2/6] cannot remember --- messages/uniworx/de.msg | 1 + src/Handler/Profile.hs | 50 +++++++++++++++++++++++++++++---------- src/Handler/Utils/Form.hs | 5 +++- src/Utils/Form.hs | 2 +- 4 files changed, 44 insertions(+), 14 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index c1b8fcca7..1bd1ddd42 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -5,6 +5,7 @@ BtnRegister: Anmelden BtnDeregister: Abmelden BtnHijack: Sitzung übernehmen +Aborted: Abgebrochen Registered: Angemeldet RegisterFrom: Anmeldungen von RegisterTo: Anmeldungen bis diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 29918fe82..1eec221fe 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -142,14 +142,23 @@ postProfileR = do postProfileDataR :: Handler Html postProfileDataR = do - (uid, User{..}) <- requireAuthPair ((btnResult,_), _) <- runFormPost $ buttonForm case btnResult of - (FormSuccess BtnDelete) -> addMessage Warning "Delete-Knopf gedrückt" - (FormSuccess BtnAbort ) -> addMessage Warning "Knopf Abort erkannt" - _other -> addMessage Warning "KEIN Knopf erkannt" - addMessage Error "Löschen der Daten wurde noch nicht implementiert." - getProfileDataR + (FormSuccess BtnDelete) -> do + (uid, User{..}) <- requireAuthPair + addMessage Warning "Delete-Knopf gedrückt" + addMessage Error "Löschen der Daten wurde noch nicht implementiert." + -- first determine all submission that solely depend on this user: + -- SubmissionGroup / SubmissionGroupUser + -- Submission / SubmissionUser + + -- runDB $ deleteCascade uid + (FormSuccess BtnAbort ) -> do + addMessageI Info MsgAborted + getProfileDataR + _other -> do + getProfileDataR + getProfileDataR :: Handler Html getProfileDataR = do @@ -176,13 +185,30 @@ getProfileDataR = do -- TODO: move this into a Message and/or Widget-File let delWdgt = [whamlet|
-
Sind Sie sich absolut sicher, alle gespeicherten Daten zu löschen? - Abgegebene Hausaufgaben werden dadurch rückwirkend gelöscht, - wodurch eventuell ein Klausurbonus nicht mehr anerkannt wird.
- Gilt nicht in der Testphase von Uni2work: - Klausurnoten können Sie hiermit nicht löschen. - Da diese 5 Jahre bis nach Ihrer Exmatrikulation aufbewahrt werden müssen. + Während der Testphase von Uni2work können Sie hiermit + Ihren Account bei Uni2work vollständig löschen. + Mit Ihrem Campus-Account können Sie sich aber danach + jederzeit erneut einloggen, wodurch wieder ein leerer Account erstellt wird. +
+ Hochgeladene Hausaufgaben-Dateien werden unabhhängig vom Urherber nur dann gelöscht, + wenn die Dateien ausschließlich Ihnen zugeordnet sind. + Dateien aus Gruppenabgaben werden also erst dann gelöscht, + wenn alle Gruppenmitglieder Ihren Account gelöscht haben. +
+ Achtung: + Auch abgegebene Hausübungen werden gelöscht! + Falls ein Veranstalter Informationen darüber nicht anderweitig gespeichert hat, + kann dadurch ein etwaiger Hausaufgabenbonus verloren gehen. + (Verbuchte Noten sollten dadurch nicht betroffen sein, aber in einem etwaigen + Streitfall konnen die per Uni2work verwalteten Hausaufgaben dann + auch nicht mehr rekonstruiert/berücksichtigt werden.) +
+ Nach der Testphase von Uni2work wird das Löschen eines Accounts etwas + eingeschränkt werden, da z.B. Klausurnoten 5 Jahre bis nach Exmatrikulation + aufbewahrt werden müssen. +
+ Sind Sie sich absolut sicher, alle Ihre in Uni2work gespeicherten Daten zu löschen?
^{btnWdgt} |] defaultLayout $ do diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 6236c1194..3bff46100 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -153,7 +153,7 @@ combinedButtonField btns inner csrf = do -} -- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ())) -buttonForm :: (Button UniWorX a) => Form a +buttonForm :: (Button UniWorX a, Show a) => Form a buttonForm csrf = do buttonIdent <- newFormIdent let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing @@ -164,12 +164,15 @@ buttonForm csrf = do $forall bView <- btnViews ^{fvInput bView} |] + $logDebugS "FormResult" $ tshow results return (accResult results,widget) where accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a accResult = Foldable.foldr accResult' FormMissing accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a + -- TODO: Does not work for Forms with more than 3 buttons, since all deliver FormFailure except for one! + -- TODO: Maybe change buttonField? accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"] accResult' (FormSuccess (Just x)) _ = FormSuccess x accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Shouldn't Failure override Success? diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 939169e9b..9a96781ef 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -195,7 +195,7 @@ buttonField btn = Field {fieldParse, fieldView, fieldEnctype} fieldParse [] _ = return $ Right Nothing fieldParse [str] _ | str == toPathPiece btn = return $ Right $ Just btn - | otherwise = return $ Left "Wrong button value" + | otherwise = return $ Left "Wrong button value" -- SJ: Right Nothing?! fieldParse _ _ = return $ Left "Multiple button values" combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> AForm (HandlerT site IO) [Maybe a] From bef662d1629cbfcb472328f1c2e0028ab71248ca Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 11 Oct 2018 10:39:28 +0200 Subject: [PATCH 3/6] Fix build. --- src/Handler/Profile.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 867e69149..874971fec 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -151,13 +151,13 @@ postProfileDataR = do -- first determine all submission that solely depend on this user: -- SubmissionGroup / SubmissionGroupUser -- Submission / SubmissionUser - -- runDB $ deleteCascade uid (FormSuccess BtnAbort ) -> do addMessageI Info MsgAborted - getProfileDataR - _other -> do - getProfileDataR + redirect ProfileDataR + _other -> return () + getProfileDataR + getProfileDataR :: Handler Html From 39e96e6ccd32646525f698c15c169fca105ca9b1 Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 11 Oct 2018 11:14:56 +0200 Subject: [PATCH 4/6] Fixes #190 --- src/Handler/Course.hs | 17 +++++++++++------ src/Handler/Utils/Form.hs | 8 ++++++++ 2 files changed, 19 insertions(+), 6 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 5e09e2b7e..154c75d10 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -532,12 +532,17 @@ newCourseForm template = identForm FIDcourse $ \html -> do [ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] [] , map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. userId] [] ] - let termsField = case template of - --TODO: if Admin, then all - -- if allowed to delete course then allow current and all active term - -- otherwise only keep current term - (Just cform) | (Just _) <- cfCourseId cform -> termsSetField [cfTerm cform] - _allOtherCases -> termsActiveField + + termsField <- liftHandlerT $ case template of + -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin + (Just cform) | (Just cid) <- cfCourseId cform -> do -- edit existing course + _courseOld@Course{..} <- runDB $ get404 cid + mayEditTerm <- isAuthorized TermEditR True + mayDelete <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True + return $ if + | (mayEditTerm == Authorized) || (mayDelete == Authorized) -> termsAllowedField + | otherwise -> termsSetField [cfTerm cform] + _allOtherCases -> return termsAllowedField (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm <$> pure (cfCourseId =<< template) <*> areq ciField (fslI MsgCourseName) (cfName <$> template) diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 3bff46100..c5ba85946 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -7,6 +7,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} @@ -220,6 +221,13 @@ pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..} 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 ] From b87c3c4ca74d48b581faf8212f7b80cfe8bae200 Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 11 Oct 2018 12:04:40 +0200 Subject: [PATCH 5/6] Fixes #202. Not a bug actually. --- models | 4 ++-- src/Handler/Utils/Form.hs | 6 ++---- src/Utils/Form.hs | 2 +- 3 files changed, 5 insertions(+), 7 deletions(-) diff --git a/models b/models index 594b69fad..194a9c063 100644 --- a/models +++ b/models @@ -150,7 +150,7 @@ SubmissionFile isDeletion Bool -- only set if isUpdate is also set, but file was deleted by corrector UniqueSubmissionFile file submission isUpdate deriving Show -SubmissionUser +SubmissionUser -- Actual submission participant user UserId submission SubmissionId UniqueSubmissionUser user submission @@ -161,7 +161,7 @@ SubmissionGroupEdit user UserId time UTCTime submissionGroup SubmissionGroupId -SubmissionGroupUser +SubmissionGroupUser -- Registered submission groups, independent of actual SubmissionUser submissionGroup SubmissionGroupId user UserId UniqueSubmissionGroupUser submissionGroup user diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index c5ba85946..78ddbe393 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -165,18 +165,16 @@ buttonForm csrf = do $forall bView <- btnViews ^{fvInput bView} |] - $logDebugS "FormResult" $ tshow results return (accResult results,widget) where accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a accResult = Foldable.foldr accResult' FormMissing accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a - -- TODO: Does not work for Forms with more than 3 buttons, since all deliver FormFailure except for one! - -- TODO: Maybe change buttonField? + -- Find the single FormSuccess Just _; Expected behaviour: all buttons deliver FormFailure, except for one. accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"] accResult' (FormSuccess (Just x)) _ = FormSuccess x - accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Shouldn't Failure override Success? + accResult' _ x@(FormSuccess _) = x --Safe: most buttons deliver FormFailure, one delivers FormSuccess accResult' (FormSuccess Nothing) x = x accResult' FormMissing _ = FormMissing accResult' (FormFailure errs) _ = FormFailure errs diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 9a96781ef..939169e9b 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -195,7 +195,7 @@ buttonField btn = Field {fieldParse, fieldView, fieldEnctype} fieldParse [] _ = return $ Right Nothing fieldParse [str] _ | str == toPathPiece btn = return $ Right $ Just btn - | otherwise = return $ Left "Wrong button value" -- SJ: Right Nothing?! + | otherwise = return $ Left "Wrong button value" fieldParse _ _ = return $ Left "Multiple button values" combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> AForm (HandlerT site IO) [Maybe a] From 67ba5509b143f786eb8b8893715834c85bf8659f Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 11 Oct 2018 19:24:44 +0200 Subject: [PATCH 6/6] 3rd tick for issue #187 --- src/Handler/Course.hs | 113 ++++++++++++++++++++------------------ src/Handler/Utils/Form.hs | 31 ----------- 2 files changed, 60 insertions(+), 84 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 154c75d10..044f9b391 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -15,7 +15,7 @@ module Handler.Course where -import Import +import Import hiding (catMaybes) import Control.Lens import Utils.Lens @@ -33,6 +33,9 @@ import Data.Maybe import qualified Data.Set as Set import qualified Data.Map as Map +import qualified Data.CaseInsensitive as CI + + import Colonnade hiding (fromMaybe,bool) -- import Yesod.Colonnade @@ -317,6 +320,14 @@ postCRegisterR tid ssh csh = do (_other) -> return () -- TODO check this! redirect $ CourseR tid ssh csh CShowR + +getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> Maybe CourseShorthand -> Handler Html +getCourseNewTemplateR mbTid mbSsh mbCsh = + redirect (CourseNewR, catMaybes [ ("tid",).termToText.unTermKey <$> mbTid + , ("ssh",).CI.original.unSchoolKey <$> mbSsh + , ("csh",).CI.original <$> mbCsh + ]) + getCourseNewR :: Handler Html -- call via toTextUrl getCourseNewR = do uid <- requireAuthId @@ -325,59 +336,55 @@ getCourseNewR = do <*> iopt ciField "ssh" <*> iopt ciField "csh" let noTemplateAction = courseEditHandler True Nothing - case params of + case params of -- DO NOT REMOVE: without this distinction, lecturers would never see an empty newCourseForm any more! FormMissing -> noTemplateAction - FormFailure msgs -> forM_ msgs ((addMessage Error) . toHtml) - >> noTemplateAction - FormSuccess (mbTid,mbSsh,mbCsh) -> - getCourseNewTemplateR (TermKey <$> mbTid) (SchoolKey <$> mbSsh) mbCsh - -getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> Maybe CourseShorthand -> Handler Html -getCourseNewTemplateR mbTid mbSsh mbCsh = do - uid <- requireAuthId - oldCourses <- runDB $ do - E.select $ E.from $ \course -> do - whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm E.==. E.val tid - whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool E.==. E.val ssh - whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand E.==. E.val csh - let lecturersCourse = - E.exists $ E.from $ \lecturer -> do - E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid - E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId - let lecturersSchool = - E.exists $ E.from $ \user -> do - E.where_ $ user E.^. UserLecturerUser E.==. E.val uid - E.&&. user E.^. UserLecturerSchool E.==. course E.^. CourseSchool - let courseCreated c = - E.sub_select . E.from $ \edit -> do -- oldest edit must be creation - E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId - return $ E.min_ $ edit E.^. CourseEditTime - E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer - , E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer from schools of lecturer - , E.desc $ courseCreated course] -- most recent created course - E.limit 1 - return course - template <- case listToMaybe oldCourses of - (Just oldTemplate) -> - let newTemplate = (courseToForm oldTemplate) in - return $ Just $ newTemplate - { cfCourseId = Nothing - , cfTerm = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness - , cfRegFrom = Nothing - , cfRegTo = Nothing - , cfDeRegUntil = Nothing - } - Nothing -> do - (tidOk,sshOk,cshOk) <- runDB $ (,,) - <$> ifMaybeM mbTid True existsKey - <*> ifMaybeM mbSsh True existsKey - <*> ifMaybeM mbCsh True (\csh -> (not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1]) - unless tidOk $ addMessageI Warning $ MsgNoSuchTerm $ fromJust mbTid -- safe, since tidOk==True otherwise - unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise - unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh - when (tidOk && sshOk && cshOk) $ addMessageI Warning MsgNoSuchCourse - return Nothing - courseEditHandler True template + FormFailure msgs -> forM_ msgs ((addMessage Error) . toHtml) >> + noTemplateAction + FormSuccess (fmap TermKey -> mbTid, fmap SchoolKey -> mbSsh, mbCsh) -> do + uid <- requireAuthId + oldCourses <- runDB $ do + E.select $ E.from $ \course -> do + whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm E.==. E.val tid + whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool E.==. E.val ssh + whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand E.==. E.val csh + let lecturersCourse = + E.exists $ E.from $ \lecturer -> do + E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid + E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId + let lecturersSchool = + E.exists $ E.from $ \user -> do + E.where_ $ user E.^. UserLecturerUser E.==. E.val uid + E.&&. user E.^. UserLecturerSchool E.==. course E.^. CourseSchool + let courseCreated c = + E.sub_select . E.from $ \edit -> do -- oldest edit must be creation + E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId + return $ E.min_ $ edit E.^. CourseEditTime + E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer + , E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer from schools of lecturer + , E.desc $ courseCreated course] -- most recent created course + E.limit 1 + return course + template <- case listToMaybe oldCourses of + (Just oldTemplate) -> + let newTemplate = (courseToForm oldTemplate) in + return $ Just $ newTemplate + { cfCourseId = Nothing + , cfTerm = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness + , cfRegFrom = Nothing + , cfRegTo = Nothing + , cfDeRegUntil = Nothing + } + Nothing -> do + (tidOk,sshOk,cshOk) <- runDB $ (,,) + <$> ifMaybeM mbTid True existsKey + <*> ifMaybeM mbSsh True existsKey + <*> ifMaybeM mbCsh True (\csh -> (not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1]) + unless tidOk $ addMessageI Warning $ MsgNoSuchTerm $ fromJust mbTid -- safe, since tidOk==True otherwise + unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise + unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh + when (tidOk && sshOk && cshOk) $ addMessageI Warning MsgNoSuchCourse + return Nothing + courseEditHandler True template postCourseNewR :: Handler Html postCourseNewR = courseEditHandler False Nothing -- Note: Nothing is safe here, since we will create a new course. diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 78ddbe393..a6efd53ff 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -121,37 +121,6 @@ linkButton lbl cls url = [whamlet| - {- -combinedButtonField :: Button a => [a] -> Form m -> Form (a,m) -combinedButtonField btns inner csrf = do - buttonIdent <- newFormIdent - let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing - (results, btnViews) <- unzip <$> mapM button [minBound..maxBound] - (innerRes,innerWdgt) <- inner - let widget = do - [whamlet| - #{csrf} - ^{innerWdgt} -
- $forall bView <- btnViews - ^{fvInput bView} - |] - let result = case (accResult result, innerRes) of - (FormSuccess b, FormSuccess i) -> FormSuccess (b,i) - _ -> FormFailure ["Something went wrong"] -- TODO - return (result,widget) - where - accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a - accResult = Foldable.foldr accResult' FormMissing - - accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a - accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"] - accResult' (FormSuccess (Just x)) _ = FormSuccess x - accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Shouldn't Failure override Success? - accResult' (FormSuccess Nothing) x = x - accResult' FormMissing _ = FormMissing - accResult' (FormFailure errs) _ = FormFailure errs - -} -- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ())) buttonForm :: (Button UniWorX a, Show a) => Form a