diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index c638a4ba4..d24a09e5c 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 @@ -570,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/routes b/routes index ebd3e5973..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 SheetOldUnassigned 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 b3dfb271f..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 @@ -463,12 +478,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 @@ -1265,8 +1290,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 @@ -1274,7 +1299,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 @@ -1287,21 +1312,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 @@ -1310,7 +1323,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 } @@ -1367,18 +1379,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 @@ -1391,6 +1391,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 @@ -1415,10 +1427,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/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/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 ef30c1293..fd15fa58b 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 @@ -287,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 @@ -435,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/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.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 -