From 02a0dc14359c9ef048c08ba40dfe1c717f207b60 Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 30 Jan 2019 10:58:57 +0100 Subject: [PATCH 01/11] Minor Refactor --- src/Foundation.hs | 18 +++--------------- src/Handler/Sheet.hs | 22 ++++++---------------- src/Utils/Sheet.hs | 22 ++++++++++++++++++++++ 3 files changed, 31 insertions(+), 31 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index 901c6c124..4840003f7 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1287,21 +1287,9 @@ pageActions (CourseR tid ssh csh SheetListR) = , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetCurrentR , menuItemModal = False - , menuItemAccessCallback' = do - now <- liftIO getCurrentTime - sheets <- runDB . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do - E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId - E.where_ $ sheet E.^. SheetActiveTo E.>. E.val now - E.&&. sheet E.^. SheetActiveFrom E.<=. E.val now - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.orderBy [E.asc $ sheet E.^. SheetActiveTo] - E.limit 1 - return $ sheet E.^. SheetName - case sheets of - (E.Value shn):_ -> (== Authorized) <$> isAuthorized (CSheetR tid ssh csh shn SShowR) False - _ -> return False + , menuItemAccessCallback' = runDB . maybeT (return False) $ do + void . MaybeT $ sheetCurrent tid ssh csh + return True } , MenuItem { menuItemType = PageActionPrime diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index ef30c1293..454b90a09 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -143,25 +143,15 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do getSheetCurrentR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getSheetCurrentR tid ssh csh = runDB $ do - now <- liftIO getCurrentTime - sheets <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do - E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId - E.where_ $ sheet E.^. SheetActiveTo E.>. E.val now - E.&&. sheet E.^. SheetActiveFrom E.<=. E.val now - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.orderBy [E.asc $ sheet E.^. SheetActiveFrom] - E.limit 1 - return $ sheet E.^. SheetName - case sheets of - (E.Value shn):_ -> redirectAccess $ CSheetR tid ssh csh shn SShowR - _ -> notFound + let redi shn = redirectAccess $ CSheetR tid ssh csh shn SShowR + shn <- sheetCurrent tid ssh csh + maybe notFound redi shn getSheetOldUnassigned :: TermId -> SchoolId -> CourseShorthand -> Handler () getSheetOldUnassigned tid ssh csh = runDB $ do - shn' <- sheetOldUnassigned tid ssh csh - maybe notFound (\shn -> redirectAccess $ CSheetR tid ssh csh shn SSubsR) shn' + let redi shn = redirectAccess $ CSheetR tid ssh csh shn SSubsR + shn <- sheetOldUnassigned tid ssh csh + maybe notFound redi shn getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getSheetListR tid ssh csh = do diff --git a/src/Utils/Sheet.hs b/src/Utils/Sheet.hs index 21f4ab310..93924d98d 100644 --- a/src/Utils/Sheet.hs +++ b/src/Utils/Sheet.hs @@ -3,6 +3,28 @@ module Utils.Sheet where import Import.NoFoundation import qualified Database.Esqueleto as E + +-- DB Queries for Sheets that are used in several places + +sheetCurrent :: MonadIO m => TermId -> SchoolId -> CourseShorthand -> SqlReadT m (Maybe SheetName) +sheetCurrent tid ssh csh = do + now <- liftIO getCurrentTime + sheets <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do + E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + E.where_ $ sheet E.^. SheetActiveTo E.>. E.val now + E.&&. sheet E.^. SheetActiveFrom E.<=. E.val now + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.orderBy [E.asc $ sheet E.^. SheetActiveFrom] + E.limit 1 + return $ sheet E.^. SheetName + return $ case sheets of + [] -> Nothing + [E.Value shn] -> Just shn + _ -> error "SQL Query with limit 1 returned more than one result" + + sheetOldUnassigned :: MonadIO m => TermId -> SchoolId -> CourseShorthand -> SqlReadT m (Maybe SheetName) sheetOldUnassigned tid ssh csh = do now <- liftIO getCurrentTime From 0c9f9aa419b51d111a2724ca93453a1593574208 Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 30 Jan 2019 11:13:25 +0100 Subject: [PATCH 02/11] Bugfix access rights current & lastinactive --- routes | 4 ++-- src/Foundation.hs | 1 - 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/routes b/routes index ebd3e5973..99f6f5add 100644 --- a/routes +++ b/routes @@ -73,8 +73,8 @@ /subs CCorrectionsR GET POST /ex SheetListR GET !registered !materials !corrector !/ex/new SheetNewR GET POST - !/ex/current SheetCurrentR GET !free -- just a redirect - !/ex/lastinactive SheetOldUnassigned GET !free -- just a redirect + !/ex/current SheetCurrentR GET !registered !materials !corrector + !/ex/unassigned SheetOldUnassigned GET /ex/#SheetName SheetR: /show SShowR GET !timeANDregistered !timeANDmaterials !corrector /edit SEditR GET POST diff --git a/src/Foundation.hs b/src/Foundation.hs index 4840003f7..a01f6744f 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1298,7 +1298,6 @@ pageActions (CourseR tid ssh csh SheetListR) = , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetOldUnassigned , menuItemModal = False , menuItemAccessCallback' = runDB . maybeT (return False) $ do - guardM $ (== Authorized) <$> evalAccessCorrector tid ssh csh void . MaybeT $ sheetOldUnassigned tid ssh csh return True } From a45e83fa68222ee57041a53454ffa437dd2f6b07 Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 30 Jan 2019 11:20:46 +0100 Subject: [PATCH 03/11] Minor Refactor --- src/Utils/Sheet.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Utils/Sheet.hs b/src/Utils/Sheet.hs index 93924d98d..ab6fa1bae 100644 --- a/src/Utils/Sheet.hs +++ b/src/Utils/Sheet.hs @@ -34,7 +34,7 @@ sheetOldUnassigned tid ssh csh = do E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh - E.where_ . E.exists . E.from $ \submission -> do + E.where_ . E.exists . E.from $ \submission -> E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId E.&&. E.isNothing (submission E.^. SubmissionRatingBy) E.orderBy [E.desc $ sheet E.^. SheetActiveTo] From 2e9320886fda78b18ab753680166720791da478a Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 30 Jan 2019 11:27:41 +0100 Subject: [PATCH 04/11] Minor bugfix sheetCurrent --- src/Utils/Sheet.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Utils/Sheet.hs b/src/Utils/Sheet.hs index ab6fa1bae..6525c7abb 100644 --- a/src/Utils/Sheet.hs +++ b/src/Utils/Sheet.hs @@ -16,7 +16,7 @@ sheetCurrent tid ssh csh = do E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh - E.orderBy [E.asc $ sheet E.^. SheetActiveFrom] + E.orderBy [E.asc $ sheet E.^. SheetActiveTo] E.limit 1 return $ sheet E.^. SheetName return $ case sheets of From b45d1c92f9c7604d05c8121d49b690e37f5f2b81 Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 30 Jan 2019 11:30:54 +0100 Subject: [PATCH 05/11] Bugfix sheetOldUnassigned --- src/Utils/Sheet.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Utils/Sheet.hs b/src/Utils/Sheet.hs index 6525c7abb..595c0729e 100644 --- a/src/Utils/Sheet.hs +++ b/src/Utils/Sheet.hs @@ -37,7 +37,7 @@ sheetOldUnassigned tid ssh csh = do E.where_ . E.exists . E.from $ \submission -> E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId E.&&. E.isNothing (submission E.^. SubmissionRatingBy) - E.orderBy [E.desc $ sheet E.^. SheetActiveTo] + E.orderBy [E.asc $ sheet E.^. SheetActiveTo] E.limit 1 return $ sheet E.^. SheetName return $ case sheets of From bd44fc60abcfba9112568bcbcf09598f7cd037a3 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 30 Jan 2019 12:20:07 +0100 Subject: [PATCH 06/11] Minor cleanup --- routes | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/routes b/routes index 99f6f5add..1c1535769 100644 --- a/routes +++ b/routes @@ -72,9 +72,9 @@ /notes CNotesR GET POST !corrector /subs CCorrectionsR GET POST /ex SheetListR GET !registered !materials !corrector - !/ex/new SheetNewR GET POST - !/ex/current SheetCurrentR GET !registered !materials !corrector - !/ex/unassigned SheetOldUnassigned GET + /ex/new SheetNewR GET POST + /ex/current SheetCurrentR GET !registered !materials !corrector + /ex/unassigned SheetOldUnassigned GET /ex/#SheetName SheetR: /show SShowR GET !timeANDregistered !timeANDmaterials !corrector /edit SEditR GET POST From 39da549461dbe5789e3f96b342785bf9bd35966c Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 30 Jan 2019 14:48:16 +0100 Subject: [PATCH 07/11] Towards #267 --- messages/uniworx/de.msg | 3 ++- src/Handler/Course.hs | 39 +++++++++++++++------------ templates/course.hamlet | 34 ++++++++++++----------- templates/widgets/registerForm.hamlet | 1 - 4 files changed, 42 insertions(+), 35 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 4f6f91a82..264cb3d79 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -7,6 +7,7 @@ BtnHijack: Sitzung übernehmen Aborted: Abgebrochen Registered: Angemeldet +RegisteredSince date@Text: Angemeldet seit #{date} RegisterFrom: Anmeldungen von RegisterTo: Anmeldungen bis DeRegUntil: Abmeldungen bis @@ -108,7 +109,7 @@ SheetSolutionFrom: Lösung ab SheetMarking: Hinweise für Korrektoren SheetType: Wertung SheetInvisible: Dieses Übungsblatt ist für Teilnehmer momentan unsichtbar! -SheetInvisibleUntil mFrom@Text: Dieses Übungsblatt ist für Teilnehmer momentan unsichtbar bis #{mFrom}! +SheetInvisibleUntil date@Text: Dieses Übungsblatt ist für Teilnehmer momentan unsichtbar bis #{date}! SheetName: Name SheetDescription: Hinweise für Teilnehmer SheetGroup: Gruppenabgabe diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 53eb08665..7af4ae48f 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -259,25 +259,30 @@ getTermCourseListR tid = do getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId - (courseEnt,(schoolMB,participants,registered),lecturers) <- runDB $ do - courseEnt@(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh - dependent <- (,,) - <$> get (courseSchool course) -- join -- just fetch full school name here - <*> count [CourseParticipantCourse ==. cid] -- join - <*> (case mbAid of -- TODO: Someone please refactor this late-night mess here! - Nothing -> return False - (Just aid) -> do regL <- getBy (UniqueParticipant aid cid) - return $ isJust regL) - lecturers <- E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do - E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId - E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid - return $ user E.^. UserDisplayName - return (courseEnt,dependent,E.unValue <$> lecturers) - let course = entityVal courseEnt - (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course - registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True + (course,schoolName,participants,registered,lecturers) <- runDB . maybeT notFound $ do + [(E.Entity cid course, E.Value schoolName, E.Value participants, E.Value registered)] + <- lift . E.select . E.from $ + \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do + E.on $ E.just (course E.^. CourseId) E.==. participant E.?. CourseParticipantCourse + E.&&. E.val mbAid E.==. participant E.?. CourseParticipantUser + E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + let numParticipants = E.sub_select . E.from $ \part -> do + E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId + return ( E.countRows :: E.SqlExpr (E.Value Int64)) + return (course,school E.^. SchoolName, numParticipants, participant E.?. CourseParticipantRegistration) + lecturers <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do + E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId + E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid + return $ user E.^. UserDisplayName + return (course,schoolName,participants,registered,map E.unValue lecturers) mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course + mRegAt <- traverse (formatTime SelFormatDateTime) $ registered + (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm (isJust mRegAt) $ courseRegisterSecret course + registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True defaultLayout $ do setTitle [shamlet| #{toPathPiece tid} - #{csh}|] $(widgetFile "course") diff --git a/templates/course.hamlet b/templates/course.hamlet index 76bd9ba2a..6968b4b97 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -1,10 +1,9 @@
- $maybe school <- schoolMB -
Fakultät/Institut -
-
- #{schoolName school} +
Fakultät/Institut +
+
+ #{schoolName} $maybe descr <- courseDescription course
_{MsgCourseDescription} @@ -33,20 +32,23 @@ $# $if NTop (Just 0) < NTop (courseCapacity course) #{participants} $maybe capacity <- courseCapacity course \ von #{capacity} - $maybe regFrom <- mRegFrom -
Anmeldezeitraum -
-
- Ab #{regFrom} - $maybe regTo <- mRegTo - \ bis #{regTo} - $if registrationOpen + $maybe regFrom <- mRegFrom +
Anmeldezeitraum +
+
+ Ab #{regFrom} + $maybe regTo <- mRegTo + \ bis #{regTo} + $if registrationOpen || isJust mRegAt
-
- $# regWidget is defined through templates/widgets/registerForm - ^{regWidget} + $if registrationOpen + + $# regWidget is defined through templates/widgets/registerForm + ^{regWidget} + $maybe date <- mRegAt + _{MsgRegisteredSince date}
Material
diff --git a/templates/widgets/registerForm.hamlet b/templates/widgets/registerForm.hamlet index d20fc0cc8..a2dd97af9 100644 --- a/templates/widgets/registerForm.hamlet +++ b/templates/widgets/registerForm.hamlet @@ -5,4 +5,3 @@ $maybe secretView <- msecretView ^{fvInput secretView} $# Always display register/deregister button ^{fvInput btnView} - From 13b567148050e8889aaf2103a2ea74fab38f3c65 Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 30 Jan 2019 16:00:18 +0100 Subject: [PATCH 08/11] Fixes #267 and related bugs --- src/Foundation.hs | 20 +++++++++++++++----- src/Handler/Course.hs | 5 +++-- src/Utils.hs | 2 +- templates/course.hamlet | 4 ++++ 4 files changed, 23 insertions(+), 8 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index 47f7640f3..fe61d882a 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -463,12 +463,22 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of return Authorized - CourseR tid ssh csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do - Entity _ Course{courseRegisterFrom, courseRegisterTo} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + CourseR tid ssh csh CRegisterR -> do + mbc <- getBy $ TermSchoolCourseShort tid ssh csh + mAid <- lift maybeAuthId + registered <- case (mbc,mAid) of + (Just (Entity cid _), Just uid) -> isJust <$> (getBy $ UniqueParticipant uid cid) + _ -> return False cTime <- (NTop . Just) <$> liftIO getCurrentTime - guard $ NTop courseRegisterFrom <= cTime - && NTop courseRegisterTo >= cTime - return Authorized + case mbc of + (Just (Entity _ Course{courseRegisterFrom, courseRegisterTo})) + | not registered + , courseRegisterFrom <= nBot cTime + , NTop courseRegisterTo >= cTime -> return Authorized + (Just (Entity _ Course{courseDeregisterUntil})) + | registered + , NTop courseDeregisterUntil >= cTime -> return Authorized + _other -> unauthorizedI MsgUnauthorizedCourseTime MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do smId <- decrypt cID diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 7af4ae48f..203859d1b 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -278,8 +278,9 @@ getCShowR tid ssh csh = do E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid return $ user E.^. UserDisplayName return (course,schoolName,participants,registered,map E.unValue lecturers) - mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course - mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course + mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course + mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course + mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course mRegAt <- traverse (formatTime SelFormatDateTime) $ registered (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm (isJust mRegAt) $ courseRegisterSecret course registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True diff --git a/src/Utils.hs b/src/Utils.hs index bc7d4fa4d..2990778dc 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -364,7 +364,7 @@ mcons :: Maybe a -> [a] -> [a] mcons Nothing xs = xs mcons (Just x) xs = x:xs -newtype NTop a = NTop a -- treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom +newtype NTop a = NTop { nBot :: a } -- treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom instance Eq a => Eq (NTop (Maybe a)) where (NTop x) == (NTop y) = x == y diff --git a/templates/course.hamlet b/templates/course.hamlet index 6968b4b97..130fe7f0a 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -39,6 +39,10 @@ $# $if NTop (Just 0) < NTop (courseCapacity course) Ab #{regFrom} $maybe regTo <- mRegTo \ bis #{regTo} + $maybe dereg <- mDereg +
+ \ Achtung: + \ Abmeldung nur bis #{dereg} erlaubt. $if registrationOpen || isJust mRegAt
From e4324a1c9b7ac93477a1d18977029a1e1cfa4ebf Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 30 Jan 2019 17:50:44 +0100 Subject: [PATCH 09/11] Fixes #262 --- messages/uniworx/de.msg | 3 ++- src/Foundation.hs | 40 ++++++++++++++++++++++++---------------- src/Handler/Sheet.hs | 6 ++++++ 3 files changed, 32 insertions(+), 17 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 264cb3d79..c7c7f8574 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -571,13 +571,14 @@ MenuSheetNew: Neues Übungsblatt anlegen MenuSheetCurrent: Aktuelles Übungsblatt MenuSheetOldUnassigned: Abgaben ohne Korrektor MenuCourseEdit: Kurs editieren -MenuCourseNewTemplate: Als neuen Kurs klonen +MenuCourseClone: Als neuen Kurs klonen MenuCourseDelete: Kurs löschen MenuSubmissionNew: Abgabe anlegen MenuSubmissionOwn: Abgabe MenuCorrectors: Korrektoren MenuSheetEdit: Übungsblatt editieren MenuSheetDelete: Übungsblatt löschen +MenuSheetClone: Als neues Übungsblatt klonen MenuCorrectionsUpload: Korrekturen hochladen MenuCorrectionsCreate: Abgaben registrieren MenuCorrectionsGrade: Abgaben bewerten diff --git a/src/Foundation.hs b/src/Foundation.hs index fe61d882a..9ac8fb834 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1275,8 +1275,8 @@ pageActions (CourseR tid ssh csh CShowR) = } , MenuItem { menuItemType = PageActionSecondary - , menuItemLabel = MsgMenuCourseNewTemplate - , menuItemIcon = Nothing + , menuItemLabel = MsgMenuCourseClone + , menuItemIcon = Just "copy" , menuItemRoute = SomeRoute (CourseNewR, [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)]) , menuItemModal = False , menuItemAccessCallback' = return True @@ -1284,7 +1284,7 @@ pageActions (CourseR tid ssh csh CShowR) = , MenuItem { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuCourseDelete - , menuItemIcon = Nothing + , menuItemIcon = Just "trash" , menuItemRoute = SomeRoute $ CourseR tid ssh csh CDeleteR , menuItemModal = False , menuItemAccessCallback' = return True @@ -1364,18 +1364,6 @@ pageActions (CSheetR tid ssh csh shn SShowR) = guard $ null submissions return True } - , MenuItem - { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuCorrectionsOwn - , menuItemIcon = Nothing - , menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term" , termToText $ unTermKey tid) - , ("corrections-school", CI.original $ unSchoolKey ssh) - , ("corrections-course", CI.original csh) - , ("corrections-sheet" , CI.original shn) - ]) - , menuItemModal = False - , menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh - } , MenuItem { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSubmissionOwn @@ -1388,6 +1376,18 @@ pageActions (CSheetR tid ssh csh shn SShowR) = guard . not $ null submissions return True } + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuCorrectionsOwn + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term" , termToText $ unTermKey tid) + , ("corrections-school", CI.original $ unSchoolKey ssh) + , ("corrections-course", CI.original csh) + , ("corrections-sheet" , CI.original shn) + ]) + , menuItemModal = False + , menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh + } , MenuItem { menuItemType = PageActionPrime , menuItemLabel = MsgMenuCorrectors @@ -1412,10 +1412,18 @@ pageActions (CSheetR tid ssh csh shn SShowR) = , menuItemModal = False , menuItemAccessCallback' = return True } + , MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuSheetClone + , menuItemIcon = Just "copy" + , menuItemRoute = SomeRoute (CourseR tid ssh csh SheetNewR, [("shn", toPathPiece shn)]) + , menuItemModal = False + , menuItemAccessCallback' = return True + } , MenuItem { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuSheetDelete - , menuItemIcon = Nothing + , menuItemIcon = Just "trash" , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SDelR , menuItemModal = False , menuItemAccessCallback' = return True diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 454b90a09..e798f9ca9 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -425,11 +425,17 @@ getSFileR tid ssh csh shn typ title = do getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getSheetNewR tid ssh csh = do + parShn <- runInputGetResult $ iopt ciField "shn" + let searchShn sheet = case parShn of + (FormSuccess (Just shn)) -> E.where_ $ sheet E.^. SheetName E.==. E.val shn + -- (FormFailure msgs) -> -- not in MonadHandler anymore -- forM_ msgs (addMessage Error . toHtml) + _other -> return () lastSheets <- runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.where_ $ course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh + searchShn sheet -- let lastSheetEdit = E.sub_select . E.from $ \sheetEdit -> do -- E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId -- return . E.max_ $ sheetEdit E.^. SheetEditTime From 73a19863b166e8536f49ad9160443e9d37ed00cf Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 30 Jan 2019 18:02:19 +0100 Subject: [PATCH 10/11] Fixbuild for hlint stupidty --- src/Handler/Course.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 203859d1b..b656ccdd2 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -281,7 +281,7 @@ getCShowR tid ssh csh = do mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course - mRegAt <- traverse (formatTime SelFormatDateTime) $ registered + mRegAt <- traverse (formatTime SelFormatDateTime) registered (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm (isJust mRegAt) $ courseRegisterSecret course registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True defaultLayout $ do From 8684ca016f58c8a5d782c6d1c68a2510afa52cbc Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 31 Jan 2019 11:12:20 +0100 Subject: [PATCH 11/11] Button cleanup --- src/Auth/Dummy.hs | 9 +- src/Auth/LDAP.hs | 13 +- src/Auth/PWHash.hs | 11 +- src/Foundation.hs | 25 +++- src/Handler/Admin.hs | 24 ++-- src/Handler/Profile.hs | 2 +- src/Handler/Sheet.hs | 6 +- src/Handler/Utils/Form.hs | 122 ++++++++----------- src/Handler/Utils/Table/Pagination.hs | 2 +- src/Utils/Form.hs | 52 ++++---- templates/table/layout-filter-default.hamlet | 2 +- 11 files changed, 121 insertions(+), 147 deletions(-) diff --git a/src/Auth/Dummy.hs b/src/Auth/Dummy.hs index bb26aa344..e7033f3d8 100644 --- a/src/Auth/Dummy.hs +++ b/src/Auth/Dummy.hs @@ -14,15 +14,14 @@ import qualified Data.CaseInsensitive as CI data DummyMessage = MsgDummyIdent | MsgDummyNoFormData + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) dummyForm :: ( RenderMessage site FormMessage , RenderMessage site DummyMessage - , RenderMessage site ButtonMessage , YesodPersist site , SqlBackendCanRead (YesodPersistBackend site) - , Button site SubmitButton - , Show (ButtonCssClass site) + , Button site ButtonSubmit ) => AForm (HandlerT site IO) (CI Text) dummyForm = areq (selectField userList) (fslI MsgDummyIdent) Nothing <* submitButton @@ -35,9 +34,7 @@ dummyLogin :: ( YesodAuth site , SqlBackendCanRead (YesodPersistBackend site) , RenderMessage site FormMessage , RenderMessage site DummyMessage - , RenderMessage site ButtonMessage - , Button site SubmitButton - , Show (ButtonCssClass site) + , Button site ButtonSubmit ) => AuthPlugin site dummyLogin = AuthPlugin{..} where diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index ee658b195..cd2a9a037 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -28,13 +28,14 @@ import qualified Yesod.Auth.Message as Msg data CampusLogin = CampusLogin { campusIdent :: CI Text , campusPassword :: Text - } + } deriving (Generic, Typeable) data CampusMessage = MsgCampusIdentNote | MsgCampusIdent | MsgCampusPassword | MsgCampusSubmit | MsgCampusInvalidCredentials + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry] @@ -53,9 +54,7 @@ userPrincipalName = Ldap.Attr "userPrincipalName" campusForm :: ( RenderMessage site FormMessage , RenderMessage site CampusMessage - , RenderMessage site ButtonMessage - , Button site SubmitButton - , Show (ButtonCssClass site) + , Button site ButtonSubmit ) => AForm (HandlerT site IO) CampusLogin campusForm = CampusLogin <$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote) Nothing @@ -66,9 +65,7 @@ campusLogin :: forall site. ( YesodAuth site , RenderMessage site FormMessage , RenderMessage site CampusMessage - , RenderMessage site ButtonMessage - , Button site SubmitButton - , Show (ButtonCssClass site) + , Button site ButtonSubmit ) => LdapConf -> LdapPool -> AuthPlugin site campusLogin conf@LdapConf{..} pool = AuthPlugin{..} where @@ -116,7 +113,7 @@ data CampusUserException = CampusUserLdapError LdapPoolError | CampusUserHostCannotConnect String [IOException] | CampusUserNoResult | CampusUserAmbiguous - deriving (Show, Eq, Typeable) + deriving (Show, Eq, Generic, Typeable) instance Exception CampusUserException diff --git a/src/Auth/PWHash.hs b/src/Auth/PWHash.hs index 53001ce92..68df34703 100644 --- a/src/Auth/PWHash.hs +++ b/src/Auth/PWHash.hs @@ -19,17 +19,16 @@ import qualified Yesod.Auth.Message as Msg data HashLogin = HashLogin { hashIdent :: CI Text , hashPassword :: Text - } + } deriving (Generic, Typeable) data PWHashMessage = MsgPWHashIdent | MsgPWHashPassword + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) hashForm :: ( RenderMessage site FormMessage , RenderMessage site PWHashMessage - , RenderMessage site ButtonMessage - , Button site SubmitButton - , Show (ButtonCssClass site) + , Button site ButtonSubmit ) => AForm (HandlerT site IO) HashLogin hashForm = HashLogin <$> areq ciField (fslpI MsgPWHashIdent "Identifikation") Nothing @@ -42,9 +41,7 @@ hashLogin :: ( YesodAuth site , SqlBackendCanRead (YesodPersistBackend site) , RenderMessage site FormMessage , RenderMessage site PWHashMessage - , RenderMessage site ButtonMessage - , Button site SubmitButton - , Show (ButtonCssClass site) + , Button site ButtonSubmit ) => PWHashAlgorithm -> AuthPlugin site hashLogin pwHashAlgo = AuthPlugin{..} where diff --git a/src/Foundation.hs b/src/Foundation.hs index 9ac8fb834..6f69c53b6 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -276,13 +276,28 @@ menuItemAccessCallback MenuItem{..} = and2M ((==) Authorized <$> authCheck) menu $(return []) -data instance ButtonCssClass UniWorX = BCDefault | BCPrimary | BCSuccess | BCInfo | BCWarning | BCDanger | BCLink - deriving (Enum, Eq, Ord, Bounded, Read, Show) +data instance ButtonClass UniWorX + = BCIsButton + | BCDefault + | BCPrimary + | BCSuccess + | BCInfo + | BCWarning + | BCDanger + | BCLink + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe (ButtonClass UniWorX) +instance Finite (ButtonClass UniWorX) -instance Button UniWorX SubmitButton where - label BtnSubmit = [whamlet|_{MsgBtnSubmit}|] +instance PathPiece (ButtonClass UniWorX) where + toPathPiece BCIsButton = "btn" + toPathPiece bClass = ("btn-" <>) . camelToPathPiece' 1 $ tshow bClass + fromPathPiece = finiteFromPathPiece - cssClass BtnSubmit = BCPrimary + +embedRenderMessage ''UniWorX ''ButtonSubmit id +instance Button UniWorX ButtonSubmit where + btnClasses BtnSubmit = [BCIsButton, BCPrimary] getTimeLocale' :: [Lang] -> TimeLocale diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index feea45783..17bc943b9 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -13,8 +13,6 @@ import Control.Monad.Trans.Except -- import Data.Function ((&)) -- import Yesod.Form.Bootstrap3 -import Web.PathPieces (showToPathPiece, readFromPathPiece) - import Database.Persist.Sql (fromSqlKey) -- import Colonnade hiding (fromMaybe) @@ -23,19 +21,19 @@ import Database.Persist.Sql (fromSqlKey) -- import qualified Data.UUID.Cryptographic as UUID -- BEGIN - Buttons needed only here -data CreateButton = CreateMath | CreateInf -- Dummy for Example - deriving (Enum, Eq, Ord, Bounded, Read, Show) +data ButtonCreate = CreateMath | CreateInf -- Dummy for Example + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe ButtonCreate +instance Finite ButtonCreate -instance PathPiece CreateButton where -- for displaying the button only, not really for paths - toPathPiece = showToPathPiece - fromPathPiece = readFromPathPiece +nullaryPathPiece ''ButtonCreate camelToPathPiece -instance Button UniWorX CreateButton where - label CreateMath = [whamlet|Mathematik|] - label CreateInf = "Informatik" +instance Button UniWorX ButtonCreate where + btnLabel CreateMath = [whamlet|Mathematik|] + btnLabel CreateInf = "Informatik" - cssClass CreateMath = BCInfo - cssClass CreateInf = BCPrimary + btnClasses CreateMath = [BCIsButton, BCInfo] + btnClasses CreateInf = [BCIsButton, BCPrimary] -- END Button needed here emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailContext) @@ -60,7 +58,7 @@ emailTestForm = (,) getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden! getAdminTestR = postAdminTestR postAdminTestR = do - ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm "buttons" (buttonForm :: Form CreateButton) + ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm "buttons" (buttonForm :: Form ButtonCreate) case btnResult of (FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt" (FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt" diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 12a99c604..38f064dd8 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -222,7 +222,7 @@ getProfileDataR = do let tutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|] -- Delete Button - (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form BtnDelete) + (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form ButtonDelete) defaultLayout $ do let delWdgt = $(widgetFile "widgets/data-delete") $(widgetFile "profileData") diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index e798f9ca9..fd15fa58b 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -277,15 +277,15 @@ getSheetListR tid ssh csh = do $(widgetFile "sheetList") data ButtonGeneratePseudonym = BtnGenerate - deriving (Enum, Eq, Ord, Bounded, Read, Show) + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Universe ButtonGeneratePseudonym instance Finite ButtonGeneratePseudonym nullaryPathPiece ''ButtonGeneratePseudonym (camelToPathPiece' 1) instance Button UniWorX ButtonGeneratePseudonym where - label BtnGenerate = [whamlet|_{MsgSheetGeneratePseudonym}|] - cssClass BtnGenerate = BCDefault + btnLabel BtnGenerate = [whamlet|_{MsgSheetGeneratePseudonym}|] + btnClasses BtnGenerate = [BCIsButton, BCDefault] -- Show single sheet getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 35297475e..152d53186 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -15,8 +15,6 @@ import qualified Data.Char as Char import qualified Data.CaseInsensitive as CI -import qualified Data.Foldable as Foldable - -- import Yesod.Core import qualified Data.Text as T -- import Yesod.Form.Types @@ -51,64 +49,55 @@ import Data.Aeson.Text (encodeToLazyText) -- Buttons (new version ) -- ---------------------------- -data BtnDelete = BtnDelete - deriving (Enum, Eq, Ord, Bounded, Read, Show) +data ButtonDelete = BtnDelete + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe ButtonDelete +instance Finite ButtonDelete -instance Universe BtnDelete -instance Finite BtnDelete +nullaryPathPiece ''ButtonDelete $ camelToPathPiece' 1 -nullaryPathPiece ''BtnDelete $ camelToPathPiece' 1 +embedRenderMessage ''UniWorX ''ButtonDelete id +instance Button UniWorX ButtonDelete where + btnClasses BtnDelete = [BCIsButton, BCDanger] -instance Button UniWorX BtnDelete where - label BtnDelete = [whamlet|_{MsgBtnDelete}|] +data ButtonRegister = BtnRegister | BtnDeregister + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe ButtonRegister +instance Finite ButtonRegister - cssClass BtnDelete = BCDanger +nullaryPathPiece ''ButtonRegister $ camelToPathPiece' 1 -data RegisterButton = BtnRegister | BtnDeregister - deriving (Enum, Eq, Ord, Bounded, Read, Show) +embedRenderMessage ''UniWorX ''ButtonRegister id +instance Button UniWorX ButtonRegister where + btnClasses BtnRegister = [BCIsButton, BCPrimary] + btnClasses BtnDeregister = [BCIsButton, BCDanger] -instance Universe RegisterButton -instance Finite RegisterButton +data ButtonHijack = BtnHijack + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe ButtonHijack +instance Finite ButtonHijack -nullaryPathPiece ''RegisterButton $ camelToPathPiece' 1 +nullaryPathPiece ''ButtonHijack $ camelToPathPiece' 1 -instance Button UniWorX RegisterButton where - label BtnRegister = [whamlet|_{MsgBtnRegister}|] - label BtnDeregister = [whamlet|_{MsgBtnDeregister}|] +embedRenderMessage ''UniWorX ''ButtonHijack id +instance Button UniWorX ButtonHijack where + btnClasses BtnHijack = [BCIsButton, BCDefault] - cssClass BtnRegister = BCPrimary - cssClass BtnDeregister = BCDanger +data ButtonSubmitDelete = BtnSubmit' | BtnDelete' + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) -data AdminHijackUserButton = BtnHijack - deriving (Enum, Eq, Ord, Bounded, Read, Show) +instance Universe ButtonSubmitDelete +instance Finite ButtonSubmitDelete -instance Universe AdminHijackUserButton -instance Finite AdminHijackUserButton - -nullaryPathPiece ''AdminHijackUserButton $ camelToPathPiece' 1 - -instance Button UniWorX AdminHijackUserButton where - label BtnHijack = [whamlet|_{MsgBtnHijack}|] - - cssClass BtnHijack = BCDefault - -data BtnSubmitDelete = BtnSubmit' | BtnDelete' - deriving (Enum, Eq, Ord, Bounded, Read, Show) - -instance Universe BtnSubmitDelete -instance Finite BtnSubmitDelete - -instance Button UniWorX BtnSubmitDelete where - label BtnSubmit' = [whamlet|_{MsgBtnSubmit}|] - label BtnDelete' = [whamlet|_{MsgBtnDelete}|] - - cssClass BtnSubmit' = BCPrimary - cssClass BtnDelete' = BCDanger +embedRenderMessage ''UniWorX ''ButtonSubmitDelete $ dropSuffix "'" +instance Button UniWorX ButtonSubmitDelete where + btnClasses BtnSubmit' = [BCIsButton, BCPrimary] + btnClasses BtnDelete' = [BCIsButton, BCDanger] btnValidate _ BtnSubmit' = True btnValidate _ BtnDelete' = False -nullaryPathPiece ''BtnSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'" +nullaryPathPiece ''ButtonSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'" -- -- Looks like a button, but is just a link (e.g. for create course, etc.) @@ -118,8 +107,14 @@ nullaryPathPiece ''BtnSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'" -- instance PathPiece LinkButton where -- LinkButton route = ??? -linkButton :: Widget -> ButtonCssClass UniWorX -> Route UniWorX -> Widget -- Alternative: Handler.Utils.simpleLink -linkButton lbl cls url = [whamlet| ^{lbl} |] +linkButton :: Widget -> [ButtonClass UniWorX] -> SomeRoute UniWorX -> Widget -- Alternative: Handler.Utils.simpleLink +linkButton lbl cls url = do + url' <- toTextUrl url + [whamlet| + $newline never + + ^{lbl} + |] -- [whamlet| -- -- @@ -128,31 +123,16 @@ linkButton lbl cls url = [whamlet| --- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ())) -buttonForm :: (Button UniWorX a, Show a) => Form a +-- buttonForm :: (Button UniWorX a, Finite a) => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, Widget) +buttonForm :: (Button UniWorX a, Finite a) => Form a buttonForm csrf = do - buttonIdent <- newFormIdent - let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing - (results, btnViews) <- unzip <$> mapM button [minBound..maxBound] - let widget = - [whamlet| - #{csrf} - $forall bView <- btnViews - ^{fvInput bView} - |] - 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 - -- 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 --Safe: most buttons deliver FormFailure, one delivers FormSuccess - accResult' (FormSuccess Nothing) x = x - accResult' FormMissing _ = FormMissing - accResult' (FormFailure errs) _ = FormFailure errs + (res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonFieldF "" + return (res, [whamlet| + $newline never + #{csrf} + $forall bView <- fViews + ^{fvInput bView} + |]) diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index c42a85dda..9b205b1a9 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -519,7 +519,7 @@ dbParamsFormWrap DBParamsForm{..} tableForm frag = do return . (res,) $ do btnId <- newIdent act <- traverse toTextUrl dbParamsFormAction - let submitField :: Field Handler SubmitButton + let submitField :: Field Handler ButtonSubmit submitField = buttonField BtnSubmit submitView :: Widget submitView = fieldView submitField btnId "" mempty (Right BtnSubmit) False diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index a7f6d0e31..6fab13a32 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -7,7 +7,6 @@ import Settings import qualified Text.Blaze.Internal as Blaze (null) import qualified Data.Text as T -import qualified Data.Char as Char import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI @@ -200,37 +199,36 @@ identForm = identifyForm . toPathPiece -- Buttons (new version ) -- ---------------------------- -data family ButtonCssClass site :: * +data family ButtonClass site :: * -bcc2txt :: Show (ButtonCssClass site) => ButtonCssClass site -> Text -- a Hack; maybe define Read/Show manually -bcc2txt bcc = T.pack $ "btn-" ++ (Char.toLower <$> drop 2 (show bcc)) +class (PathPiece a, PathPiece (ButtonClass site), RenderMessage site ButtonMessage) => Button site a where + btnLabel :: a -> WidgetT site IO () -class (Enum a, Bounded a, Ord a, PathPiece a) => Button site a where - label :: a -> WidgetT site IO () - label = toWidget . toPathPiece + default btnLabel :: RenderMessage site a => a -> WidgetT site IO () + btnLabel = toWidget <=< ap getMessageRender . return btnValidate :: forall p. p site -> a -> Bool btnValidate _ _ = True - cssClass :: a -> ButtonCssClass site + btnClasses :: a -> [ButtonClass site] + btnClasses _ = [] data ButtonMessage = MsgAmbiguousButtons | MsgWrongButtonValue | MsgMultipleButtonValues + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) -data SubmitButton = BtnSubmit - deriving (Enum, Eq, Ord, Bounded, Read, Show) +data ButtonSubmit = BtnSubmit + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) -instance Universe SubmitButton -instance Finite SubmitButton +instance Universe ButtonSubmit +instance Finite ButtonSubmit -nullaryPathPiece ''SubmitButton $ camelToPathPiece' 1 +nullaryPathPiece ''ButtonSubmit $ camelToPathPiece' 1 buttonField :: forall a m. ( Button (HandlerSite m) a - , Show (ButtonCssClass (HandlerSite m)) - , RenderMessage (HandlerSite m) ButtonMessage - , Monad m + , MonadHandler m ) => a -> Field m a -- | Already validates that the correct button press was received (result only neccessary for combinedButtonField) buttonField btn = Field{..} @@ -239,12 +237,12 @@ buttonField btn = Field{..} fieldView :: FieldViewFunc m a fieldView fid name attrs _val _ = let - cssClass' :: ButtonCssClass (HandlerSite m) - cssClass' = cssClass btn validate = btnValidate (Proxy @(HandlerSite m)) btn + classes :: [ButtonClass (HandlerSite m)] + classes = btnClasses btn in [whamlet| $newline never -