fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into 'live'

Browse Source 
Fix Support message referers

See merge request !93
This commit is contained in:
Gregor Kleen 2018-11-09 22:56:42 +01:00
commit 195219023e
17 changed files with 421 additions and 245 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
db.sh Executable file
View File

@ -0,0 +1,6 @@
#!/usr/bin/env bash
set -xe
stack build --fast --flag uniworx:library-only --flag uniworx:dev
stack exec uniworxdb -- $@

50
messages/uniworx/de.msg
View File

@ -275,14 +275,14 @@ RatingDeleted: Korrektur zurückgesetzt
RatingFilesUpdated: Korrigierte Dateien überschrieben RatingFilesUpdated: Korrigierte Dateien überschrieben
RatingNotUnicode uexc@UnicodeException: Bewertungsdatei nicht in UTF-8 kodiert: #{tshow uexc} RatingNotUnicode uexc@UnicodeException: Bewertungsdatei nicht in UTF-8 kodiert: #{tshow uexc}
RatingMissingSeparator: Could not split rating header from comments RatingMissingSeparator: Präambel der Bewertungsdatei konnte nicht identifziert werden
RatingMultiple: Encountered multiple point values in rating RatingMultiple: Bewertungen enthält mehrere Punktzahlen für die gleiche Abgabe
RatingInvalid parseErr@String: Failed to parse rating point value #{parseErr} RatingInvalid parseErr@String: Bewertungspunktzahl konnte nicht als Zahl verstanden werden: #{parseErr}
RatingFileIsDirectory: We do not expect this to, it's included for totality RatingFileIsDirectory: Unerwarteter Fehler: Datei ist unerlaubterweise ein Verzeichnis
RatingNegative: Rating points must be non-negative RatingNegative: Bewertungspunkte dürfen nicht negativ sein
RatingExceedsMax: Rating point must not exceed maximum points RatingExceedsMax: Bewertung übersteigt die erlaubte Maximalpunktzahl
RatingNotExpected: Rating not expected RatingNotExpected: Keine Bewertungen erlaubt
RatingBinaryExpected: Rating must be 0 or 1 RatingBinaryExpected: Bewertung muss 0 (=durchgefallen) oder 1 (=bestanden) sein
NoTableContent: Kein Tabelleninhalt NoTableContent: Kein Tabelleninhalt
NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter
@ -483,4 +483,36 @@ ErrMsgInvalidBase64 base64Err@String: Verschlüsselte Daten nicht korrekt base64
ErrMsgCouldNotDecodeNonce: Konnte secretbox-nonce nicht dekodieren ErrMsgCouldNotDecodeNonce: Konnte secretbox-nonce nicht dekodieren
ErrMsgCouldNotOpenSecretbox: Konnte libsodium-secretbox nicht öffnen (Verschlüsselte Daten sind nicht authentisch) ErrMsgCouldNotOpenSecretbox: Konnte libsodium-secretbox nicht öffnen (Verschlüsselte Daten sind nicht authentisch)
ErrMsgCouldNotDecodePlaintext utf8Err@Text: Konnte Klartext nicht UTF8-dekodieren: #{utf8Err} ErrMsgCouldNotDecodePlaintext utf8Err@Text: Konnte Klartext nicht UTF8-dekodieren: #{utf8Err}
ErrMsgHeading: Fehlermeldung entschlüsseln ErrMsgHeading: Fehlermeldung entschlüsseln
InvalidRoute: Konnte URL nicht interpretieren
MenuHome: Aktuell
MenuVersion: Impressum
MenuHelp: Hilfe
MenuProfile: Anpassen
MenuLogin: Login
MenuLogout: Logout
MenuCourseList: Kurse
MenuTermShow: Semester
MenuCorrection: Korrektur
MenuUsers: Benutzer
MenuAdminTest: Admin-Demo
MenuMessageList: Systemnachrichten
MenuAdminErrMsg: Fehlermeldung entschlüsseln
MenuProfileData: Persönliche Daten
MenuTermCreate: Neues Semester anlegen
MenuCourseNew: Neuen Kurs anlegen
MenuTermEdit: Semester editieren
MenuSheetList: Übungsblätter
MenuCorrections: Abgaben
MenuSheetNew: Neues Übungsblatt anlegen
MenuCourseEdit: Kurs editieren
MenuCourseNewTemplate: Als neuen Kurs klonen
MenuSubmissionNew: Abgabe anlegen
MenuSubmissionOwn: Abgabe
MenuCorrectors: Korrektoren
MenuSheetEdit: Übungsblatt editieren
MenuCorrectionsUpload: Korrekturen hochladen
MenuCorrectionsCreate: Abgaben registrieren
MenuCorrectionsGrade: Abgaben bewerten

13
package.yaml
View File

