Merge branch 'master' into 'live'
Fix Support message referers See merge request !93
This commit is contained in:
Gregor Kleen
commit
195219023e
6
db.sh
Executable file
6
db.sh
Executable file
@ -0,0 +1,6 @@
|
||||
#!/usr/bin/env bash
|
||||
|
||||
set -xe
|
||||
|
||||
stack build --fast --flag uniworx:library-only --flag uniworx:dev
|
||||
stack exec uniworxdb -- $@
|
||||
@ -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
|
||||
@ -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
|
||||
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
|
||||
|
||||
13
package.yaml
13
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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 --
|
||||
------------------------------------------------
|
||||
|
||||
34
src/Yesod/Core/Instances.hs
Normal file
34
src/Yesod/Core/Instances.hs
Normal 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
|
||||
|
||||
2
start.sh
2
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 $@
|
||||
|
||||
@ -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');
|
||||
|
||||
@ -12,9 +12,9 @@ $newline never
|
||||
<div .asidenav__link-shorthand>#{courseShorthand}
|
||||
<div .asidenav__link-label>#{courseName}
|
||||
<ul .asidenav__nested-list.list--iconless>
|
||||
$forall action <- pageActions
|
||||
$case action
|
||||
$of PageActionPrime (MenuItem{menuItemRoute, menuItemLabel})
|
||||
$forall (MenuItem{menuItemType, menuItemLabel}, route) <- pageActions
|
||||
$case menuItemType
|
||||
$of PageActionPrime
|
||||
<li .asidenav__nested-list-item>
|
||||
<a .asidenav__link-wrapper href=@{menuItemRoute}>#{menuItemLabel}
|
||||
<a .asidenav__link-wrapper href=#{route}>_{menuItemLabel}
|
||||
$of _
|
||||
|
||||
@ -12,34 +12,34 @@ $newline never
|
||||
<i .fas.fa-star>
|
||||
<div .navbar__link-label> Favorites
|
||||
|
||||
$forall (menuType, menuIdent) <- menuTypes
|
||||
$case menuType
|
||||
$of NavbarAside (MenuItem label mIcon route _ isModal)
|
||||
<li .navbar__list-item :highlight route:.navbar__list-item--active>
|
||||
$if isModal
|
||||
$forall (MenuItem{menuItemType, menuItemRoute, menuItemIcon, menuItemLabel, menuItemModal}, menuIdent, route) <- menuTypes
|
||||
$case menuItemType
|
||||
$of NavbarAside
|
||||
<li .navbar__list-item :highlight (urlRoute menuItemRoute):.navbar__list-item--active>
|
||||
$if menuItemModal
|
||||
<div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable=true data-dynamic=True>
|
||||
<a .navbar__link-wrapper href=@{route} ##{menuIdent}>
|
||||
<i .fas.fa-#{fromMaybe "none" mIcon}>
|
||||
<div .navbar__link-label>#{label}
|
||||
<a .navbar__link-wrapper href=#{route} ##{menuIdent}>
|
||||
<i .fas.fa-#{fromMaybe "none" menuItemIcon}>
|
||||
<div .navbar__link-label>_{SomeMessage menuItemLabel}
|
||||
$of _
|
||||
|
||||
<ul .navbar__list.list--inline>
|
||||
$forall (menuType, menuIdent) <- menuTypes
|
||||
$case menuType
|
||||
$of NavbarRight (MenuItem label mIcon route _ isModal)
|
||||
<li .navbar__list-item :Just route == mcurrentRoute:.navbar__list-item--active>
|
||||
$if isModal
|
||||
$forall (MenuItem{menuItemType, menuItemRoute, menuItemIcon, menuItemLabel, menuItemModal}, menuIdent, route) <- menuTypes
|
||||
$case menuItemType
|
||||
$of NavbarRight
|
||||
<li .navbar__list-item :highlight (urlRoute menuItemRoute):.navbar__list-item--active>
|
||||
$if menuItemModal
|
||||
<div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable=true data-dynamic=True>
|
||||
<a .navbar__link-wrapper href=@{route} ##{menuIdent}>
|
||||
<i .fas.fa-#{fromMaybe "none" mIcon}>
|
||||
<div .navbar__link-label>#{label}
|
||||
$of NavbarSecondary (MenuItem label mIcon route _ isModal)
|
||||
<li .navbar__list-item.navbar__list-item--secondary :Just route == mcurrentRoute:.navbar__list-item--active>
|
||||
$if isModal
|
||||
<a .navbar__link-wrapper href=#{route} ##{menuIdent}>
|
||||
<i .fas.fa-#{fromMaybe "none" menuItemIcon}>
|
||||
<div .navbar__link-label>_{SomeMessage menuItemLabel}
|
||||
$of NavbarSecondary
|
||||
<li .navbar__list-item.navbar__list-item--secondary :highlight (urlRoute menuItemRoute):.navbar__list-item--active>
|
||||
$if menuItemModal
|
||||
<div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable=true data-dynamic=True>
|
||||
<a .navbar__link-wrapper href=@{route} ##{menuIdent}>
|
||||
<i .fas.fa-#{fromMaybe "none" mIcon}>
|
||||
<div .navbar__link-label>#{label}
|
||||
<a .navbar__link-wrapper href=#{route} ##{menuIdent}>
|
||||
<i .fas.fa-#{fromMaybe "none" menuItemIcon}>
|
||||
<div .navbar__link-label>_{SomeMessage menuItemLabel}
|
||||
$of _
|
||||
|
||||
<div .navbar__pushdown>
|
||||
|
||||
@ -2,16 +2,16 @@ $newline never
|
||||
$if hasPageActions
|
||||
<div .page-nav-prime>
|
||||
<ul .pagenav__list>
|
||||
$forall (menuType, menuIdent) <- menuTypes
|
||||
$case menuType
|
||||
$of PageActionPrime (MenuItem label _mIcon route _callback isModal)
|
||||
$forall (MenuItem{menuItemLabel, menuItemType, menuItemModal}, menuIdent, route) <- menuTypes
|
||||
$case menuItemType
|
||||
$of PageActionPrime
|
||||
<li .pagenav__list-item>
|
||||
$if isModal
|
||||
$if menuItemModal
|
||||
<div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable=true data-dynamic=True>
|
||||
<a .pagenav__link-wrapper href=@{route} ##{menuIdent}>#{label}
|
||||
$of PageActionSecondary (MenuItem label _mIcon route _callback isModal)
|
||||
<a .pagenav__link-wrapper href=#{route} ##{menuIdent}>_{SomeMessage menuItemLabel}
|
||||
$of PageActionSecondary
|
||||
<li .pagenav__list-item>
|
||||
$if isModal
|
||||
$if menuItemModal
|
||||
<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 _
|
||||
|
||||
@ -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"
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user