From 7df82a10d736cb5414d06ecf1d0bf881c783db8c Mon Sep 17 00:00:00 2001 From: SJost Date: Fri, 9 Nov 2018 15:52:55 +0100 Subject: [PATCH 1/3] Translation for ErrorRatings --- messages/uniworx/de.msg | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 6b9c99c63..564fb43eb 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -275,14 +275,14 @@ RatingDeleted: Korrektur zurückgesetzt RatingFilesUpdated: Korrigierte Dateien überschrieben RatingNotUnicode uexc@UnicodeException: Bewertungsdatei nicht in UTF-8 kodiert: #{tshow uexc} -RatingMissingSeparator: Could not split rating header from comments -RatingMultiple: Encountered multiple point values in rating -RatingInvalid parseErr@String: Failed to parse rating point value #{parseErr} -RatingFileIsDirectory: We do not expect this to, it's included for totality -RatingNegative: Rating points must be non-negative -RatingExceedsMax: Rating point must not exceed maximum points -RatingNotExpected: Rating not expected -RatingBinaryExpected: Rating must be 0 or 1 +RatingMissingSeparator: Präambel der Bewertungsdatei konnte nicht identifziert werden +RatingMultiple: Bewertungen enthält mehrere Punktzahlen für die gleiche Abgabe +RatingInvalid parseErr@String: Bewertungspunktzahl konnte nicht als Zahl verstanden werden: #{parseErr} +RatingFileIsDirectory: Unerwarteter Fehler: Datei ist unerlaubterweise ein Verzeichnis +RatingNegative: Bewertungspunkte dürfen nicht negativ sein +RatingExceedsMax: Bewertung übersteigt die erlaubte Maximalpunktzahl +RatingNotExpected: Keine Bewertungen erlaubt +RatingBinaryExpected: Bewertung muss 0 (=durchgefallen) oder 1 (=bestanden) sein NoTableContent: Kein Tabelleninhalt NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter From 8fde402efee9ce645cf5b7e252c145632f084cdb Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 9 Nov 2018 16:12:30 +0100 Subject: [PATCH 2/3] Refactor db.hs --- db.sh | 6 ++++ package.yaml | 13 +++++++-- start.sh | 2 +- db.hs => test/Database.hs | 61 ++++++++++++++++++++++++--------------- test/{Spec.hs => Main.hs} | 0 test/TestImport.hs | 14 ++++----- 6 files changed, 61 insertions(+), 35 deletions(-) create mode 100755 db.sh rename db.hs => test/Database.hs (85%) rename test/{Spec.hs => Main.hs} (100%) diff --git a/db.sh b/db.sh new file mode 100755 index 000000000..28bd04d89 --- /dev/null +++ b/db.sh @@ -0,0 +1,6 @@ +#!/usr/bin/env bash + +set -xe + +stack build --fast --flag uniworx:library-only --flag uniworx:dev +stack exec uniworxdb -- $@ diff --git a/package.yaml b/package.yaml index 10ef926b4..c9fdbb55a 100644 --- a/package.yaml +++ b/package.yaml @@ -155,6 +155,7 @@ default-extensions: - DataKinds - BinaryLiterals - PolyKinds + - PackageImports ghc-options: - -Wall @@ -196,11 +197,19 @@ executables: when: - condition: flag(library-only) buildable: false + uniworxdb: + main: Database.hs + ghc-options: + - -main-is Database + source-dirs: test + dependencies: + - uniworx + other-modules: [] # Test suite tests: yesod: - main: Spec.hs + main: Main.hs source-dirs: test dependencies: - uniworx @@ -231,5 +240,5 @@ flags: default: false pedantic: description: Be very pedantic about warnings and errors - manual: true + manual: false default: true diff --git a/start.sh b/start.sh index 7f0a48c4e..67d80033a 100755 --- a/start.sh +++ b/start.sh @@ -19,4 +19,4 @@ if [[ -d .stack-work-run ]]; then trap move-back EXIT fi -stack exec -- yesod devel +stack exec -- yesod devel $@ diff --git a/db.hs b/test/Database.hs similarity index 85% rename from db.hs rename to test/Database.hs index d28038000..8359210ce 100755 --- a/db.hs +++ b/test/Database.hs @@ -1,40 +1,40 @@ -#!/usr/bin/env stack --- stack runghc --package uniworx - -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} +module Database + ( main + , fillDb + , truncateDb + ) where import "uniworx" Import hiding (Option(..)) import "uniworx" Application (db, getAppDevSettings) +import "uniworx" Jobs (stopJobCtl) + +import Data.Pool (destroyAllResources) import Database.Persist.Postgresql -import Database.Persist.Sql import Control.Monad.Logger import System.Console.GetOpt import System.Exit (exitWith, ExitCode(..)) import System.IO (hPutStrLn, stderr) -import qualified Data.ByteString as BS +import System.FilePath (()) -import Database.Persist.Sql (toSqlKey) +import qualified Data.ByteString as BS import Data.Time data DBAction = DBClear + | DBTruncate | DBMigrate | DBFill argsDescr :: [OptDescr DBAction] argsDescr = - [ Option ['c'] ["clear"] (NoArg DBClear) "Delete everything accessable by the current database user" - , Option ['m'] ["migrate"] (NoArg DBMigrate) "Perform database migration" - , Option ['f'] ["fill"] (NoArg DBFill) "Fill database with example data" + [ Option ['c'] ["clear"] (NoArg DBClear) "Delete everything accessable by the current database user" + , Option ['t'] ["truncate"] (NoArg DBTruncate) "Truncate all tables mentioned in the current schema (This cannot be run concurrently with any other activity accessing the database)" + , Option ['m'] ["migrate"] (NoArg DBMigrate) "Perform database migration" + , Option ['f'] ["fill"] (NoArg DBFill) "Fill database with example data" ] @@ -47,16 +47,31 @@ main = do settings <- liftIO getAppDevSettings withPostgresqlConn (pgConnStr $ appDatabaseConf settings) . runSqlConn $ do rawExecute "drop owned by current_user;" [] + DBTruncate -> db $ do + foundation <- getYesod + stopJobCtl foundation + liftIO . destroyAllResources $ appConnPool foundation + truncateDb DBMigrate -> db $ return () DBFill -> db $ fillDb (_, _, errs) -> do forM_ errs $ hPutStrLn stderr - hPutStrLn stderr $ usageInfo "db.hs" argsDescr + hPutStrLn stderr $ usageInfo "uniworxdb" argsDescr exitWith $ ExitFailure 2 +truncateDb :: MonadIO m => ReaderT SqlBackend m () +truncateDb = do + tables <- map unSingle <$> [sqlQQ|SELECT table_name FROM information_schema.tables WHERE table_schema = 'public'|] + sqlBackend <- ask + + let escapedTables = map (connEscapeName sqlBackend . DBName) $ filter (not . (`elem` protected)) tables + query = "TRUNCATE TABLE " ++ intercalate ", " escapedTables ++ " RESTART IDENTITY" + protected = ["applied_migration"] + rawExecute query [] + insertFile :: FilePath -> DB FileId insertFile fileTitle = do - fileContent <- liftIO $ Just <$> BS.readFile ("testdata/" <> fileTitle) + fileContent <- liftIO . fmap Just . BS.readFile $ "testdata" fileTitle fileModified <- liftIO getCurrentTime insert File{..} @@ -217,12 +232,12 @@ fillDb = do void . insert $ DegreeCourse ffp sdMst sdInf void . insert $ Lecturer jost ffp void . insert $ Lecturer gkleen ffp - sheetkey <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions - insert_ $ SheetEdit gkleen now sheetkey - sheetkey <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions - insert_ $ SheetEdit gkleen now sheetkey - sheetkey <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions - insert_ $ SheetEdit gkleen now sheetkey + adhoc <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions + insert_ $ SheetEdit gkleen now adhoc + feste <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions + insert_ $ SheetEdit gkleen now feste + keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions + insert_ $ SheetEdit gkleen now keine -- EIP eip <- insert' Course { courseName = "Einführung in die Programmierung" diff --git a/test/Spec.hs b/test/Main.hs similarity index 100% rename from test/Spec.hs rename to test/Main.hs diff --git a/test/TestImport.hs b/test/TestImport.hs index 35464d9ce..1ef954051 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -6,7 +6,7 @@ module TestImport import Application (makeFoundation, makeLogWare) import ClassyPrelude as X hiding (delete, deleteBy, Handler) import Database.Persist as X hiding (get) -import Database.Persist.Sql (SqlPersistM, runSqlPersistMPool, rawExecute, unSingle, connEscapeName, sqlQQ) +import Database.Persist.Sql (SqlPersistM, runSqlPersistMPool) import Foundation as X import Model as X import Test.Hspec as X @@ -21,6 +21,9 @@ import Test.QuickCheck.Instances as X () import System.IO as X (hPrint, hPutStrLn, stderr) import Jobs (handleJobs, stopJobCtl) +import Database (truncateDb) +import Database as X (fillDb) + import Control.Monad.Trans.Resource (runResourceT, MonadResourceBase) import Data.Pool (destroyAllResources) @@ -63,14 +66,7 @@ withApp = around $ \act -> runResourceT $ do -- 'withApp' calls it before each test, creating a clean environment for each -- spec to run in. wipeDB :: (MonadResourceBase m, MonadMask m) => UniWorX -> m () -wipeDB app = runDBWithApp app $ do - tables <- map unSingle <$> [sqlQQ|SELECT table_name FROM information_schema.tables WHERE table_schema = 'public'|] - sqlBackend <- ask - - let escapedTables = map (connEscapeName sqlBackend . DBName) $ filter (not . (`elem` protected)) tables - query = "TRUNCATE TABLE " ++ intercalate ", " escapedTables ++ " RESTART IDENTITY" - protected = ["applied_migration"] - rawExecute query [] +wipeDB app = runDBWithApp app Database.truncateDb -- | Authenticate as a user. This relies on the `auth-dummy-login: true` flag -- being set in test-settings.yaml, which enables dummy authentication in From 7bf3a52599513e5efe2fa63d3ad215761e3aa6ef Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 9 Nov 2018 22:43:45 +0100 Subject: [PATCH 3/3] i18n MenuItems & Semantic support-referer Addresses #228 --- messages/uniworx/de.msg | 34 +- src/Foundation.hs | 381 +++++++++++++---------- src/Handler/Home.hs | 15 +- src/Handler/Utils/Form.hs | 5 + src/Import/NoFoundation.hs | 1 + src/Utils/Form.hs | 6 + src/Yesod/Core/Instances.hs | 34 ++ templates/standalone/modal.julius | 10 +- templates/widgets/asidenav.hamlet | 8 +- templates/widgets/navbar.hamlet | 44 +-- templates/widgets/pageactionprime.hamlet | 16 +- 11 files changed, 352 insertions(+), 202 deletions(-) create mode 100644 src/Yesod/Core/Instances.hs 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}