diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index cd1425452..2908a6e2e 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -626,12 +626,12 @@ MenuCorrectionsCreate: Abgaben registrieren MenuCorrectionsGrade: Abgaben bewerten MenuAuthPreds: Authorisierungseinstellungen -AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate werden nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist (d.h. bis ihr Browser-Cookie abgelaufen ist). +AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren. AuthPredsActive: Aktive Authorisierungsprädikate AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert AuthTagFree: Seite ist universell zugänglich AuthTagAdmin: Nutzer ist Administrator -AuthTagNoEscalation: Nutzer-Rechte werden nicht erweitert +AuthTagNoEscalation: Nutzer-Rechte werden nicht auf fremde Institute ausgeweitet AuthTagDeprecated: Seite ist nicht überholt AuthTagDevelopment: Seite ist nicht in Entwicklung AuthTagLecturer: Nutzer ist Dozent @@ -646,7 +646,7 @@ AuthTagOwner: Nutzer ist Besitzer AuthTagRated: Korrektur ist bewertet AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren -AuthTagAuthentication: Authentifizierung erfüllt Anforderungen +AuthTagAuthentication: Nutzer ist angemeldet, falls erforderlich AuthTagRead: Zugriff ist nur lesend AuthTagWrite: Zugriff ist i.A. schreibend diff --git a/models/users b/models/users index 59f9ecb6b..c0e4db206 100644 --- a/models/users +++ b/models/users @@ -1,3 +1,4 @@ +-- Some comments needes User json ident (CI Text) authentication AuthenticationMode @@ -24,7 +25,7 @@ UserLecturer user UserId school SchoolId UniqueSchoolLecturer user school -StudyFeatures +StudyFeatures -- Abschluss, Studiengang, Haupt/Nebenfachh und Fachsemester user UserId degree StudyDegreeId field StudyTermsId @@ -34,12 +35,12 @@ StudyFeatures valid Bool default=true UniqueStudyFeatures user degree field type semester -- UniqueUserSubject user degree field -- There exists a counterexample -StudyDegree +StudyDegree -- Studienabschluss key Int shorthand Text Maybe name Text Maybe Primary key -StudyTerms +StudyTerms -- Studiengang key Int shorthand Text Maybe name Text Maybe diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 2224dc20f..5f3d14f69 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -13,7 +13,7 @@ import Handler.Utils.Course import Handler.Utils.Delete -- import Data.Time -import qualified Data.Text as T +-- import qualified Data.Text as T import Data.Function ((&)) -- import Yesod.Form.Bootstrap3 @@ -282,9 +282,9 @@ getCShowR tid ssh csh = do lecturers <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid - return $ user E.^. UserDisplayName - - return (course,schoolName,participants,registration,map E.unValue lecturers) + return $ (user E.^. UserDisplayName, user E.^. UserSurname, user E.^. UserEmail) + return (course,schoolName,participants,registration,lecturers) + mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course @@ -633,7 +633,7 @@ validateCourse CourseForm{..} = type UserTableExpr = (E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote)) type UserTableWhere = UserTableExpr -> E.SqlExpr (E.Value Bool) -type UserTableData = DBRow (Entity User, E.Value UTCTime, E.Value (Maybe CourseUserNoteId)) +type UserTableData = DBRow (Entity User, UTCTime, Maybe CourseUserNoteId) forceUserTableType :: (UserTableExpr -> a) -> (UserTableExpr -> a) forceUserTableType = id @@ -656,10 +656,10 @@ instance HasUser UserTableData where hasUser = _dbrOutput . _1 . _entityVal _userTableRegistration :: Lens' UserTableData UTCTime -_userTableRegistration = _dbrOutput . _2 . _unValue +_userTableRegistration = _dbrOutput . _2 _userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId) -_userTableNote = _dbrOutput . _3 . _unValue +_userTableNote = _dbrOutput . _3 -- default Where-Clause courseIs :: CourseId -> UserTableWhere @@ -669,7 +669,7 @@ courseIs cid ((_user `E.InnerJoin` participant) `E.LeftOuterJoin` _note) = parti colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c) colUserComment tid ssh csh = sortable (Just "course-user-note") (i18nCell MsgCourseUserNote) - $ \DBRow{ dbrOutput=(Entity uid _, _, E.Value mbNoteKey) } -> + $ \DBRow{ dbrOutput=(Entity uid _, _, mbNoteKey) } -> maybeEmpty mbNoteKey $ const $ anchorCellM (courseLink <$> encrypt uid) (toWidget $ hasComment True) where @@ -694,7 +694,7 @@ makeCourseUserTable whereClause colChoices psValidator = dbtStyle = def dbtSQLQuery = userTableQuery whereClause dbtRowKey ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note) = user E.^. UserId - dbtProj = return -- . dbrOutput -- NOT SURE + dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId) -> return (user, registrationTime, userNoteId) dbtColonnade = colChoices dbtSorting = Map.fromList [] -- TODO dbtFilter = Map.fromList [] -- TODO diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 6363b641a..b9579f26d 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -192,7 +192,7 @@ getImpressumR :: Handler Html getImpressumR = -- do siteLayoutMsg' MsgMenuImpressum $ do setTitleI MsgImpressumHeading - $(widgetFile "impressum") + $(i18nWidgetFile "imprint") -- | Hinweise zu Datenschutz und Aufbewahrungspflichten @@ -200,7 +200,7 @@ getDataProtR :: Handler Html getDataProtR = -- do siteLayoutMsg' MsgMenuDataProt $ do setTitleI MsgDataProtHeading - $(widgetFile "data-protection-de") + $(i18nWidgetFile "data-protection") -- | Allgemeine Informationen @@ -280,8 +280,7 @@ getInfoLecturerR :: Handler Html getInfoLecturerR = siteLayoutMsg' MsgInfoLecturerTitle $ do setTitleI MsgInfoLecturerTitle - -- TODO: Translation. This is simply too much for a simple message and too akwward to cut into bits. Create i18nWidgetFile tool. - $(widgetFile "infoLecturer") + $(i18nWidgetFile "info-lecturer") getAuthPredsR, postAuthPredsR :: Handler Html diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 67beeabd1..8face7168 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -7,6 +7,13 @@ import Import import qualified Data.Text as T -- import qualified Data.Set (Set) import qualified Data.Set as Set +import Data.CaseInsensitive (CI, original) +-- import qualified Data.CaseInsensitive as CI + +import Language.Haskell.TH (Q, Exp) +-- import Language.Haskell.TH.Datatype + +import Text.Hamlet (shamletFile) import Handler.Utils.DateTime as Handler.Utils import Handler.Utils.Form as Handler.Utils @@ -36,9 +43,16 @@ tidFromText = fmap TermKey . maybeRight . termFromText simpleLink :: Widget -> Route UniWorX -> Widget simpleLink lbl url = [whamlet|^{lbl}|] +-- | toWidget-Version of @nameHtml@, for convenience nameWidget :: Text -> Text -> Widget nameWidget displayName surname = toWidget $ nameHtml displayName surname +-- | toWidget-Version of @nameEmailHtml@, for convenience +nameEmailWidget :: (CI Text) -> Text -> Text -> Widget +nameEmailWidget email displayName surname = toWidget $ nameEmailHtml email displayName surname + +-- | Show user's displayName, highlighting the surname if possible. +-- Otherwise appends the surname in parenthesis nameHtml :: Text -> Text -> Html nameHtml displayName surname | null surname = toHtml displayName @@ -56,6 +70,21 @@ nameHtml displayName surname |] [] -> error "Data.Text.splitOn returned empty list in violation of specification." +-- | Like nameHtml just show a users displayname with hightlighted surname, +-- but also wrap the name with a mailto-link +nameEmailHtml :: (CI Text) -> Text -> Text -> Html +nameEmailHtml email displayName surname = + wrapMailto email $ nameHtml displayName surname + +-- | Wrap mailto around given Html using single hamlet-file for consistency +wrapMailto :: (CI Text) -> Html -> Html +wrapMailto (original -> email) linkText + | null email = linkText + | otherwise = $(shamletFile "templates/widgets/link-email.hamlet") + +-- | Just show an email address in a standard way, for convenience inside hamlet files. +mailtoHtml :: (CI Text) -> Html +mailtoHtml email = wrapMailto email $ toHtml email warnTermDays :: TermId -> [Maybe UTCTime] -> DB () warnTermDays tid times = do @@ -70,3 +99,12 @@ warnTermDays tid times = do forM_ outoflecture $ warnI MsgDayIsOutOfLecture forM_ outoftermdays $ warnI MsgDayIsOutOfTerm +-- | Add language dependent template files +-- For large files which are translated as a whole. +-- Argument musst be a directory under templates, +-- which contains a file for each language, +-- eg. /templates/imprint/de.hamlet and /templates/imprint/en.hamlet +i18nWidgetFile :: FilePath -> Q Exp +i18nWidgetFile = + -- TODO write code to distinguish languages here + widgetFile . ( "de") \ No newline at end of file diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 68bd0e9a3..dc86454dd 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -65,7 +65,8 @@ userCell :: IsDBTable m a => Text -> Text -> DBCell m a userCell displayName surname = cell $ nameWidget displayName surname emailCell :: IsDBTable m a => CI Text -> DBCell m a -emailCell userEmail = cell $(widgetFile "widgets/link-email") +emailCell email = cell $(widgetFile "widgets/link-email") + where linkText= toWgt email cellHasUser :: (IsDBTable m c, HasUser a) => a -> DBCell m c cellHasUser = liftA2 userCell (view _userDisplayName) (view _userSurname) diff --git a/templates/adminUser.hamlet b/templates/adminUser.hamlet index 5909795a5..60d0d6b47 100644 --- a/templates/adminUser.hamlet +++ b/templates/adminUser.hamlet @@ -1,5 +1,6 @@

- #{userEmail} + $# Does not use link-email.hamlet, but should + ^{mailtoHtml userEmail}

^{formWidget} ^{submitButtonView} diff --git a/templates/course.hamlet b/templates/course.hamlet index 130fe7f0a..bccf46976 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -18,7 +18,9 @@
_{MsgLecturerFor}
- #{T.intercalate ", " lecturers} +