@ -155,6 +155,7 @@ default-extensions:
- DataKinds - DataKinds
- BinaryLiterals - BinaryLiterals
- PolyKinds - PolyKinds
- PackageImports
ghc-options: ghc-options:
- -Wall - -Wall
@ -196,11 +197,19 @@ executables:
when: when:
- condition: flag(library-only) - condition: flag(library-only)
buildable: false buildable: false
uniworxdb:
main: Database.hs
ghc-options:
- -main-is Database
source-dirs: test
dependencies:
- uniworx
other-modules: []
# Test suite # Test suite
tests: tests:
yesod: yesod:
main: Spec.hs main: Main.hs
source-dirs: test source-dirs: test
dependencies: dependencies:
- uniworx - uniworx
@ -231,5 +240,5 @@ flags:
default: false default: false
pedantic: pedantic:
description: Be very pedantic about warnings and errors description: Be very pedantic about warnings and errors
manual: true manual: false
default: true default: true

381
src/Foundation.hs
View File

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

15
src/Handler/Home.hs
View File

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

5
src/Handler/Utils/Form.hs
View File

@ -159,6 +159,11 @@ buttonForm csrf = do
-- ciField moved to Utils.Form -- ciField moved to Utils.Form
routeField :: ( Monad m
, HandlerSite m ~ UniWorX
) => Field m (Route UniWorX)
routeField = checkMMap (return . maybe (Left MsgInvalidRoute) Right . fromPathPiece) toPathPiece textField
natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
natFieldI msg = checkBool (>= 0) msg intField natFieldI msg = checkBool (>= 0) msg intField

1
src/Import/NoFoundation.hs
View File

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

6
src/Utils/Form.hs
View File

@ -137,6 +137,12 @@ addDatalist mValues field = field
noValidate :: FieldSettings site -> FieldSettings site noValidate :: FieldSettings site -> FieldSettings site
noValidate = addAttr "formnovalidate" "" noValidate = addAttr "formnovalidate" ""
inputDisabled :: FieldSettings site -> FieldSettings site
inputDisabled = addAttr "disabled" ""
inputReadonly :: FieldSettings site -> FieldSettings site
inputReadonly = addAttr "readonly" ""
------------------------------------------------ ------------------------------------------------
-- Unique Form Identifiers to avoid accidents -- -- Unique Form Identifiers to avoid accidents --
------------------------------------------------ ------------------------------------------------

34
src/Yesod/Core/Instances.hs Normal file
View File

@ -0,0 +1,34 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Yesod.Core.Instances
(
) where
import ClassyPrelude.Yesod
import Utils (assertM')
import Control.Lens
import Data.ByteString.Builder (toLazyByteString)
import System.FilePath ((</>))
instance (RenderRoute site, ParseRoute site) => PathPiece (Route site) where
fromPathPiece
= parseRoute
. over (_2.traverse._2) (fromMaybe "")
. over _2 queryToQueryText
. decodePath
. encodeUtf8
toPathPiece
= pack
. ("/" </>)
. unpack
. decodeUtf8
. toLazyByteString
. uncurry encodePath
. over _2 queryTextToQuery
. over (_2.traverse._2) (assertM' $ not . null)
. renderRoute

2
start.sh
View File

@ -19,4 +19,4 @@ if [[ -d .stack-work-run ]]; then
trap move-back EXIT trap move-back EXIT
fi fi
stack exec -- yesod devel stack exec -- yesod devel $@

10
templates/standalone/modal.julius
View File

@ -98,7 +98,15 @@
}); });
} }
frame.setAttribute('src', dynamicContentURL + "?" + #{String modalParameter}); var url = "";
var i = dynamicContentURL.indexOf('?');
if (i === -1) {
url = dynamicContentURL + "?" + #{String modalParameter};
} else {
url = dynamicContentURL.slice(0,i) + "?" + #{String modalParameter} + "&" + dynamicContentURL.slice(i + 1);
}
frame.setAttribute('src', url);
} }
// tell further modals, that this one already got initialized // tell further modals, that this one already got initialized
modal.classList.add('js-modal-initialized'); modal.classList.add('js-modal-initialized');

8
templates/widgets/asidenav.hamlet
View File

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

44
templates/widgets/navbar.hamlet
View File

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

16
templates/widgets/pageactionprime.hamlet
View File

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

61
db.hs → test/Database.hs
View File

