i18n MenuItems & Semantic support-referer

Addresses #228
This commit is contained in:
Gregor Kleen 2018-11-09 22:43:45 +01:00
parent b9afc667fe
commit 7bf3a52599
11 changed files with 352 additions and 202 deletions

View File

@ -483,4 +483,36 @@ ErrMsgInvalidBase64 base64Err@String: Verschlüsselte Daten nicht korrekt base64
ErrMsgCouldNotDecodeNonce: Konnte secretbox-nonce nicht dekodieren ErrMsgCouldNotDecodeNonce: Konnte secretbox-nonce nicht dekodieren
ErrMsgCouldNotOpenSecretbox: Konnte libsodium-secretbox nicht öffnen (Verschlüsselte Daten sind nicht authentisch) ErrMsgCouldNotOpenSecretbox: Konnte libsodium-secretbox nicht öffnen (Verschlüsselte Daten sind nicht authentisch)
ErrMsgCouldNotDecodePlaintext utf8Err@Text: Konnte Klartext nicht UTF8-dekodieren: #{utf8Err} ErrMsgCouldNotDecodePlaintext utf8Err@Text: Konnte Klartext nicht UTF8-dekodieren: #{utf8Err}
ErrMsgHeading: Fehlermeldung entschlüsseln 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

View File

