diff --git a/ChangeLog.md b/ChangeLog.md index 784dc8824..3e3d9dfe8 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ + * Version 30.01.2019 + + Designänderungen + * Version 16.01.2019 Links für Bequemlichkeiten hinzugefügt (z.B. aktuelles Übungsblatt) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index c75a4fb73..f620cecf7 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 @@ -69,7 +70,7 @@ CourseSemester: Semester CourseSchool: Institut CourseSchoolShort: Fach CourseSecretTip: Anmeldung zum Kurs erfordert Eingabe des Passworts, sofern gesetzt -CourseRegisterFromTip: Ohne Datum ist keine eigenständige Anmeldung von Studierenden möglich +CourseRegisterFromTip: Ohne Datum ist KEINE eigenständige Anmeldung von Studierenden möglich CourseRegisterToTip: Anmeldung darf auch ohne Begrenzung möglich sein CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein CourseFilterSearch: Volltext-Suche @@ -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 @@ -207,6 +208,7 @@ CorByProportionOnly proportion@Rational: #{display proportion} Anteile CorByProportionIncludingTutorial proportion@Rational: #{display proportion} Anteile - Tutorium CorByProportionExcludingTutorial proportion@Rational: #{display proportion} Anteile + Tutorium +RowCount count@Int64: #{display count} #{pluralDE count "Eintrag" "Einträge"} insgesamt DeleteRow: Zeile entfernen ProportionNegative: Anteile dürfen nicht negativ sein CorrectorUpdated: Korrektor erfolgreich aktualisiert @@ -240,7 +242,7 @@ MultiFileUploadInfo: (Mehrere Dateien mit Shift oder Strg auswählen) NrColumn: Nr SelectColumn: Auswahl -DBTablePagesize: Einträge +DBTablePagesize: Einträge pro Seite DBTablePagesizeAll: Alle CorrDownload: Herunterladen @@ -568,15 +570,16 @@ MenuSubmissions: Abgaben MenuSheetList: Übungsblätter MenuSheetNew: Neues Übungsblatt anlegen MenuSheetCurrent: Aktuelles Übungsblatt -MenuSheetLastInactive: Zuletzt abgegebenes Ü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 @@ -608,4 +611,4 @@ DeleteCopyStringIfSure n@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE n " DeleteConfirmation: Bestätigung DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen. -DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde \ No newline at end of file +DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde diff --git a/routes b/routes index 6e3015dfd..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 !free -- just a redirect - !/ex/lastinactive SheetLastInactiveR GET !free -- just a redirect + /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 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 aa1c0657d..f9415181f 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -63,6 +63,7 @@ import Handler.Utils.StudyFeatures import Handler.Utils.Templates import Utils.Lens import Utils.Form +import Utils.Sheet import Utils.SystemMessage import Text.Shakespeare.Text (st) @@ -275,20 +276,35 @@ instance HasRoute UniWorX MenuItem where urlRoute MenuItem{..} = urlRoute menuItemRoute menuItemAccessCallback :: MenuItem -> Handler Bool -menuItemAccessCallback MenuItem{..} = (&&) <$> ((==) Authorized <$> authCheck) <*> menuItemAccessCallback' +menuItemAccessCallback MenuItem{..} = and2M ((==) Authorized <$> authCheck) menuItemAccessCallback' where authCheck = handleAny (\_ -> return . Unauthorized $ error "authCheck caught exception") $ isAuthorized (urlRoute menuItemRoute) False $(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 @@ -469,12 +485,23 @@ 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 - cTime <- (NTop . Just) <$> liftIO getCurrentTime - guard $ NTop courseRegisterFrom <= cTime - && NTop courseRegisterTo >= cTime - return Authorized + CourseR tid ssh csh CRegisterR -> do + now <- liftIO getCurrentTime + 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 + case mbc of + (Just (Entity _ Course{courseRegisterFrom, courseRegisterTo})) + | not registered + , Just regFrom <- courseRegisterFrom -- Nothing = no registration + , regFrom <= now + , maybe True (now <=) courseRegisterTo -> return Authorized + (Just (Entity _ Course{courseDeregisterUntil})) + | registered + , maybe True (now <=) courseDeregisterUntil -> return Authorized + _other -> unauthorizedI MsgUnauthorizedCourseTime MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do smId <- decrypt cID @@ -1269,8 +1296,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 @@ -1278,7 +1305,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 @@ -1291,29 +1318,19 @@ 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 - , menuItemLabel = MsgMenuSheetLastInactive + , menuItemLabel = MsgMenuSheetOldUnassigned , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetLastInactiveR + , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetOldUnassigned , menuItemModal = False - , menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh + , menuItemAccessCallback' = runDB . maybeT (return False) $ do + void . MaybeT $ sheetOldUnassigned tid ssh csh + return True } , MenuItem { menuItemType = PageActionPrime @@ -1368,18 +1385,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 @@ -1392,6 +1397,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 @@ -1416,10 +1433,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 @@ -1455,7 +1480,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = , MenuItem { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuSubmissionDelete - , menuItemIcon = Nothing + , menuItemIcon = Just "trash" , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR , menuItemModal = False , menuItemAccessCallback' = return True @@ -1474,7 +1499,7 @@ pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) = pageActions (CSheetR tid ssh csh shn SCorrR) = [ MenuItem { menuItemType = PageActionPrime - , menuItemLabel = MsgMenuCorrections + , menuItemLabel = MsgMenuSubmissions , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SSubsR , menuItemModal = False 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/Corrections.hs b/src/Handler/Corrections.hs index 5b8cd35c7..1fece3778 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -479,11 +479,9 @@ assignAction selId = ( CorrSetCorrector E.distinct $ return user - mr <- getMessageRender + correctors' <- forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (SomeMessage userDisplayName, ) <$> encrypt entityKey - correctors' <- fmap ((mr MsgNoCorrector, Nothing) :) . forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (display userDisplayName, ) . Just <$> encrypt entityKey - - cId <- wpreq (selectFieldList correctors' :: Field (HandlerT UniWorX IO) (Maybe CryptoUUIDUser)) (fslI MsgCorrector) Nothing + cId <- wopt (selectFieldList correctors' :: Field (HandlerT UniWorX IO) CryptoUUIDUser) (fslI MsgCorrector) Nothing fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId ) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 53eb08665..b656ccdd2 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -259,25 +259,31 @@ 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 + (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 + 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 - mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course - mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course defaultLayout $ do setTitle [shamlet| #{toPathPiece tid} - #{csh}|] $(widgetFile "course") 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 2995c3b7d..fd15fa58b 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -3,6 +3,7 @@ module Handler.Sheet where import Import import System.FilePath (takeFileName) +import Utils.Sheet import Handler.Utils -- import Handler.Utils.Zip import Handler.Utils.Table.Cells @@ -142,38 +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 - -getSheetLastInactiveR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getSheetLastInactiveR tid ssh csh = runDB $ do - -- TODO: deliver oldest sheet with unassigned submissions instead!!! - 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.&&. 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.desc $ sheet E.^. SheetActiveTo] - 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 + 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 @@ -299,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 @@ -447,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 diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 7ccf0a731..3ecc4b932 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -69,3 +69,8 @@ warnTermDays tid times = do forM_ warnholidays $ warnI MsgDayIsAHoliday forM_ outoflecture $ warnI MsgDayIsOutOfLecture forM_ outoftermdays $ warnI MsgDayIsOutOfTerm + +visibleWidget :: Bool -> Widget +-- ^ @visibleWidget False@ is an icon that denotes that something™ is not visible +visibleWidget True = mempty +visibleWidget False = [whamlet||] 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/Submission.hs b/src/Handler/Utils/Submission.hs index a397041a8..124da1b83 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -130,7 +130,9 @@ assignSubmissions sid restriction = do props = getSum $ foldMap (Sum . fst) assignments toDeficit' (prop, assigned) = let - target = round $ fromInteger assigned' * (prop / props) + target + | props == 0 = 0 + | otherwise = round $ fromInteger assigned' * (prop / props) in target - assigned $logDebugS "assignSubmissions" $ "Previous submissions: " <> tshow prevSubs' diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index c42a85dda..368758bea 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 @@ -602,11 +602,11 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db | otherwise = def + referencePagesize = psLimit . snd . runPSValidator dbtable $ Just prevPi + (((filterRes, filterWdgt), filterEnc), ((pagesizeRes, pagesizeWdgt), pagesizeEnc)) <- mdo (filterRes'@((filterRes, _), _)) <- runFormGet . identForm FIDDBTableFilter . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi) - let referencePagesize = psLimit . snd . runPSValidator dbtable $ Just prevPi - (pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identForm FIDDBTablePagesize . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . renderAForm FormDBTablePagesize $ areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addAutosubmit & addName (wIdent "pagesize") & addClass "select--pagesize") (Just referencePagesize) <* autosubmitButton @@ -760,6 +760,15 @@ dbColonnade :: (Headedness h, Monoid x) -> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) dbColonnade = id +pagesizeOptions :: PagesizeLimit -- ^ Current/previous value + -> NonNull [PagesizeLimit] +pagesizeOptions psLim = impureNonNull . Set.toAscList . Set.fromList $ psLim : PagesizeAll : map PagesizeLimit opts + where + opts :: [Int64] + opts = filter (> 0) $ opts' <> map (`div` 2) opts' + + opts' = [ 10^n | n <- [1..3]] + pagesizeField :: PagesizeLimit -> Field Handler PagesizeLimit pagesizeField psLim = selectField $ do MsgRenderer mr <- getMsgRenderer @@ -767,16 +776,9 @@ pagesizeField psLim = selectField $ do optText (PagesizeLimit l) = tshow l optText PagesizeAll = mr MsgDBTablePagesizeAll - toOptionList = flip OptionList fromPathPiece . map (\o -> Option (optText o) o $ toPathPiece o) . Set.toAscList . Set.fromList - return $ toOptionList limOpts - where - limOpts :: [PagesizeLimit] - limOpts = psLim : PagesizeAll : map PagesizeLimit opts + toOptionList = flip OptionList fromPathPiece . map (\o -> Option (optText o) o $ toPathPiece o) + return . toOptionList . toNullable $ pagesizeOptions psLim - opts :: [Int64] - opts = filter (> 0) $ opts' <> map (`div` 2) opts' - - opts' = [ 10^n | n <- [1..3]] --- DBCell utility functions diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 308b5a6dd..1f1220787 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -59,6 +59,7 @@ import Ldap.Client.Pool as Import import Database.Esqueleto.Instances as Import () import Database.Persist.Sql.Instances as Import () +import Database.Persist.Sql as Import (SqlReadT,SqlWriteT) import Control.Monad.Trans.RWS (RWST) 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/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 -