_{MsgErrorResponseEncrypted} +
+ #{formatted}
+ |]
+ | otherwise -> plaintext
+
+ errPage = case err of
+ NotFound -> [whamlet|_{MsgErrorResponseNotFound}|]
+ InternalError err -> encrypted err [whamlet|
#{err}|]
+ InvalidArgs errs -> [whamlet|
+
_{MsgErrorResponseNotAuthenticated}|] + PermissionDenied err -> [whamlet|
#{err}|] + BadMethod method -> [whamlet|
_{MsgErrorResponseBadMethod (decodeUtf8 method)}|] + fmap toTypedContent . siteLayout (Just . toHtml . mr $ ErrorResponseTitle err) $ do + toWidget + [cassius| + .errMsg + white-space: pre-wrap + font-family: monospace + |] + errPage - mcurrentRoute <- getCurrentRoute - - -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance. - (title, parents) <- breadcrumbs - --- let isParent :: Route UniWorX -> Bool --- isParent r = r == (fst parents) - - let menu = defaultLinks ++ maybe [] pageActions mcurrentRoute - - menuTypes <- mapM (\x -> (x, ) <$> newIdent) =<< filterM (menuItemAccessCallback . menuItem) menu - - isAuth <- isJust <$> maybeAuthId - - -- Lookup Favourites & Theme if possible -- TODO: cache this info in a cookie?! - (favourites', currentTheme) <- do - muid <- maybeAuthPair - case muid of - Nothing -> return ([],userDefaultTheme) - (Just (uid,user)) -> do - favs <- runDB $ E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do - E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse) - E.where_ (courseFavourite E.^. CourseFavouriteUser E.==. E.val uid) - E.orderBy [ E.asc $ course E.^. CourseShorthand ] - 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 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 - 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 tid = filter (\(Course{..}, _, _) -> unTermKey courseTerm == tid) favourites - - -- We break up the default layout into two components: - -- default-layout is the contents of the body tag, and - -- default-layout-wrapper is the entire page. Since the final - -- value passed to hamletToRepHtml cannot be a widget, this allows - -- you to use normal widget features in default-layout. - - - let - navbar :: Widget - navbar = $(widgetFile "widgets/navbar") - asidenav :: Widget - asidenav = $(widgetFile "widgets/asidenav") - contentHeadline :: Maybe Widget - contentHeadline = pageHeading =<< mcurrentRoute - breadcrumbs :: Widget - breadcrumbs = $(widgetFile "widgets/breadcrumbs") - 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 - hasPageActions :: Bool - hasPageActions = any (isPageActionPrime . fst) menuTypes - - pc <- widgetToPageContent $ do - addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900|Roboto:300,400,600" - addScript $ StaticR js_zepto_js - addScript $ StaticR js_fetchPolyfill_js - addScript $ StaticR js_urlPolyfill_js - addScript $ StaticR js_featureChecker_js - addScript $ StaticR js_flatpickr_js - addScript $ StaticR js_tabber_js - addStylesheet $ StaticR css_flatpickr_css - addStylesheet $ StaticR css_tabber_css - addStylesheet $ StaticR css_fonts_css - addStylesheet $ StaticR css_fontawesome_css - $(widgetFile "default-layout") - $(widgetFile "standalone/modal") - $(widgetFile "standalone/showHide") - $(widgetFile "standalone/inputs") - $(widgetFile "standalone/tooltip") - $(widgetFile "standalone/tabber") - $(widgetFile "standalone/alerts") - $(widgetFile "standalone/datepicker") - withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") + defaultLayout = siteLayout Nothing -- The page to be redirected to when authentication is required. authRoute _ = Just $ AuthR LoginR @@ -768,6 +680,105 @@ instance Yesod UniWorX where makeLogger = return . appLogger +siteLayout :: Maybe Html -- ^ Optionally override `pageHeading` + -> Widget -> Handler Html +siteLayout headingOverride widget = do + master <- getYesod + let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master + + applySystemMessages + mmsgs <- getMessages + + mcurrentRoute <- getCurrentRoute + + -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance. + (title, parents) <- breadcrumbs + + -- let isParent :: Route UniWorX -> Bool + -- isParent r = r == (fst parents) + + let menu = defaultLinks ++ maybe [] pageActions mcurrentRoute + + menuTypes <- mapM (\x -> (x, ) <$> newIdent) =<< filterM (menuItemAccessCallback . menuItem) menu + + isAuth <- isJust <$> maybeAuthId + + -- Lookup Favourites & Theme if possible -- TODO: cache this info in a cookie?! + (favourites', currentTheme) <- do + muid <- maybeAuthPair + case muid of + Nothing -> return ([],userDefaultTheme) + (Just (uid,user)) -> do + favs <- runDB $ E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do + E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse) + E.where_ (courseFavourite E.^. CourseFavouriteUser E.==. E.val uid) + E.orderBy [ E.asc $ course E.^. CourseShorthand ] + 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 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 + 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 tid = filter (\(Course{..}, _, _) -> unTermKey courseTerm == tid) favourites + + -- We break up the default layout into two components: + -- default-layout is the contents of the body tag, and + -- default-layout-wrapper is the entire page. Since the final + -- value passed to hamletToRepHtml cannot be a widget, this allows + -- you to use normal widget features in default-layout. + + + let + navbar :: Widget + navbar = $(widgetFile "widgets/navbar") + asidenav :: Widget + asidenav = $(widgetFile "widgets/asidenav") + contentHeadline :: Maybe Widget + contentHeadline = (toWidget <$> headingOverride) <|> (pageHeading =<< mcurrentRoute) + breadcrumbs :: Widget + breadcrumbs = $(widgetFile "widgets/breadcrumbs") + 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 + hasPageActions :: Bool + hasPageActions = any (isPageActionPrime . fst) menuTypes + + pc <- widgetToPageContent $ do + addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900|Roboto:300,400,600" + addScript $ StaticR js_zepto_js + addScript $ StaticR js_fetchPolyfill_js + addScript $ StaticR js_urlPolyfill_js + addScript $ StaticR js_featureChecker_js + addScript $ StaticR js_flatpickr_js + addScript $ StaticR js_tabber_js + addStylesheet $ StaticR css_flatpickr_css + addStylesheet $ StaticR css_tabber_css + addStylesheet $ StaticR css_fonts_css + addStylesheet $ StaticR css_fontawesome_css + $(widgetFile "default-layout") + $(widgetFile "standalone/modal") + $(widgetFile "standalone/showHide") + $(widgetFile "standalone/inputs") + $(widgetFile "standalone/tooltip") + $(widgetFile "standalone/tabber") + $(widgetFile "standalone/alerts") + $(widgetFile "standalone/datepicker") + withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") + + applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m () applySystemMessages = liftHandlerT . runDB . runConduit $ selectSource [] [] .| C.mapM_ applyMessage where @@ -949,8 +960,8 @@ pageActions (HomeR) = -- , menuItemAccessCallback' = return True -- } -- , - NavbarAside $ MenuItem - { menuItemLabel = "AdminDemo" + PageActionPrime $ MenuItem + { menuItemLabel = "Admin-Demo" , menuItemIcon = Just "screwdriver" , menuItemRoute = AdminTestR , menuItemModal = False @@ -963,6 +974,13 @@ pageActions (HomeR) = , menuItemModal = False , menuItemAccessCallback' = return True } + , PageActionPrime $ MenuItem + { menuItemLabel = "Fehlermeldung entschlüsseln" + , menuItemIcon = Nothing + , menuItemRoute = AdminErrMsgR + , menuItemModal = False + , menuItemAccessCallback' = return True + } ] pageActions (ProfileR) = [ PageActionPrime $ MenuItem @@ -1210,6 +1228,8 @@ pageHeading (AdminTestR) = Just $ [whamlet|Internal Code Demonstration Page|] pageHeading (AdminUserR _) = Just $ [whamlet|User Display for Admin|] +pageHeading (AdminErrMsgR) + = Just $ i18nHeading MsgErrMsgHeading pageHeading (VersionR) = Just $ i18nHeading MsgImpressumHeading pageHeading (HelpR) diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 1b5c3ae9d..50b1963e7 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -1,20 +1,22 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} - module Handler.Admin where import Import import Handler.Utils import Jobs +import qualified Data.ByteString as BS + +import qualified Crypto.Saltine.Internal.ByteSizes as Saltine +import qualified Data.ByteString.Base64.URL as Base64 +import Crypto.Saltine.Core.SecretBox (secretboxOpen) +import qualified Crypto.Saltine.Class as Saltine + +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Char (isSpace) + +import Control.Monad.Trans.Except + -- import Data.Time -- import qualified Data.Text as T -- import Data.Function ((&)) @@ -105,3 +107,35 @@ getAdminUserR uuid = do
+ #{t}
+
+