@ -146,28 +146,6 @@ pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Cr
pattern CSubmissionR tid ssh csh shn cid ptn pattern CSubmissionR tid ssh csh shn cid ptn
= CSheetR tid ssh csh shn (SubmissionR 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 -- Messages
mkMessage "UniWorX" "messages/uniworx" "de" mkMessage "UniWorX" "messages/uniworx" "de"
mkMessageVariant "UniWorX" "Campus" "messages/campus" "de" mkMessageVariant "UniWorX" "Campus" "messages/campus" "de"
@ -238,6 +216,51 @@ newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse
embedRenderMessageVariant ''UniWorX ''ErrorResponseTitle ("ErrorResponseTitle" <>) 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 data instance ButtonCssClass UniWorX = BCDefault | BCPrimary | BCSuccess | BCInfo | BCWarning | BCDanger | BCLink
deriving (Enum, Eq, Ord, Bounded, Read, Show) deriving (Enum, Eq, Ord, Bounded, Read, Show)
@ -702,7 +725,6 @@ siteLayout headingOverride widget = do
let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master
isModal <- isJust <$> siteModalId isModal <- isJust <$> siteModalId
$logDebugS "siteLayout" $ "isModal = " <> tshow isModal
mmsgs <- if mmsgs <- if
| isModal -> return [] | isModal -> return []
@ -718,9 +740,11 @@ siteLayout headingOverride widget = do
-- let isParent :: Route UniWorX -> Bool -- let isParent :: Route UniWorX -> Bool
-- isParent r = r == (fst parents) -- 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 isAuth <- isJust <$> maybeAuthId
@ -737,18 +761,20 @@ siteLayout headingOverride widget = do
return course return course
return (favs, userTheme user) return (favs, userTheme user)
favourites <- forM favourites' $ \(Entity _ c@Course{..}) favourites <- forM favourites' $ \(Entity _ c@Course{..})
-> let -> let courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR
courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR in do
in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute) 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 let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority
highlight = let crumbs = mcons mcurrentRoute $ fst <$> reverse parents 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 highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map snd3 favourites) crumbs
in \r -> Just r == highR in \r -> Just r == highR
favouriteTerms :: [TermIdentifier] favouriteTerms :: [TermIdentifier]
favouriteTerms = Set.toDescList $ foldMap (\(Course{..}, _, _) -> Set.singleton $ unTermKey courseTerm) favourites 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 favouriteTerm tid = filter (\(Course{..}, _, _) -> unTermKey courseTerm == tid) favourites
-- We break up the default layout into two components: -- We break up the default layout into two components:
@ -770,12 +796,12 @@ siteLayout headingOverride widget = do
pageactionprime :: Widget pageactionprime :: Widget
pageactionprime = $(widgetFile "widgets/pageactionprime") -- TODO: rename, since it also shows secondary pageActions now pageactionprime = $(widgetFile "widgets/pageactionprime") -- TODO: rename, since it also shows secondary pageActions now
-- functions to determine if there are page-actions (primary or secondary) -- functions to determine if there are page-actions (primary or secondary)
isPageActionPrime :: MenuTypes -> Bool isPageAction :: MenuType -> Bool
isPageActionPrime (PageActionPrime _) = True isPageAction PageActionPrime = True
isPageActionPrime (PageActionSecondary _) = True isPageAction PageActionSecondary = True
isPageActionPrime _ = False isPageAction _ = False
hasPageActions :: Bool hasPageActions :: Bool
hasPageActions = any (isPageActionPrime . fst) menuTypes hasPageActions = any (isPageAction . menuItemType . view _1) menuTypes
pc <- widgetToPageContent $ do pc <- widgetToPageContent $ do
addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900|Roboto:300,400,600" 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 :: (MonadHandler m, HandlerSite m ~ UniWorX) => m [MenuItem]
defaultLinks = -- Define the menu items of the header. defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the header.
[ NavbarAside $ MenuItem [ return MenuItem
{ menuItemLabel = "Home" { menuItemType = NavbarAside
, menuItemLabel = MsgMenuHome
, menuItemIcon = Just "home" , menuItemIcon = Just "home"
, menuItemRoute = HomeR , menuItemRoute = SomeRoute HomeR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, NavbarRight $ MenuItem , return MenuItem
{ menuItemLabel = "Impressum" { menuItemType = NavbarRight
, menuItemLabel = MsgMenuVersion
, menuItemIcon = Just "book" , menuItemIcon = Just "book"
, menuItemRoute = VersionR , menuItemRoute = SomeRoute VersionR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, NavbarRight $ MenuItem , do
{ menuItemLabel = "Hilfe" mCurrentRoute <- getCurrentRoute
, menuItemIcon = Just "question"
, menuItemRoute = HelpR return MenuItem
, menuItemModal = True -- TODO: Does not work yet, issue #212 { menuItemType = NavbarRight
, menuItemAccessCallback' = return True , menuItemLabel = MsgMenuHelp
} , menuItemIcon = Just "question"
, NavbarRight $ MenuItem , menuItemRoute = SomeRoute (HelpR, catMaybes [("site", ) . toPathPiece <$> mCurrentRoute])
{ menuItemLabel = "Anpassen" , menuItemModal = True
, menuItemAccessCallback' = return True
}
, return MenuItem
{ menuItemType = NavbarRight
, menuItemLabel = MsgMenuProfile
, menuItemIcon = Just "cogs" , menuItemIcon = Just "cogs"
, menuItemRoute = ProfileR , menuItemRoute = SomeRoute ProfileR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = isJust <$> maybeAuthPair , menuItemAccessCallback' = isJust <$> maybeAuthPair
} }
, NavbarSecondary $ MenuItem , return MenuItem
{ menuItemLabel = "Login" { menuItemType = NavbarSecondary
, menuItemLabel = MsgMenuLogin
, menuItemIcon = Just "sign-in-alt" , menuItemIcon = Just "sign-in-alt"
, menuItemRoute = AuthR LoginR , menuItemRoute = SomeRoute $ AuthR LoginR
, menuItemModal = True -- TODO: Does not work yet, issue #212 , menuItemModal = True
, menuItemAccessCallback' = isNothing <$> maybeAuthPair , menuItemAccessCallback' = isNothing <$> maybeAuthPair
} }
, NavbarSecondary $ MenuItem , return MenuItem
{ menuItemLabel = "Logout" { menuItemType = NavbarSecondary
, menuItemLabel = MsgMenuLogout
, menuItemIcon = Just "sign-out-alt" , menuItemIcon = Just "sign-out-alt"
, menuItemRoute = AuthR LogoutR , menuItemRoute = SomeRoute $ AuthR LogoutR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = isJust <$> maybeAuthPair , menuItemAccessCallback' = isJust <$> maybeAuthPair
} }
, NavbarAside $ MenuItem , return MenuItem
{ menuItemLabel = "Kurse" { menuItemType = NavbarAside
, menuItemLabel = MsgMenuCourseList
, menuItemIcon = Just "calendar-alt" , menuItemIcon = Just "calendar-alt"
, menuItemRoute = CourseListR , menuItemRoute = SomeRoute CourseListR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, NavbarAside $ MenuItem , return MenuItem
{ menuItemLabel = "Semester" { menuItemType = NavbarAside
, menuItemLabel = MsgMenuTermShow
, menuItemIcon = Just "graduation-cap" , menuItemIcon = Just "graduation-cap"
, menuItemRoute = TermShowR , menuItemRoute = SomeRoute TermShowR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, NavbarAside $ MenuItem , return MenuItem
{ menuItemLabel = "Korrektur" { menuItemType = NavbarAside
, menuItemLabel = MsgMenuCorrections
, menuItemIcon = Just "check" , menuItemIcon = Just "check"
, menuItemRoute = CorrectionsR , menuItemRoute = SomeRoute CorrectionsR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, NavbarAside $ MenuItem , return MenuItem
{ menuItemLabel = "Benutzer" { menuItemType = NavbarAside
, menuItemLabel = MsgMenuUsers
, menuItemIcon = Just "users" , menuItemIcon = Just "users"
, menuItemRoute = UsersR , menuItemRoute = SomeRoute UsersR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR 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 Icons: https://fontawesome.com/icons?d=gallery
Guideline: use icons without boxes/frames, only non-pro Guideline: use icons without boxes/frames, only non-pro
@ -983,76 +1022,85 @@ pageActions (HomeR) =
-- , menuItemAccessCallback' = return True -- , menuItemAccessCallback' = return True
-- } -- }
-- , -- ,
PageActionPrime $ MenuItem MenuItem
{ menuItemLabel = "Admin-Demo" { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuAdminTest
, menuItemIcon = Just "screwdriver" , menuItemIcon = Just "screwdriver"
, menuItemRoute = AdminTestR , menuItemRoute = SomeRoute AdminTestR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, PageActionPrime $ MenuItem , MenuItem
{ menuItemLabel = "System-Nachrichten" { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuMessageList
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = MessageListR , menuItemRoute = SomeRoute MessageListR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, PageActionPrime $ MenuItem , MenuItem
{ menuItemLabel = "Fehlermeldung entschlüsseln" { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuAdminErrMsg
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = AdminErrMsgR , menuItemRoute = SomeRoute AdminErrMsgR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (ProfileR) = pageActions (ProfileR) =
[ PageActionPrime $ MenuItem [ MenuItem
{ menuItemLabel = "Gespeicherte Daten" { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuProfileData
, menuItemIcon = Just "book" , menuItemIcon = Just "book"
, menuItemRoute = ProfileDataR , menuItemRoute = SomeRoute ProfileDataR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions TermShowR = pageActions TermShowR =
[ PageActionPrime $ MenuItem [ MenuItem
{ menuItemLabel = "Neues Semester anlegen" { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuTermCreate
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = TermEditR , menuItemRoute = SomeRoute TermEditR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (TermCourseListR tid) = pageActions (TermCourseListR tid) =
[ PageActionPrime $ MenuItem [ MenuItem
{ menuItemLabel = "Neuen Kurs anlegen" { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCourseNew
, menuItemIcon = Just "book" , menuItemIcon = Just "book"
, menuItemRoute = CourseNewR , menuItemRoute = SomeRoute CourseNewR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, PageActionPrime $ MenuItem , MenuItem
{ menuItemLabel = "Semster editieren" { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuTermEdit
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = TermEditExistR tid , menuItemRoute = SomeRoute $ TermEditExistR tid
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (CourseListR) = pageActions (CourseListR) =
[ PageActionPrime $ MenuItem [ MenuItem
{ menuItemLabel = "Neuen Kurs anlegen" { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCourseNew
, menuItemIcon = Just "book" , menuItemIcon = Just "book"
, menuItemRoute = CourseNewR , menuItemRoute = SomeRoute CourseNewR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (CourseR tid ssh csh CShowR) = pageActions (CourseR tid ssh csh CShowR) =
[ PageActionPrime $ MenuItem [ MenuItem
{ menuItemLabel = "Übungsblätter" { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSheetList
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CourseR tid ssh csh SheetListR , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetListR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = do --TODO always show for lecturer , menuItemAccessCallback' = do --TODO always show for lecturer
let sheetRouteAccess shn = (== Authorized) <$> (isAuthorized (CSheetR tid ssh csh shn SShowR) False) 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) return (sheets,lecturer)
or2M (return lecturer) $ anyM sheets sheetRouteAccess or2M (return lecturer) $ anyM sheets sheetRouteAccess
} }
, PageActionPrime $ MenuItem , MenuItem
{ menuItemLabel = "Abgaben" { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrections
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CourseR tid ssh csh CCorrectionsR , menuItemRoute = SomeRoute $ CourseR tid ssh csh CCorrectionsR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, PageActionPrime $ MenuItem , MenuItem
{ menuItemLabel = "Neues Übungsblatt anlegen" { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSheetNew
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CourseR tid ssh csh SheetNewR , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetNewR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, PageActionSecondary $ MenuItem , MenuItem
{ menuItemLabel = "Kurs editieren" { menuItemType = PageActionSecondary
, menuItemLabel = MsgMenuCourseEdit
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CourseR tid ssh csh CEditR , menuItemRoute = SomeRoute $ CourseR tid ssh csh CEditR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, PageActionSecondary $ MenuItem , MenuItem
{ menuItemLabel = "Neuen Kurs klonen" { menuItemType = PageActionSecondary
, menuItemLabel = MsgMenuCourseNewTemplate
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CourseNewTemplateR (Just tid) (Just ssh) (Just csh) , menuItemRoute = SomeRoute $ CourseNewTemplateR (Just tid) (Just ssh) (Just csh)
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (CourseR tid ssh csh SheetListR) = pageActions (CourseR tid ssh csh SheetListR) =
[ PageActionPrime $ MenuItem [ MenuItem
{ menuItemLabel = "Neues Übungsblatt anlegen" { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSheetNew
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CourseR tid ssh csh SheetNewR , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetNewR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (CSheetR tid ssh csh shn SShowR) = pageActions (CSheetR tid ssh csh shn SShowR) =
[ PageActionPrime $ MenuItem [ MenuItem
{ menuItemLabel = "Abgabe anlegen" { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSubmissionNew
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSheetR tid ssh csh shn SubmissionNewR , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR
, menuItemModal = True , menuItemModal = True
, menuItemAccessCallback' = runDB . maybeT (return False) $ do , menuItemAccessCallback' = runDB . maybeT (return False) $ do
uid <- MaybeT $ liftHandlerT maybeAuthId uid <- MaybeT $ liftHandlerT maybeAuthId
@ -1116,10 +1170,11 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
guard $ null submissions guard $ null submissions
return True return True
} }
, PageActionPrime $ MenuItem , MenuItem
{ menuItemLabel = "Abgabe ansehen" { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSubmissionOwn
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSheetR tid ssh csh shn SubmissionOwnR , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionOwnR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = runDB . maybeT (return False) $ do , menuItemAccessCallback' = runDB . maybeT (return False) $ do
uid <- MaybeT $ liftHandlerT maybeAuthId uid <- MaybeT $ liftHandlerT maybeAuthId
@ -1127,74 +1182,83 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
guard . not $ null submissions guard . not $ null submissions
return True return True
} }
, PageActionPrime $ MenuItem , MenuItem
{ menuItemLabel = "Korrektoren" { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrectors
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSheetR tid ssh csh shn SCorrR , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SCorrR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, PageActionPrime $ MenuItem , MenuItem
{ menuItemLabel = "Abgaben" { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrections
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSheetR tid ssh csh shn SSubsR , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SSubsR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, PageActionPrime $ MenuItem , MenuItem
{ menuItemLabel = "Blatt Editieren" { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSheetEdit
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSheetR tid ssh csh shn SEditR , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SEditR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (CSheetR tid ssh csh shn SSubsR) = pageActions (CSheetR tid ssh csh shn SSubsR) =
[ PageActionPrime $ MenuItem [ MenuItem
{ menuItemLabel = "Korrektoren" { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrectors
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSheetR tid ssh csh shn SCorrR , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SCorrR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
[ PageActionPrime $ MenuItem [ MenuItem
{ menuItemLabel = "Korrektur" { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrection
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSubmissionR tid ssh csh shn cid CorrectionR , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (CSheetR tid ssh csh shn SCorrR) = pageActions (CSheetR tid ssh csh shn SCorrR) =
[ PageActionPrime $ MenuItem [ MenuItem
{ menuItemLabel = "Abgaben" { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrections
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSheetR tid ssh csh shn SSubsR , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SSubsR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, PageActionSecondary $ MenuItem , MenuItem
{ menuItemLabel = "Edit " <> (CI.original shn) { menuItemType = PageActionSecondary
, menuItemLabel = MsgMenuSheetEdit
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSheetR tid ssh csh shn SEditR , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SEditR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (CorrectionsR) = pageActions (CorrectionsR) =
[ PageActionPrime $ MenuItem [ MenuItem
{ menuItemLabel = "Korrekturen hochladen" { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrectionsUpload
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CorrectionsUploadR , menuItemRoute = SomeRoute CorrectionsUploadR
, menuItemModal = True , menuItemModal = True
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, PageActionPrime $ MenuItem , MenuItem
{ menuItemLabel = "Abgaben erstellen" { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrectionsCreate
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CorrectionsCreateR , menuItemRoute = SomeRoute CorrectionsCreateR
, menuItemModal = True , menuItemModal = True
, menuItemAccessCallback' = runDB $ do , menuItemAccessCallback' = runDB $ do
uid <- liftHandlerT requireAuthId uid <- liftHandlerT requireAuthId
@ -1205,26 +1269,29 @@ pageActions (CorrectionsR) =
return E.countRows return E.countRows
return $ (corrCount :: Int) /= 0 return $ (corrCount :: Int) /= 0
} }
, PageActionPrime $ MenuItem , MenuItem
{ menuItemLabel = "Korrekturen eintragen" { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrectionsGrade
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CorrectionsGradeR , menuItemRoute = SomeRoute CorrectionsGradeR
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (CorrectionsGradeR) = pageActions (CorrectionsGradeR) =
[ PageActionPrime $ MenuItem [ MenuItem
{ menuItemLabel = "Korrekturen hochladen" { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrectionsUpload
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CorrectionsUploadR , menuItemRoute = SomeRoute CorrectionsUploadR
, menuItemModal = True , menuItemModal = True
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, PageActionPrime $ MenuItem , MenuItem
{ menuItemLabel = "Abgaben erstellen" { menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrectionsCreate
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CorrectionsCreateR , menuItemRoute = SomeRoute CorrectionsCreateR
, menuItemModal = True , menuItemModal = True
, menuItemAccessCallback' = runDB $ do , menuItemAccessCallback' = runDB $ do
uid <- liftHandlerT requireAuthId uid <- liftHandlerT requireAuthId

View File

@ -6,12 +6,9 @@ import Handler.Utils
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.Text.Encoding (decodeUtf8')
import Data.Time hiding (formatTime) import Data.Time hiding (formatTime)
import Data.Universe.Helpers import Data.Universe.Helpers
import Network.Wai (requestHeaderReferer)
-- import qualified Data.Text as T -- import qualified Data.Text as T
-- import Yesod.Form.Bootstrap3 -- import Yesod.Form.Bootstrap3
@ -244,14 +241,14 @@ instance RenderMessage UniWorX HelpIdentOptions where
HIAnonymous -> MsgHelpAnonymous HIAnonymous -> MsgHelpAnonymous
data HelpForm = HelpForm data HelpForm = HelpForm
{ hfReferer:: Maybe Text { hfReferer:: Maybe (Route UniWorX)
, hfUserId :: Either (Maybe Address) UserId , hfUserId :: Either (Maybe Address) UserId
, hfRequest:: Text , hfRequest:: Text
} }
helpForm :: Maybe Text -> Maybe UserId -> AForm _ HelpForm helpForm :: Maybe (Route UniWorX) -> Maybe UserId -> AForm _ HelpForm
helpForm mReferer mUid = 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) <*> multiActionA (fslI MsgHelpAnswer) identActions (HIUser <$ mUid)
<*> (unTextarea <$> areq textareaField (fslI MsgHelpRequest) Nothing) <*> (unTextarea <$> areq textareaField (fslI MsgHelpRequest) Nothing)
<* submitButton <* submitButton
@ -270,19 +267,19 @@ getHelpR, postHelpR :: Handler Html
getHelpR = postHelpR getHelpR = postHelpR
postHelpR = do postHelpR = do
mUid <- maybeAuthId mUid <- maybeAuthId
mRefererBS <- requestHeaderReferer <$> waiRequest mReferer <- flip formResultMaybe return <=< runInputGetResult $ iopt routeField "site"
let mReferer = maybeRight . decodeUtf8' =<< mRefererBS
((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mReferer mUid ((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mReferer mUid
case res of case res of
FormSuccess HelpForm{..} -> do FormSuccess HelpForm{..} -> do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
hfReferer' <- traverse toTextUrl hfReferer
queueJob' JobHelpRequest queueJob' JobHelpRequest
{ jSender = hfUserId { jSender = hfUserId
, jHelpRequest = hfRequest , jHelpRequest = hfRequest
, jRequestTime = now , jRequestTime = now
, jReferer = hfReferer , jReferer = hfReferer'
} }
-- redirect $ HelpR -- redirect $ HelpR
addMessageI Success MsgHelpSent addMessageI Success MsgHelpSent

View File

@ -159,6 +159,11 @@ buttonForm csrf = do
-- ciField moved to Utils.Form -- 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 :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
natFieldI msg = checkBool (>= 0) msg intField natFieldI msg = checkBool (>= 0) msg intField

View File

@ -45,6 +45,7 @@ import Control.Monad.Morph as Import (MFunctor(..))
import Control.Monad.Trans.Resource as Import (ReleaseKey) import Control.Monad.Trans.Resource as Import (ReleaseKey)
import Network.Mail.Mime.Instances as Import () import Network.Mail.Mime.Instances as Import ()
import Yesod.Core.Instances as Import ()
import Control.Monad.Trans.RWS (RWST) import Control.Monad.Trans.RWS (RWST)

View File

@ -137,6 +137,12 @@ addDatalist mValues field = field
noValidate :: FieldSettings site -> FieldSettings site noValidate :: FieldSettings site -> FieldSettings site
noValidate = addAttr "formnovalidate" "" 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 -- -- Unique Form Identifiers to avoid accidents --
------------------------------------------------ ------------------------------------------------

View File

@ -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

View File

@ -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 // tell further modals, that this one already got initialized
modal.classList.add('js-modal-initialized'); modal.classList.add('js-modal-initialized');

View File

@ -12,9 +12,9 @@ $newline never
<div .asidenav__link-shorthand>#{courseShorthand} <div .asidenav__link-shorthand>#{courseShorthand}
<div .asidenav__link-label>#{courseName} <div .asidenav__link-label>#{courseName}
<ul .asidenav__nested-list.list--iconless> <ul .asidenav__nested-list.list--iconless>
$forall action <- pageActions $forall (MenuItem{menuItemType, menuItemLabel}, route) <- pageActions
$case action $case menuItemType
$of PageActionPrime (MenuItem{menuItemRoute, menuItemLabel}) $of PageActionPrime
<li .asidenav__nested-list-item> <li .asidenav__nested-list-item>
<a .asidenav__link-wrapper href=@{menuItemRoute}>#{menuItemLabel} <a .asidenav__link-wrapper href=#{route}>_{menuItemLabel}
$of _ $of _

View File

@ -12,34 +12,34 @@ $newline never
<i .fas.fa-star> <i .fas.fa-star>
<div .navbar__link-label> Favorites <div .navbar__link-label> Favorites
$forall (menuType, menuIdent) <- menuTypes $forall (MenuItem{menuItemType, menuItemRoute, menuItemIcon, menuItemLabel, menuItemModal}, menuIdent, route) <- menuTypes
$case menuType $case menuItemType
$of NavbarAside (MenuItem label mIcon route _ isModal) $of NavbarAside
<li .navbar__list-item :highlight route:.navbar__list-item--active> <li .navbar__list-item :highlight (urlRoute menuItemRoute):.navbar__list-item--active>
$if isModal $if menuItemModal
<div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable=true data-dynamic=True> <div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable=true data-dynamic=True>
<a .navbar__link-wrapper href=@{route} ##{menuIdent}> <a .navbar__link-wrapper href=#{route} ##{menuIdent}>
<i .fas.fa-#{fromMaybe "none" mIcon}> <i .fas.fa-#{fromMaybe "none" menuItemIcon}>
<div .navbar__link-label>#{label} <div .navbar__link-label>_{SomeMessage menuItemLabel}
$of _ $of _
<ul .navbar__list.list--inline> <ul .navbar__list.list--inline>
$forall (menuType, menuIdent) <- menuTypes $forall (MenuItem{menuItemType, menuItemRoute, menuItemIcon, menuItemLabel, menuItemModal}, menuIdent, route) <- menuTypes
$case menuType $case menuItemType
$of NavbarRight (MenuItem label mIcon route _ isModal) $of NavbarRight
<li .navbar__list-item :Just route == mcurrentRoute:.navbar__list-item--active> <li .navbar__list-item :highlight (urlRoute menuItemRoute):.navbar__list-item--active>
$if isModal $if menuItemModal
<div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable=true data-dynamic=True> <div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable=true data-dynamic=True>
<a .navbar__link-wrapper href=@{route} ##{menuIdent}> <a .navbar__link-wrapper href=#{route} ##{menuIdent}>
<i .fas.fa-#{fromMaybe "none" mIcon}> <i .fas.fa-#{fromMaybe "none" menuItemIcon}>
<div .navbar__link-label>#{label} <div .navbar__link-label>_{SomeMessage menuItemLabel}
$of NavbarSecondary (MenuItem label mIcon route _ isModal) $of NavbarSecondary
<li .navbar__list-item.navbar__list-item--secondary :Just route == mcurrentRoute:.navbar__list-item--active> <li .navbar__list-item.navbar__list-item--secondary :highlight (urlRoute menuItemRoute):.navbar__list-item--active>
$if isModal $if menuItemModal
<div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable=true data-dynamic=True> <div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable=true data-dynamic=True>
<a .navbar__link-wrapper href=@{route} ##{menuIdent}> <a .navbar__link-wrapper href=#{route} ##{menuIdent}>
<i .fas.fa-#{fromMaybe "none" mIcon}> <i .fas.fa-#{fromMaybe "none" menuItemIcon}>
<div .navbar__link-label>#{label} <div .navbar__link-label>_{SomeMessage menuItemLabel}
$of _ $of _
<div .navbar__pushdown> <div .navbar__pushdown>

View File

@ -2,16 +2,16 @@ $newline never
$if hasPageActions $if hasPageActions
<div .page-nav-prime> <div .page-nav-prime>
<ul .pagenav__list> <ul .pagenav__list>
$forall (menuType, menuIdent) <- menuTypes $forall (MenuItem{menuItemLabel, menuItemType, menuItemModal}, menuIdent, route) <- menuTypes
$case menuType $case menuItemType
$of PageActionPrime (MenuItem label _mIcon route _callback isModal) $of PageActionPrime
<li .pagenav__list-item> <li .pagenav__list-item>
$if isModal $if menuItemModal
<div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable=true data-dynamic=True> <div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable=true data-dynamic=True>
<a .pagenav__link-wrapper href=@{route} ##{menuIdent}>#{label} <a .pagenav__link-wrapper href=#{route} ##{menuIdent}>_{SomeMessage menuItemLabel}
$of PageActionSecondary (MenuItem label _mIcon route _callback isModal) $of PageActionSecondary
<li .pagenav__list-item> <li .pagenav__list-item>
$if isModal $if menuItemModal
<div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable=true data-dynamic=True> <div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable=true data-dynamic=True>
<a .pagenav__link-wrapper href=@{route} ##{menuIdent}>#{label} <a .pagenav__link-wrapper href=#{route} ##{menuIdent}>_{SomeMessage menuItemLabel}
$of _ $of _