diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 564fb43eb..5c7b3cfe6 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -483,4 +483,36 @@ ErrMsgInvalidBase64 base64Err@String: Verschlüsselte Daten nicht korrekt base64 ErrMsgCouldNotDecodeNonce: Konnte secretbox-nonce nicht dekodieren ErrMsgCouldNotOpenSecretbox: Konnte libsodium-secretbox nicht öffnen (Verschlüsselte Daten sind nicht authentisch) ErrMsgCouldNotDecodePlaintext utf8Err@Text: Konnte Klartext nicht UTF8-dekodieren: #{utf8Err} -ErrMsgHeading: Fehlermeldung entschlüsseln \ No newline at end of file +ErrMsgHeading: Fehlermeldung entschlüsseln + +InvalidRoute: Konnte URL nicht interpretieren + +MenuHome: Aktuell +MenuVersion: Impressum +MenuHelp: Hilfe +MenuProfile: Anpassen +MenuLogin: Login +MenuLogout: Logout +MenuCourseList: Kurse +MenuTermShow: Semester +MenuCorrection: Korrektur +MenuUsers: Benutzer +MenuAdminTest: Admin-Demo +MenuMessageList: Systemnachrichten +MenuAdminErrMsg: Fehlermeldung entschlüsseln +MenuProfileData: Persönliche Daten +MenuTermCreate: Neues Semester anlegen +MenuCourseNew: Neuen Kurs anlegen +MenuTermEdit: Semester editieren +MenuSheetList: Übungsblätter +MenuCorrections: Abgaben +MenuSheetNew: Neues Übungsblatt anlegen +MenuCourseEdit: Kurs editieren +MenuCourseNewTemplate: Als neuen Kurs klonen +MenuSubmissionNew: Abgabe anlegen +MenuSubmissionOwn: Abgabe +MenuCorrectors: Korrektoren +MenuSheetEdit: Übungsblatt editieren +MenuCorrectionsUpload: Korrekturen hochladen +MenuCorrectionsCreate: Abgaben registrieren +MenuCorrectionsGrade: Abgaben bewerten diff --git a/src/Foundation.hs b/src/Foundation.hs index 6dbc131bf..a2d0f20ac 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -146,28 +146,6 @@ pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Cr pattern CSubmissionR tid ssh csh shn cid ptn = CSheetR tid ssh csh shn (SubmissionR cid ptn) --- Menus and Favourites -data MenuItem = MenuItem - { menuItemLabel :: Text - , menuItemIcon :: Maybe Text -- currently from: https://fontawesome.com/icons?d=gallery - , menuItemRoute :: Route UniWorX - , menuItemAccessCallback' :: Handler Bool -- Check whether action is shown in ADDITION to authorization (which is always checked) - , menuItemModal :: Bool - } - -menuItemAccessCallback :: MenuItem -> Handler Bool -menuItemAccessCallback MenuItem{..} = (&&) <$> ((==) Authorized <$> authCheck) <*> menuItemAccessCallback' - where - authCheck = handleAny (\_ -> return . Unauthorized $ error "authCheck caught exception") $ isAuthorized menuItemRoute False - -data MenuTypes -- Semantische Rolle: - = NavbarAside { menuItem :: MenuItem } -- TODO - | NavbarExtra { menuItem :: MenuItem } -- TODO - | NavbarRight { menuItem :: MenuItem } -- Generell, nahezu immer sichtbar - | NavbarSecondary { menuItem :: MenuItem } -- Generell, nahezu immer sichtbar - | PageActionPrime { menuItem :: MenuItem } -- Seitenspezifische Aktion, häufig - | PageActionSecondary { menuItem :: MenuItem } -- Seitenspezifische Aktion, selten (nicht im MouseOver enthalten, immer hinten gelistet) - -- Messages mkMessage "UniWorX" "messages/uniworx" "de" mkMessageVariant "UniWorX" "Campus" "messages/campus" "de" @@ -238,6 +216,51 @@ newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <>) +-- Menus and Favourites +data MenuType = NavbarAside | NavbarRight | NavbarSecondary | PageActionPrime | PageActionSecondary + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + +class RedirectUrl site url => HasRoute site url where + urlRoute :: url -> Route site + +instance HasRoute site (Route site) where + urlRoute = id +instance (key ~ Text, val ~ Text) => HasRoute site (Route site, Map key val) where + urlRoute = view _1 +instance (key ~ Text, val ~ Text) => HasRoute site (Route site, [(key, val)]) where + urlRoute = view _1 +instance (HasRoute site a, PathPiece b) => HasRoute site (Fragment a b) where + urlRoute (a :#: _) = urlRoute a + +data SomeRoute site = forall url. HasRoute site url => SomeRoute url + +instance RedirectUrl site (SomeRoute site) where + toTextUrl (SomeRoute url) = toTextUrl url +instance HasRoute site (SomeRoute site) where + urlRoute (SomeRoute url) = urlRoute url + +data MenuItem = MenuItem + { menuItemLabel :: UniWorXMessage + , menuItemIcon :: Maybe Text -- currently from: https://fontawesome.com/icons?d=gallery + , menuItemRoute :: SomeRoute UniWorX + , menuItemAccessCallback' :: Handler Bool -- Check whether action is shown in ADDITION to authorization (which is always checked) + , menuItemModal :: Bool + , menuItemType :: MenuType + } + +instance RedirectUrl UniWorX MenuItem where + toTextUrl MenuItem{..} = toTextUrl menuItemRoute +instance HasRoute UniWorX MenuItem where + urlRoute MenuItem{..} = urlRoute menuItemRoute + +menuItemAccessCallback :: MenuItem -> Handler Bool +menuItemAccessCallback MenuItem{..} = (&&) <$> ((==) 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) @@ -702,7 +725,6 @@ siteLayout headingOverride widget = do let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master isModal <- isJust <$> siteModalId - $logDebugS "siteLayout" $ "isModal = " <> tshow isModal mmsgs <- if | isModal -> return [] @@ -718,9 +740,11 @@ siteLayout headingOverride widget = do -- let isParent :: Route UniWorX -> Bool -- isParent r = r == (fst parents) - let menu = defaultLinks ++ maybe [] pageActions mcurrentRoute + defaultLinks' <- defaultLinks + let menu :: [MenuItem] + menu = defaultLinks' ++ maybe [] pageActions mcurrentRoute - menuTypes <- mapM (\x -> (x, ) <$> newIdent) =<< filterM (menuItemAccessCallback . menuItem) menu + menuTypes <- mapM (\x -> (,,) <$> pure x <*> newIdent <*> toTextUrl x) =<< filterM menuItemAccessCallback menu isAuth <- isJust <$> maybeAuthId @@ -737,18 +761,20 @@ siteLayout headingOverride widget = do return course return (favs, userTheme user) favourites <- forM favourites' $ \(Entity _ c@Course{..}) - -> let - courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR - in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute) + -> let courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR + in do + items <- filterM menuItemAccessCallback (pageActions courseRoute) + items' <- forM items $ \i -> (i, ) <$> toTextUrl i + return (c, courseRoute, items') let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority highlight = let crumbs = mcons mcurrentRoute $ fst <$> reverse parents - navItems = map snd3 favourites ++ map (menuItemRoute . menuItem . fst) menuTypes + navItems = map snd3 favourites ++ map (urlRoute . menuItemRoute . view _1) menuTypes highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map snd3 favourites) crumbs in \r -> Just r == highR favouriteTerms :: [TermIdentifier] favouriteTerms = Set.toDescList $ foldMap (\(Course{..}, _, _) -> Set.singleton $ unTermKey courseTerm) favourites - favouriteTerm :: TermIdentifier -> [(Course, Route UniWorX, [MenuTypes])] + favouriteTerm :: TermIdentifier -> [(Course, Route UniWorX, [(MenuItem, Text)])] favouriteTerm tid = filter (\(Course{..}, _, _) -> unTermKey courseTerm == tid) favourites -- We break up the default layout into two components: @@ -770,12 +796,12 @@ siteLayout headingOverride widget = do pageactionprime :: Widget pageactionprime = $(widgetFile "widgets/pageactionprime") -- TODO: rename, since it also shows secondary pageActions now -- functions to determine if there are page-actions (primary or secondary) - isPageActionPrime :: MenuTypes -> Bool - isPageActionPrime (PageActionPrime _) = True - isPageActionPrime (PageActionSecondary _) = True - isPageActionPrime _ = False + isPageAction :: MenuType -> Bool + isPageAction PageActionPrime = True + isPageAction PageActionSecondary = True + isPageAction _ = False hasPageActions :: Bool - hasPageActions = any (isPageActionPrime . fst) menuTypes + hasPageActions = any (isPageAction . menuItemType . view _1) menuTypes pc <- widgetToPageContent $ do addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900|Roboto:300,400,600" @@ -892,82 +918,95 @@ submissionList tid csh shn uid = E.select . E.from $ \(course `E.InnerJoin` shee -defaultLinks :: [MenuTypes] -defaultLinks = -- Define the menu items of the header. - [ NavbarAside $ MenuItem - { menuItemLabel = "Home" +defaultLinks :: (MonadHandler m, HandlerSite m ~ UniWorX) => m [MenuItem] +defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the header. + [ return MenuItem + { menuItemType = NavbarAside + , menuItemLabel = MsgMenuHome , menuItemIcon = Just "home" - , menuItemRoute = HomeR + , menuItemRoute = SomeRoute HomeR , menuItemModal = False , menuItemAccessCallback' = return True } - , NavbarRight $ MenuItem - { menuItemLabel = "Impressum" + , return MenuItem + { menuItemType = NavbarRight + , menuItemLabel = MsgMenuVersion , menuItemIcon = Just "book" - , menuItemRoute = VersionR + , menuItemRoute = SomeRoute VersionR , menuItemModal = False , menuItemAccessCallback' = return True } - , NavbarRight $ MenuItem - { menuItemLabel = "Hilfe" - , menuItemIcon = Just "question" - , menuItemRoute = HelpR - , menuItemModal = True -- TODO: Does not work yet, issue #212 - , menuItemAccessCallback' = return True - } - , NavbarRight $ MenuItem - { menuItemLabel = "Anpassen" + , do + mCurrentRoute <- getCurrentRoute + + return MenuItem + { menuItemType = NavbarRight + , menuItemLabel = MsgMenuHelp + , menuItemIcon = Just "question" + , menuItemRoute = SomeRoute (HelpR, catMaybes [("site", ) . toPathPiece <$> mCurrentRoute]) + , menuItemModal = True + , menuItemAccessCallback' = return True + } + , return MenuItem + { menuItemType = NavbarRight + , menuItemLabel = MsgMenuProfile , menuItemIcon = Just "cogs" - , menuItemRoute = ProfileR + , menuItemRoute = SomeRoute ProfileR , menuItemModal = False , menuItemAccessCallback' = isJust <$> maybeAuthPair } - , NavbarSecondary $ MenuItem - { menuItemLabel = "Login" + , return MenuItem + { menuItemType = NavbarSecondary + , menuItemLabel = MsgMenuLogin , menuItemIcon = Just "sign-in-alt" - , menuItemRoute = AuthR LoginR - , menuItemModal = True -- TODO: Does not work yet, issue #212 + , menuItemRoute = SomeRoute $ AuthR LoginR + , menuItemModal = True , menuItemAccessCallback' = isNothing <$> maybeAuthPair } - , NavbarSecondary $ MenuItem - { menuItemLabel = "Logout" + , return MenuItem + { menuItemType = NavbarSecondary + , menuItemLabel = MsgMenuLogout , menuItemIcon = Just "sign-out-alt" - , menuItemRoute = AuthR LogoutR + , menuItemRoute = SomeRoute $ AuthR LogoutR , menuItemModal = False , menuItemAccessCallback' = isJust <$> maybeAuthPair } - , NavbarAside $ MenuItem - { menuItemLabel = "Kurse" + , return MenuItem + { menuItemType = NavbarAside + , menuItemLabel = MsgMenuCourseList , menuItemIcon = Just "calendar-alt" - , menuItemRoute = CourseListR + , menuItemRoute = SomeRoute CourseListR , menuItemModal = False , menuItemAccessCallback' = return True } - , NavbarAside $ MenuItem - { menuItemLabel = "Semester" + , return MenuItem + { menuItemType = NavbarAside + , menuItemLabel = MsgMenuTermShow , menuItemIcon = Just "graduation-cap" - , menuItemRoute = TermShowR + , menuItemRoute = SomeRoute TermShowR , menuItemModal = False , menuItemAccessCallback' = return True } - , NavbarAside $ MenuItem - { menuItemLabel = "Korrektur" + , return MenuItem + { menuItemType = NavbarAside + , menuItemLabel = MsgMenuCorrections , menuItemIcon = Just "check" - , menuItemRoute = CorrectionsR + , menuItemRoute = SomeRoute CorrectionsR , menuItemModal = False , menuItemAccessCallback' = return True } - , NavbarAside $ MenuItem - { menuItemLabel = "Benutzer" + , return MenuItem + { menuItemType = NavbarAside + , menuItemLabel = MsgMenuUsers , menuItemIcon = Just "users" - , menuItemRoute = UsersR + , menuItemRoute = SomeRoute UsersR , menuItemModal = False , menuItemAccessCallback' = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False } ] -pageActions :: Route UniWorX -> [MenuTypes] +pageActions :: Route UniWorX -> [MenuItem] {- Icons: https://fontawesome.com/icons?d=gallery Guideline: use icons without boxes/frames, only non-pro @@ -983,76 +1022,85 @@ pageActions (HomeR) = -- , menuItemAccessCallback' = return True -- } -- , - PageActionPrime $ MenuItem - { menuItemLabel = "Admin-Demo" + MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuAdminTest , menuItemIcon = Just "screwdriver" - , menuItemRoute = AdminTestR + , menuItemRoute = SomeRoute AdminTestR , menuItemModal = False , menuItemAccessCallback' = return True } - , PageActionPrime $ MenuItem - { menuItemLabel = "System-Nachrichten" + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuMessageList , menuItemIcon = Nothing - , menuItemRoute = MessageListR + , menuItemRoute = SomeRoute MessageListR , menuItemModal = False , menuItemAccessCallback' = return True } - , PageActionPrime $ MenuItem - { menuItemLabel = "Fehlermeldung entschlüsseln" + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuAdminErrMsg , menuItemIcon = Nothing - , menuItemRoute = AdminErrMsgR + , menuItemRoute = SomeRoute AdminErrMsgR , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (ProfileR) = - [ PageActionPrime $ MenuItem - { menuItemLabel = "Gespeicherte Daten" + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuProfileData , menuItemIcon = Just "book" - , menuItemRoute = ProfileDataR + , menuItemRoute = SomeRoute ProfileDataR , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions TermShowR = - [ PageActionPrime $ MenuItem - { menuItemLabel = "Neues Semester anlegen" + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuTermCreate , menuItemIcon = Nothing - , menuItemRoute = TermEditR + , menuItemRoute = SomeRoute TermEditR , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (TermCourseListR tid) = - [ PageActionPrime $ MenuItem - { menuItemLabel = "Neuen Kurs anlegen" + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuCourseNew , menuItemIcon = Just "book" - , menuItemRoute = CourseNewR + , menuItemRoute = SomeRoute CourseNewR , menuItemModal = False , menuItemAccessCallback' = return True } - , PageActionPrime $ MenuItem - { menuItemLabel = "Semster editieren" + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuTermEdit , menuItemIcon = Nothing - , menuItemRoute = TermEditExistR tid + , menuItemRoute = SomeRoute $ TermEditExistR tid , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (CourseListR) = - [ PageActionPrime $ MenuItem - { menuItemLabel = "Neuen Kurs anlegen" + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuCourseNew , menuItemIcon = Just "book" - , menuItemRoute = CourseNewR + , menuItemRoute = SomeRoute CourseNewR , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (CourseR tid ssh csh CShowR) = - [ PageActionPrime $ MenuItem - { menuItemLabel = "Übungsblätter" + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuSheetList , menuItemIcon = Nothing - , menuItemRoute = CourseR tid ssh csh SheetListR + , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetListR , menuItemModal = False , menuItemAccessCallback' = do --TODO always show for lecturer let sheetRouteAccess shn = (== Authorized) <$> (isAuthorized (CSheetR tid ssh csh shn SShowR) False) @@ -1066,49 +1114,55 @@ pageActions (CourseR tid ssh csh CShowR) = return (sheets,lecturer) or2M (return lecturer) $ anyM sheets sheetRouteAccess } - , PageActionPrime $ MenuItem - { menuItemLabel = "Abgaben" + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuCorrections , menuItemIcon = Nothing - , menuItemRoute = CourseR tid ssh csh CCorrectionsR + , menuItemRoute = SomeRoute $ CourseR tid ssh csh CCorrectionsR , menuItemModal = False , menuItemAccessCallback' = return True } - , PageActionPrime $ MenuItem - { menuItemLabel = "Neues Übungsblatt anlegen" + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuSheetNew , menuItemIcon = Nothing - , menuItemRoute = CourseR tid ssh csh SheetNewR + , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetNewR , menuItemModal = False , menuItemAccessCallback' = return True } - , PageActionSecondary $ MenuItem - { menuItemLabel = "Kurs editieren" + , MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuCourseEdit , menuItemIcon = Nothing - , menuItemRoute = CourseR tid ssh csh CEditR + , menuItemRoute = SomeRoute $ CourseR tid ssh csh CEditR , menuItemModal = False , menuItemAccessCallback' = return True } - , PageActionSecondary $ MenuItem - { menuItemLabel = "Neuen Kurs klonen" + , MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuCourseNewTemplate , menuItemIcon = Nothing - , menuItemRoute = CourseNewTemplateR (Just tid) (Just ssh) (Just csh) + , menuItemRoute = SomeRoute $ CourseNewTemplateR (Just tid) (Just ssh) (Just csh) , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (CourseR tid ssh csh SheetListR) = - [ PageActionPrime $ MenuItem - { menuItemLabel = "Neues Übungsblatt anlegen" + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuSheetNew , menuItemIcon = Nothing - , menuItemRoute = CourseR tid ssh csh SheetNewR + , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetNewR , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (CSheetR tid ssh csh shn SShowR) = - [ PageActionPrime $ MenuItem - { menuItemLabel = "Abgabe anlegen" + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuSubmissionNew , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid ssh csh shn SubmissionNewR + , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR , menuItemModal = True , menuItemAccessCallback' = runDB . maybeT (return False) $ do uid <- MaybeT $ liftHandlerT maybeAuthId @@ -1116,10 +1170,11 @@ pageActions (CSheetR tid ssh csh shn SShowR) = guard $ null submissions return True } - , PageActionPrime $ MenuItem - { menuItemLabel = "Abgabe ansehen" + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuSubmissionOwn , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid ssh csh shn SubmissionOwnR + , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionOwnR , menuItemModal = False , menuItemAccessCallback' = runDB . maybeT (return False) $ do uid <- MaybeT $ liftHandlerT maybeAuthId @@ -1127,74 +1182,83 @@ pageActions (CSheetR tid ssh csh shn SShowR) = guard . not $ null submissions return True } - , PageActionPrime $ MenuItem - { menuItemLabel = "Korrektoren" + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuCorrectors , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid ssh csh shn SCorrR + , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SCorrR , menuItemModal = False , menuItemAccessCallback' = return True } - , PageActionPrime $ MenuItem - { menuItemLabel = "Abgaben" + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuCorrections , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid ssh csh shn SSubsR + , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SSubsR , menuItemModal = False , menuItemAccessCallback' = return True } - , PageActionPrime $ MenuItem - { menuItemLabel = "Blatt Editieren" + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuSheetEdit , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid ssh csh shn SEditR + , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SEditR , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (CSheetR tid ssh csh shn SSubsR) = - [ PageActionPrime $ MenuItem - { menuItemLabel = "Korrektoren" + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuCorrectors , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid ssh csh shn SCorrR + , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SCorrR , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = - [ PageActionPrime $ MenuItem - { menuItemLabel = "Korrektur" + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuCorrection , menuItemIcon = Nothing - , menuItemRoute = CSubmissionR tid ssh csh shn cid CorrectionR + , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (CSheetR tid ssh csh shn SCorrR) = - [ PageActionPrime $ MenuItem - { menuItemLabel = "Abgaben" + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuCorrections , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid ssh csh shn SSubsR + , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SSubsR , menuItemModal = False , menuItemAccessCallback' = return True } - , PageActionSecondary $ MenuItem - { menuItemLabel = "Edit " <> (CI.original shn) + , MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuSheetEdit , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid ssh csh shn SEditR + , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SEditR , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (CorrectionsR) = - [ PageActionPrime $ MenuItem - { menuItemLabel = "Korrekturen hochladen" + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuCorrectionsUpload , menuItemIcon = Nothing - , menuItemRoute = CorrectionsUploadR + , menuItemRoute = SomeRoute CorrectionsUploadR , menuItemModal = True , menuItemAccessCallback' = return True } - , PageActionPrime $ MenuItem - { menuItemLabel = "Abgaben erstellen" + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuCorrectionsCreate , menuItemIcon = Nothing - , menuItemRoute = CorrectionsCreateR + , menuItemRoute = SomeRoute CorrectionsCreateR , menuItemModal = True , menuItemAccessCallback' = runDB $ do uid <- liftHandlerT requireAuthId @@ -1205,26 +1269,29 @@ pageActions (CorrectionsR) = return E.countRows return $ (corrCount :: Int) /= 0 } - , PageActionPrime $ MenuItem - { menuItemLabel = "Korrekturen eintragen" + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuCorrectionsGrade , menuItemIcon = Nothing - , menuItemRoute = CorrectionsGradeR + , menuItemRoute = SomeRoute CorrectionsGradeR , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (CorrectionsGradeR) = - [ PageActionPrime $ MenuItem - { menuItemLabel = "Korrekturen hochladen" + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuCorrectionsUpload , menuItemIcon = Nothing - , menuItemRoute = CorrectionsUploadR + , menuItemRoute = SomeRoute CorrectionsUploadR , menuItemModal = True , menuItemAccessCallback' = return True } - , PageActionPrime $ MenuItem - { menuItemLabel = "Abgaben erstellen" + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuCorrectionsCreate , menuItemIcon = Nothing - , menuItemRoute = CorrectionsCreateR + , menuItemRoute = SomeRoute CorrectionsCreateR , menuItemModal = True , menuItemAccessCallback' = runDB $ do uid <- liftHandlerT requireAuthId diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 32e0f0ec9..e80ff8b64 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -6,12 +6,9 @@ import Handler.Utils import qualified Data.Map as Map import qualified Data.Text as Text -import Data.Text.Encoding (decodeUtf8') import Data.Time hiding (formatTime) import Data.Universe.Helpers -import Network.Wai (requestHeaderReferer) - -- import qualified Data.Text as T -- import Yesod.Form.Bootstrap3 @@ -244,14 +241,14 @@ instance RenderMessage UniWorX HelpIdentOptions where HIAnonymous -> MsgHelpAnonymous data HelpForm = HelpForm - { hfReferer:: Maybe Text + { hfReferer:: Maybe (Route UniWorX) , hfUserId :: Either (Maybe Address) UserId , hfRequest:: Text } -helpForm :: Maybe Text -> Maybe UserId -> AForm _ HelpForm +helpForm :: Maybe (Route UniWorX) -> Maybe UserId -> AForm _ HelpForm helpForm mReferer mUid = HelpForm - <$> maybe (pure Nothing) (fmap Just . aforced textField (fslI MsgHelpProblemPage)) mReferer + <$> aopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer) <*> multiActionA (fslI MsgHelpAnswer) identActions (HIUser <$ mUid) <*> (unTextarea <$> areq textareaField (fslI MsgHelpRequest) Nothing) <* submitButton @@ -270,19 +267,19 @@ getHelpR, postHelpR :: Handler Html getHelpR = postHelpR postHelpR = do mUid <- maybeAuthId - mRefererBS <- requestHeaderReferer <$> waiRequest - let mReferer = maybeRight . decodeUtf8' =<< mRefererBS + mReferer <- flip formResultMaybe return <=< runInputGetResult $ iopt routeField "site" ((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mReferer mUid case res of FormSuccess HelpForm{..} -> do now <- liftIO getCurrentTime + hfReferer' <- traverse toTextUrl hfReferer queueJob' JobHelpRequest { jSender = hfUserId , jHelpRequest = hfRequest , jRequestTime = now - , jReferer = hfReferer + , jReferer = hfReferer' } -- redirect $ HelpR addMessageI Success MsgHelpSent diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 4e23e11c4..e4a32bb81 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -159,6 +159,11 @@ buttonForm csrf = do -- ciField moved to Utils.Form +routeField :: ( Monad m + , HandlerSite m ~ UniWorX + ) => Field m (Route UniWorX) +routeField = checkMMap (return . maybe (Left MsgInvalidRoute) Right . fromPathPiece) toPathPiece textField + natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i natFieldI msg = checkBool (>= 0) msg intField diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 53591adab..49255b941 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -45,6 +45,7 @@ import Control.Monad.Morph as Import (MFunctor(..)) import Control.Monad.Trans.Resource as Import (ReleaseKey) import Network.Mail.Mime.Instances as Import () +import Yesod.Core.Instances as Import () import Control.Monad.Trans.RWS (RWST) diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 0781e2fd3..f5d950fd4 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -137,6 +137,12 @@ addDatalist mValues field = field noValidate :: FieldSettings site -> FieldSettings site noValidate = addAttr "formnovalidate" "" +inputDisabled :: FieldSettings site -> FieldSettings site +inputDisabled = addAttr "disabled" "" + +inputReadonly :: FieldSettings site -> FieldSettings site +inputReadonly = addAttr "readonly" "" + ------------------------------------------------ -- Unique Form Identifiers to avoid accidents -- ------------------------------------------------ diff --git a/src/Yesod/Core/Instances.hs b/src/Yesod/Core/Instances.hs new file mode 100644 index 000000000..85579cc5e --- /dev/null +++ b/src/Yesod/Core/Instances.hs @@ -0,0 +1,34 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Yesod.Core.Instances + ( + ) where + +import ClassyPrelude.Yesod + +import Utils (assertM') +import Control.Lens + +import Data.ByteString.Builder (toLazyByteString) + +import System.FilePath (()) + + +instance (RenderRoute site, ParseRoute site) => PathPiece (Route site) where + fromPathPiece + = parseRoute + . over (_2.traverse._2) (fromMaybe "") + . over _2 queryToQueryText + . decodePath + . encodeUtf8 + toPathPiece + = pack + . ("/" ) + . unpack + . decodeUtf8 + . toLazyByteString + . uncurry encodePath + . over _2 queryTextToQuery + . over (_2.traverse._2) (assertM' $ not . null) + . renderRoute + diff --git a/templates/standalone/modal.julius b/templates/standalone/modal.julius index b4b96a335..65eb3fef0 100644 --- a/templates/standalone/modal.julius +++ b/templates/standalone/modal.julius @@ -98,7 +98,15 @@ }); } - frame.setAttribute('src', dynamicContentURL + "?" + #{String modalParameter}); + var url = ""; + var i = dynamicContentURL.indexOf('?'); + if (i === -1) { + url = dynamicContentURL + "?" + #{String modalParameter}; + } else { + url = dynamicContentURL.slice(0,i) + "?" + #{String modalParameter} + "&" + dynamicContentURL.slice(i + 1); + } + + frame.setAttribute('src', url); } // tell further modals, that this one already got initialized modal.classList.add('js-modal-initialized'); diff --git a/templates/widgets/asidenav.hamlet b/templates/widgets/asidenav.hamlet index bb5f41407..fe8a7e8f5 100644 --- a/templates/widgets/asidenav.hamlet +++ b/templates/widgets/asidenav.hamlet @@ -12,9 +12,9 @@ $newline never
#{courseShorthand}
#{courseName}