@ -1,40 +1,40 @@
#!/usr/bin/env stack module Database
-- stack runghc --package uniworx ( main
, fillDb
{-# LANGUAGE OverloadedStrings #-} , truncateDb
{-# LANGUAGE PackageImports #-} ) where
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
import "uniworx" Import hiding (Option(..)) import "uniworx" Import hiding (Option(..))
import "uniworx" Application (db, getAppDevSettings) import "uniworx" Application (db, getAppDevSettings)
import "uniworx" Jobs (stopJobCtl)
import Data.Pool (destroyAllResources)
import Database.Persist.Postgresql import Database.Persist.Postgresql
import Database.Persist.Sql
import Control.Monad.Logger import Control.Monad.Logger
import System.Console.GetOpt import System.Console.GetOpt
import System.Exit (exitWith, ExitCode(..)) import System.Exit (exitWith, ExitCode(..))
import System.IO (hPutStrLn, stderr) 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 import Data.Time
data DBAction = DBClear data DBAction = DBClear
| DBTruncate
| DBMigrate | DBMigrate
| DBFill | DBFill
argsDescr :: [OptDescr DBAction] argsDescr :: [OptDescr DBAction]
argsDescr = argsDescr =
[ Option ['c'] ["clear"] (NoArg DBClear) "Delete everything accessable by the current database user" [ Option ['c'] ["clear"] (NoArg DBClear) "Delete everything accessable by the current database user"
, Option ['m'] ["migrate"] (NoArg DBMigrate) "Perform database migration" , 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 ['f'] ["fill"] (NoArg DBFill) "Fill database with example data" , 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 settings <- liftIO getAppDevSettings
withPostgresqlConn (pgConnStr $ appDatabaseConf settings) . runSqlConn $ do withPostgresqlConn (pgConnStr $ appDatabaseConf settings) . runSqlConn $ do
rawExecute "drop owned by current_user;" [] rawExecute "drop owned by current_user;" []
DBTruncate -> db $ do
foundation <- getYesod
stopJobCtl foundation
liftIO . destroyAllResources $ appConnPool foundation
truncateDb
DBMigrate -> db $ return () DBMigrate -> db $ return ()
DBFill -> db $ fillDb DBFill -> db $ fillDb
(_, _, errs) -> do (_, _, errs) -> do
forM_ errs $ hPutStrLn stderr forM_ errs $ hPutStrLn stderr
hPutStrLn stderr $ usageInfo "db.hs" argsDescr hPutStrLn stderr $ usageInfo "uniworxdb" argsDescr
exitWith $ ExitFailure 2 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 :: FilePath -> DB FileId
insertFile fileTitle = do insertFile fileTitle = do
fileContent <- liftIO $ Just <$> BS.readFile ("testdata/" <> fileTitle) fileContent <- liftIO . fmap Just . BS.readFile $ "testdata" </> fileTitle
fileModified <- liftIO getCurrentTime fileModified <- liftIO getCurrentTime
insert File{..} insert File{..}
@ -217,12 +232,12 @@ fillDb = do
void . insert $ DegreeCourse ffp sdMst sdInf void . insert $ DegreeCourse ffp sdMst sdInf
void . insert $ Lecturer jost ffp void . insert $ Lecturer jost ffp
void . insert $ Lecturer gkleen 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 adhoc <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions
insert_ $ SheetEdit gkleen now sheetkey insert_ $ SheetEdit gkleen now adhoc
sheetkey <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions feste <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions
insert_ $ SheetEdit gkleen now sheetkey insert_ $ SheetEdit gkleen now feste
sheetkey <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions
insert_ $ SheetEdit gkleen now sheetkey insert_ $ SheetEdit gkleen now keine
-- EIP -- EIP
eip <- insert' Course eip <- insert' Course
{ courseName = "Einführung in die Programmierung" { courseName = "Einführung in die Programmierung"

0
test/Spec.hs → test/Main.hs
View File

14
test/TestImport.hs
View File

@ -6,7 +6,7 @@ module TestImport
import Application (makeFoundation, makeLogWare) import Application (makeFoundation, makeLogWare)
import ClassyPrelude as X hiding (delete, deleteBy, Handler) import ClassyPrelude as X hiding (delete, deleteBy, Handler)
import Database.Persist as X hiding (get) 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 Foundation as X
import Model as X import Model as X
import Test.Hspec 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 System.IO as X (hPrint, hPutStrLn, stderr)
import Jobs (handleJobs, stopJobCtl) import Jobs (handleJobs, stopJobCtl)
import Database (truncateDb)
import Database as X (fillDb)
import Control.Monad.Trans.Resource (runResourceT, MonadResourceBase) import Control.Monad.Trans.Resource (runResourceT, MonadResourceBase)
import Data.Pool (destroyAllResources) 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 -- 'withApp' calls it before each test, creating a clean environment for each
-- spec to run in. -- spec to run in.
wipeDB :: (MonadResourceBase m, MonadMask m) => UniWorX -> m () wipeDB :: (MonadResourceBase m, MonadMask m) => UniWorX -> m ()
wipeDB app = runDBWithApp app $ do wipeDB app = runDBWithApp app Database.truncateDb
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 []
-- | Authenticate as a user. This relies on the `auth-dummy-login: true` flag -- | Authenticate as a user. This relies on the `auth-dummy-login: true` flag
-- being set in test-settings.yaml, which enables dummy authentication in -- being set in test-settings.yaml, which enables dummy authentication in