diff --git a/ChangeLog.md b/ChangeLog.md index e8491a064..923e51045 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,4 +1,16 @@ - * Version 06.08.2016 + * Version 18.09.2018 + + Tooltips funktionieren auch ohne JavaScript + + Kurskürzel müssen nur innerhalb eines Instituts eindeutig sein + + User Data zeigt nun alle momentan gespeicherten Datensätze an + + Unterstützung von Tabellenzusammenfassungen, z.B. Punktsummen + + Intelligente Verteilung von Abgaben auf Korrektoren (z.B. bei Krankheit) + + * Version 06.08.2018 Einführung einer Option, ob Dateien automatisch heruntergeladen werden sollen diff --git a/db.hs b/db.hs index 0c254a588..4a2a1bf7c 100755 --- a/db.hs +++ b/db.hs @@ -71,6 +71,7 @@ fillDb = do , userMatrikelnummer = Nothing , userEmail = "G.Kleen@campus.lmu.de" , userDisplayName = "Gregor Kleen" + , userSurname = "Kleen" , userMaxFavourites = 6 , userTheme = ThemeDefault , userDateTimeFormat = userDefaultDateTimeFormat @@ -84,6 +85,7 @@ fillDb = do , userMatrikelnummer = Nothing , userEmail = "felix.hamann@campus.lmu.de" , userDisplayName = "Felix Hamann" + , userSurname = "Hamann" , userMaxFavourites = userDefaultMaxFavourites , userTheme = ThemeDefault , userDateTimeFormat = userDefaultDateTimeFormat @@ -97,6 +99,7 @@ fillDb = do , userMatrikelnummer = Nothing , userEmail = "jost@tcs.ifi.lmu.de" , userDisplayName = "Steffen Jost" + , userSurname = "Jost" , userMaxFavourites = 14 , userTheme = ThemeMossGreen , userDateTimeFormat = userDefaultDateTimeFormat @@ -110,6 +113,7 @@ fillDb = do , userMatrikelnummer = Nothing , userEmail = "max@campus.lmu.de" , userDisplayName = "Max Musterstudent" + , userSurname = "Musterstudent" , userMaxFavourites = 7 , userTheme = ThemeAberdeenReds , userDateTimeFormat = userDefaultDateTimeFormat @@ -117,6 +121,20 @@ fillDb = do , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles } + void . insert $ User + { userPlugin = "LDAP" + , userIdent = "tester@campus.lmu.de" + , userMatrikelnummer = Just "999" + , userEmail = "tester@campus.lmu.de" + , userDisplayName = "Tina Tester" + , userSurname = "von Terror" + , userMaxFavourites = 5 + , userTheme = ThemeAberdeenReds + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles + } void . insert $ Term { termName = summer2017 , termStart = fromGregorian 2017 04 09 diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index f68710517..e66535980 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -27,6 +27,9 @@ InvalidInput: Eingaben bitte korrigieren. Term: Semester TermPlaceholder: W/S + vierstellige Jahreszahl +SchoolListHeading: Übersicht über verwaltete Institute +SchoolHeading school@SchoolName: Übersicht #{display school} + LectureStart: Beginn Vorlesungen Course: Kurs @@ -72,15 +75,15 @@ CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein Sheet: Blatt SheetList tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: #{display tid}-#{display ssh}-#{courseShortHand} Übersicht Übungsblätter SheetNewHeading tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: #{display tid}-#{display ssh}-#{courseShortHand} Neues Übungsblatt anlegen -SheetNewOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Neues Übungsblatt #{sheetName} wurde im Kurs #{display tid}-#{display ssh}-#{courseShortHand} erfolgreich erstellt. +SheetNewOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{sheetName} wurde als neues Übungsblatt im Kurs #{display tid}-#{display ssh}-#{courseShortHand} erfolgreich erstellt. SheetTitle tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName} SheetTitleNew tid@TermId ssh@SchoolId courseShortHand@CourseShorthand : #{display tid}-#{display ssh}-#{courseShortHand}: Neues Übungsblatt SheetEditHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName} editieren SheetEditOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde gespeichert. SheetNameDup tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{courseShortHand}. -SheetDelHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} herauslöschen? +SheetDelHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} herauslöschen? SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{display submissionNo} Abgaben. -SheetDelOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht. +SheetDelOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand}: #{sheetName} gelöscht. SheetExercise: Aufgabenstellung SheetHint: Hinweis @@ -125,9 +128,11 @@ SubmissionFile: Datei zur Abgabe SubmissionFiles: Abgegebene Dateien SubmissionAlreadyExistsFor email@UserEmail: #{email} hat bereits eine Abgabe zu diesem bÜbungsblatt. +SubmissionGroupName: Gruppenname + CorrectionsTitle: Zugewiesene Korrekturen CourseCorrectionsTitle: Korrekturen für diesen Kurs -CorrectorsHead sheetName@SheetName: Korrektoren für Blatt #{sheetName} +CorrectorsHead sheetName@SheetName: Korrektoren für #{sheetName} Unauthorized: Sie haben hierfür keine explizite Berechtigung. UnauthorizedAnd l@Text r@Text: (#{l} UND #{r}) @@ -165,6 +170,10 @@ Correctors: Korrektoren CorState: Status CorByTut: Nach Tutorium CorProportion: Anteil +CorByProportionOnly proportion@Rational: #{display proportion} Anteile +CorByProportionIncludingTutorial proportion@Rational: #{display proportion} Anteile - Tutorium +CorByProportionExcludingTutorial proportion@Rational: #{display proportion} Anteile + Tutorium + DeleteRow: Zeile entfernen ProportionNegative: Anteile dürfen nicht negativ sein CorrectorsUpdated: Korrektoren erfolgreich aktualisiert @@ -235,7 +244,9 @@ RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist FileTitle: Dateiname FileModified: Letzte Änderung -FileCorrected: Korrigiert + +Corrected: Korrigiert +FileCorrected: Korrigiert (Dateien) FileCorrectedDeleted: Korrigiert (gelöscht) RatingUpdated: Korrektur gespeichert RatingDeleted: Korrektur zurückgesetzt @@ -246,6 +257,7 @@ NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter AdminFor: Administrator LecturerFor: Dozent +LecturersFor: Dozenten UserListTitle: Komprehensive Benutzerliste DateTimeFormat: Datums- und Uhrzeitformat @@ -259,8 +271,10 @@ AmbiguousUTCTime: Der angegebene Zeitpunkt lässt sich nicht eindeutig zu UTC ko IllDefinedUTCTime: Der angegebene Zeitpunkt lässt sich nicht zu UTC konvertieren LastEdits: Letzte Änderungen -EditedBy name@Text time@Text: Durch #{name} um #{time} +EditedBy name@Text time@Text: #{time} durch #{name} LastEdit: Letzte Änderung +LastEditByUser: Ihre letzte Bearbeitung +NoEditByUser: Nicht von Ihnen bearbeitet SubmissionFilesIgnored: Es wurden Dateien in der hochgeladenen Abgabe ignoriert: SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe mit Nummer #{toPathPiece smid}. diff --git a/models b/models index c3cb175bf..88a300dba 100644 --- a/models +++ b/models @@ -4,6 +4,7 @@ User json matrikelnummer Text Maybe email (CI Text) displayName Text + surname Text maxFavourites Int default=12 theme Theme default='Default' dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" diff --git a/routes b/routes index d58947041..014a25e28 100644 --- a/routes +++ b/routes @@ -41,12 +41,15 @@ /profile ProfileR GET POST !free !free /profile/data ProfileDataR GET !free !free -/terms TermShowR GET !free -/terms/current TermCurrentR GET !free -/terms/edit TermEditR GET POST -/terms/#TermId/edit TermEditExistR GET -!/terms/#TermId TermCourseListR GET !free -!/terms/#TermId/#SchoolId TermSchoolCourseListR GET !free +/term TermShowR GET !free +/term/current TermCurrentR GET !free +/term/edit TermEditR GET POST +/term/#TermId/edit TermEditExistR GET +!/term/#TermId TermCourseListR GET !free +!/term/#TermId/#SchoolId TermSchoolCourseListR GET !free + +/school SchoolListR GET +/school/#SchoolId SchoolShowR GET -- For Pattern Synonyms see Foundation @@ -74,6 +77,11 @@ /correctors SCorrR GET POST !/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector +-- /user/#CryptoUUIDUser +-- /users +-- /correctors + + /corrections CorrectionsR GET POST !corrector !lecturer /corrections/upload CorrectionsUploadR GET POST !corrector !lecturer diff --git a/src/Application.hs b/src/Application.hs index 93bd35d76..c5b69f55f 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -52,6 +52,7 @@ import Handler.Profile import Handler.Users import Handler.Admin import Handler.Term +import Handler.School import Handler.Course import Handler.Sheet import Handler.Submission diff --git a/src/Foundation.hs b/src/Foundation.hs index 90371f955..5f78d7f56 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -145,7 +145,7 @@ pattern CSubmissionR tid ssh csh shn cid ptn -- Menus and Favourites data MenuItem = MenuItem { menuItemLabel :: Text - , menuItemIcon :: Maybe Text + , menuItemIcon :: Maybe Text , menuItemRoute :: Route UniWorX , menuItemAccessCallback' :: Handler Bool -- Check whether action is shown in ADDITION to authorization (which is always checked) } @@ -205,6 +205,15 @@ instance RenderMessage UniWorX CorrectorState where CorrectorExcused -> renderMessage' MsgCorrectorExcused where renderMessage' = renderMessage foundation ls + +instance RenderMessage UniWorX Load where + renderMessage foundation ls = \case + (Load {byTutorial=Nothing , byProportion=p}) -> renderMessage' $ MsgCorByProportionOnly p + (Load {byTutorial=Just True , byProportion=p}) -> renderMessage' $ MsgCorByProportionIncludingTutorial p + (Load {byTutorial=Just False, byProportion=p}) -> renderMessage' $ MsgCorByProportionExcludingTutorial p + where renderMessage' = renderMessage foundation ls + + instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route) @@ -995,6 +1004,13 @@ pageHeading (TermSchoolCourseListR tid ssh) School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh i18nHeading $ MsgTermSchoolCourseListHeading tid school +pageHeading (SchoolListR) + = Just $ i18nHeading MsgSchoolListHeading +pageHeading (SchoolShowR ssh) + = Just $ do + School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh + i18nHeading $ MsgSchoolHeading school + pageHeading (CourseListR) = Just $ i18nHeading $ MsgCourseListTitle pageHeading CourseNewR @@ -1161,6 +1177,7 @@ instance YesodAuth UniWorX where userMatrikelnummer' = lookup (Attr "LMU-Stud-Matrikelnummer") ldapData userEmail' = lookup (Attr "mail") ldapData userDisplayName' = lookup (Attr "displayName") ldapData + userSurname' = lookup (Attr "sn") ldapData userEmail <- if | Just [bs] <- userEmail' @@ -1174,6 +1191,12 @@ instance YesodAuth UniWorX where -> return userDisplayName | otherwise -> throwError $ ServerError "Could not retrieve user name" + userSurname <- if + | Just [bs] <- userSurname' + , Right userSurname <- Text.decodeUtf8' bs + -> return userSurname + | otherwise + -> throwError $ ServerError "Could not retrieve user surname" userMatrikelnummer <- if | Just [bs] <- userMatrikelnummer' , Right userMatrikelnummer <- Text.decodeUtf8' bs @@ -1193,10 +1216,11 @@ instance YesodAuth UniWorX where , userDownloadFiles = userDefaultDownloadFiles , .. } - userUpdate = [ UserMatrikelnummer =. userMatrikelnummer - , UserDisplayName =. userDisplayName - , UserEmail =. userEmail - ] + userUpdate = [ UserMatrikelnummer =. userMatrikelnummer + , UserDisplayName =. userDisplayName + , UserSurname =. userSurname + , UserEmail =. userEmail + ] userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 5e587c624..d4692c59d 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -23,6 +23,7 @@ import Import import Handler.Utils import Handler.Utils.Submission +import Handler.Utils.Table.Cells -- import Handler.Utils.Zip import Data.Set (Set) @@ -86,24 +87,24 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm) colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colCourse = sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(_, _, course, _, _) } -> - let csh = course ^. _2 - tid = course ^. _3 + let tid = course ^. _3 ssh = course ^. _4 + csh = course ^. _2 in anchorCell (CourseR tid ssh csh CShowR) [whamlet|#{display csh}|] colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSheet = sortable (Just "sheet") (i18nCell MsgSheet) $ \DBRow{ dbrOutput=(_, sheet, course, _, _) } -> - let csh = course ^. _2 - tid = course ^. _3 + let tid = course ^. _3 ssh = course ^. _4 + csh = course ^. _2 shn = sheetName $ entityVal sheet in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|#{display shn}|] colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case DBRow{ dbrOutput = (_, _, _, Nothing , _) } -> cell mempty - DBRow{ dbrOutput = (_, _, _, Just corr, _) } -> textCell . display . userDisplayName $ entityVal corr + DBRow{ dbrOutput = (_, _, _, Just (Entity _ User{..}), _) } -> userCell userDisplayName userSurname colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSubmissionLink = sortable Nothing (i18nCell MsgSubmission) @@ -125,6 +126,11 @@ colSubmittors :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let cell = listCell (Map.toList users) $ \(userId, User{..}) -> anchorCellM (AdminUserR <$> encrypt userId) (toWidget userDisplayName) in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] + +colSMatrikel :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) +colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let + cell = listCell (Map.toList users) $ \(userId, User{..}) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer) + in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId Submission{..}, Entity _ Sheet{..}, course, _, _) } -> @@ -178,7 +184,7 @@ makeCorrectionsTable whereClause colChoices psValidator = do , SortColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> sheet E.^. SheetName ) , ( "corrector" - , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserDisplayName + , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserSurname ) , ( "rating" , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints @@ -354,6 +360,7 @@ postCCorrectionsR tid ssh csh = do , dbRow , colSheet , colCorrector + , colSMatrikel , colSubmittors , colSubmissionLink , colRating diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index f8bddf741..b12ebe9c0 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -16,7 +16,12 @@ module Handler.Course where import Import + +import Control.Lens +import Utils.Lens +import Utils.TH import Handler.Utils +import Handler.Utils.Table.Cells -- import Data.Time import qualified Data.Text as T @@ -33,7 +38,7 @@ import qualified Database.Esqueleto as E import qualified Data.UUID.Cryptographic as UUID - +-- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method. type CourseTableData = DBRow (Entity Course, Int64, Bool, Entity School) colCourse :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) @@ -42,16 +47,12 @@ colCourse = sortable (Just "course") (i18nCell MsgCourse) anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseName}|] -colCourseDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) -colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) - $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> mappend - ( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseName}|] ) - ( case courseDescription of - Nothing -> mempty - (Just descr) -> cell [whamlet| ^{modalStatic descr} |] - ) +colCourseDescr :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) +colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) $ do + course <- view $ _dbrOutput . _1 . _entityVal + return $ courseCell course -colDescription :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) +colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colDescription = sortable Nothing (i18nCell MsgCourseDescription) $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> case courseDescription of @@ -91,7 +92,8 @@ colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort) colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom) $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> - cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget + maybe mempty timeCell courseRegisterFrom + -- cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget colRegTo :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo) @@ -100,7 +102,7 @@ colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo) colParticipants :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colParticipants = sortable (Just "participants") (i18nCell MsgCourseMembers) - $ \DBRow{ dbrOutput=(Entity cid Course{..}, currentParticipants, _, _) } -> textCell $ case courseCapacity of + $ \DBRow{ dbrOutput=(Entity cid Course{..}, currentParticipants, _, _) } -> i18nCell $ case courseCapacity of Nothing -> MsgCourseMembersCount currentParticipants Just max -> MsgCourseMembersCountLimited currentParticipants max @@ -161,9 +163,12 @@ makeCourseTable whereClause colChoices psValidator = do | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) | otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList criterias) ) - , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if - | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) - | otherwise -> school E.^. SchoolName `E.in_` E.valList (Set.toList criterias) +-- , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if +-- | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) +-- | otherwise -> school E.^. SchoolName `E.in_` E.valList (Set.toList criterias) +-- ) + , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) -> + emptyOrIn $ school E.^. SchoolName -- TODO: Refactor all?! ) , ( "schoolshort", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) @@ -249,17 +254,20 @@ getTermCourseListR tid = do getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId - (courseEnt,(schoolMB,participants,registered)) <- runDB $ do + (courseEnt,(schoolMB,participants,registered),lecturers) <- runDB $ do courseEnt@(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh dependent <- (,,) <$> get (courseSchool course) -- join -- just fetch full school name here <*> count [CourseParticipantCourse ==. cid] -- join <*> (case mbAid of -- TODO: Someone please refactor this late-night mess here! Nothing -> return False - (Just aid) -> do - regL <- getBy (UniqueParticipant aid cid) - return $ isJust regL) - return $ (courseEnt,dependent) + (Just aid) -> do regL <- getBy (UniqueParticipant aid cid) + return $ isJust regL) + lecturers <- 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 $ (courseEnt,dependent,E.unValue <$> lecturers) let course = entityVal courseEnt (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True @@ -335,7 +343,7 @@ courseDeleteHandler = undefined courseEditHandler :: Bool -> Maybe (Entity Course) -> Handler Html courseEditHandler isGet course = do - $logDebug "€€€€€€ courseEditHandler started" + -- $logDebug "€€€€€€ courseEditHandler started" aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!! ((result, formWidget), formEnctype) <- runFormPost . newCourseForm =<< for course courseToForm case result of diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 601fbfed9..2826e2c81 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -67,16 +67,16 @@ homeAnonymous = do colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (HandlerT UniWorX IO) ()) colonnade = mconcat [ -- dbRow - sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> + sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> textCell $ display $ courseTerm course - , sortable (Just "school") (textCell MsgCourseSchool) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do + , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do textCell $ display $ courseSchool course - , sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do + , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do let tid = courseTerm course ssh = courseSchool course csh = courseShorthand course anchorCell (CourseR tid ssh csh CShowR) (toWidget $ display csh) - , sortable (Just "deadline") (textCell MsgRegisterTo) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> + , sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget ] ((), courseTable) <- dbTable def $ DBTable @@ -156,17 +156,17 @@ homeUser uid = do colonnade = mconcat [ -- dbRow -- TOOD: sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(view _1 -> E.Value tid) } -> - sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(E.Value tid,_,_,_,_,_) } -> + sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput=(E.Value tid,_,_,_,_,_) } -> textCell $ display tid - , sortable (Just "school") (textCell MsgCourseSchool) $ \DBRow{ dbrOutput=(_,E.Value ssh,_,_,_,_) } -> + , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=(_,E.Value ssh,_,_,_,_) } -> textCell $ display ssh - , sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, _, _, _) } -> + , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, _, _, _) } -> anchorCell (CourseR tid ssh csh CShowR) (toWidget $ display csh) - , sortable (Just "sheet") (textCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) } -> + , sortable (Just "sheet") (i18nCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) } -> anchorCell (CSheetR tid ssh csh shn SShowR) (toWidget $ display shn) - , sortable (Just "deadline") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } -> + , sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } -> cell $ formatTime SelFormatDateTime deadline >>= toWidget - , sortable (Just "done") (textCell MsgDone) $ \(DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) }) -> + , sortable (Just "done") (i18nCell MsgDone) $ \(DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) }) -> case mbsid of Nothing -> mempty (Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 4bb62d344..701f3ea4e 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -1,12 +1,15 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MultiWayIf, LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} module Handler.Profile where @@ -14,10 +17,14 @@ module Handler.Profile where import Import import Handler.Utils +import Handler.Utils.Table.Cells + import Utils.Lens -- import Colonnade hiding (fromMaybe, singleton) -- import Yesod.Colonnade +import Data.Monoid (Any(..)) import qualified Data.Map as Map +-- import qualified Data.Set as Set import qualified Database.Esqueleto as E -- import Database.Esqueleto ((^.)) @@ -106,11 +113,10 @@ getProfileR = do return (course E.^. CourseTerm, course E.^.CourseSchool, course E.^. CourseShorthand) ) <*> - (E.select $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do + (E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid - return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand) ) <*> @@ -150,41 +156,320 @@ getProfileDataR = do -- mr <- getMessageRender -- Tabelle mit eigenen Kursen + (hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid -- Tabelle mit allen Teilnehmer: Kurs (link), Datum - courseTable <- do - let -- should be inlined - -- courseCol :: IsDBTable m a => Colonnade Sortable (DBRow (Entity Course, Entity CourseParticipant)) (DBCell m a) - courseCol = sortable (Just "course") (i18nCell MsgCourse) $ do -- (->) a Monad - Course{..} <- view $ _dbrOutput . _1 . _entityVal -- view == ^. - -- "preview _left" in order to match Either (result is Maybe) - return $ anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) - (citext2widget courseName) - --courseData :: (E.InnerJoin (E.SqlExpr (Entity Course)) (E.SqlExpr (Entity CourseParticipant))) - -- -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity CourseParticipant)) - courseData = \(course `E.InnerJoin` participant) -> do - E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse - E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid - return (course, participant) - dbTableWidget' def $ DBTable - { dbtIdent = "courseMembership" :: Text - , dbtSQLQuery = courseData - , dbtColonnade = mconcat - [ courseCol - ] - , dbtProj = return - , dbtSorting = Map.fromList - [ ( "course" - , SortColumn $ \(course `E.InnerJoin` _) -> course E.^. CourseName ) - ] - , dbtFilter = mempty - , dbtStyle = def - } - - -- Tabelle mit allen Abgaben und Abgabe-Gruppen - -- Tabelle mit allen Korrektor-Aufgaben - -- Tabelle mit allen Tutorials + enrolledCoursesTable <- mkEnrolledCoursesTable uid -- Tabelle mit allen Klausuren und Noten - + examTable <- return [whamlet| TOOD: Klausuranmeldungen anzeigen |] -- TODO + -- Tabelle mit allen Abgaben und Abgabe-Gruppen + submissionTable <- mkSubmissionTable uid + -- Tabelle mit allen Abgabegruppen + submissionGroupTable <- mkSubmissionGroupTable uid + -- Tabelle mit allen Korrektor-Aufgaben + correctionsTable <- mkCorrectionsTable uid + -- Tabelle mit allen Tutorials + tutorialTable <- return [whamlet| TOOD: Tutorials anzeigen |] -- TODO defaultLayout $ do $(widgetFile "profileData") $(widgetFile "dsgvDisclaimer") + + + +mkOwnedCoursesTable :: UserId -> Handler (Bool, Widget) +-- Table listing all courses that the given user is a lecturer for +mkOwnedCoursesTable = + let dbtIdent = "courseOwnership" :: Text + dbtStyle = def + + withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a) + -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a) + withType = id + + dbtSQLQuery' uid = \(course `E.InnerJoin` lecturer) -> do + E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse + E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid + return ( course E.^. CourseTerm + , course E.^. CourseSchool + , course E.^. CourseShorthand + ) + dbtProj = \x -> return $ x & _dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)) + + dbtColonnade = mconcat + [ dbRow + , sortable (Just "term") (i18nCell MsgTerm & cellAttrs .~ [("priority","0")]) $ do + tid <- view (_dbrOutput . _1) + return $ indicatorCell -- return True if one cell is produced here + `mappend` termCell tid + , sortable (Just "school") (i18nCell MsgCourseSchool) $ + schoolCell <$> view (_dbrOutput . _1 . re _Just) + <*> view (_dbrOutput . _2 ) + , sortable (Just "course") (i18nCell MsgCourse) $ + courseCellCL <$> view (_dbrOutput) + ] + + validator = def & defaultSorting [("term",SortDesc),("school",SortAsc),("course",SortAsc)] + dbtSorting = Map.fromList + [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand) + , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm ) + , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool ) + ] + dbtFilter = Map.fromList + [ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand) + , ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) + , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) + ] + in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> (dbTableWidget validator DBTable{..}) + + + +mkEnrolledCoursesTable :: UserId -> Handler Widget +-- Table listing all courses that the given user is enrolled in +mkEnrolledCoursesTable = + let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) + -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a) + withType = id + + validator = def & defaultSorting [("time",SortDesc)] + + in \uid -> dbTableWidget' validator + DBTable + { dbtIdent = "courseMembership" :: Text + , dbtSQLQuery = \(course `E.InnerJoin` participant) -> do + E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse + E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid + return (course, participant E.^. CourseParticipantRegistration) + , dbtProj = \x -> return $ x & _dbrOutput . _2 %~ E.unValue + , dbtColonnade = mconcat + [ dbRow + , sortable (Just "term") (i18nCell MsgTerm) $ + termCell <$> view (_dbrOutput . _1 . _entityVal . _courseTerm) + , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $ + schoolCell <$> view ( _courseTerm . re _Just) + <*> view ( _courseSchool ) + , sortable (Just "course") (i18nCell MsgCourse) $ + courseCell <$> view (_dbrOutput . _1 . _entityVal) + , sortable (Just "time") (i18nCell MsgRegistered) $ do + regTime <- view $ _dbrOutput . _2 + return $ timeCell regTime + ] + , dbtSorting = Map.fromList + [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseName ) + , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm ) + , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool) + , ( "time" , SortColumn $ \(_ `E.InnerJoin` participant) -> participant E.^. CourseParticipantRegistration) + ] + , dbtFilter = Map.fromList + [ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseName ) + , ( "term" , FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) + , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool) +-- , ( "time" , FilterColumn $ \(_ `E.InnerJoin` part :: CourseTableData) -> emptyOrIn $ part E.^. CourseParticipantRegistration ) + ] + , dbtStyle = def + } + + + +mkSubmissionTable :: UserId -> Handler Widget +-- Table listing all submissions for the given user +mkSubmissionTable = + let dbtIdent = "submissions" :: Text + dbtStyle = def + + withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)`E.InnerJoin` E.SqlExpr (Entity SubmissionUser) )->a) + -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)`E.InnerJoin` E.SqlExpr (Entity SubmissionUser) )->a) + withType = id + + dbtSQLQuery' uid = \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` subUser) -> do + E.on $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission + E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + E.where_ $ subUser E.^. SubmissionUserUser E.==. E.val uid + let crse = ( course E.^. CourseTerm + , course E.^. CourseSchool + , course E.^. CourseShorthand + ) + let sht = ( sheet E.^. SheetName + ) + return (crse, sht, submission, lastSubEdit uid submission) + + lastSubEdit uid submission = -- latest Edit-Time of this user for submission + E.sub_select . E.from $ \subEdit -> do + E.where_ $ subEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId + E.&&. subEdit E.^. SubmissionEditUser E.==. E.val uid + return . E.max_ $ subEdit E.^. SubmissionEditTime + + dbtProj = \x -> return $ x + & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)) + & _dbrOutput . _2 %~ E.unValue + & _dbrOutput . _4 %~ E.unValue + + dbtColonnade = mconcat + [ dbRow + , sortable (Just "term") (i18nCell MsgTerm) $ + termCell <$> view (_dbrOutput . _1 . _1) + , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $ + schoolCell <$> view ( _1. re _Just) + <*> view ( _2 ) + , sortable (Just "course") (i18nCell MsgCourse) $ + courseCellCL <$> view (_dbrOutput . _1) + , sortable (Just "sheet") (i18nCell MsgSheet) . magnify _dbrOutput $ + sheetCell <$> view _1 + <*> view _2 + , sortable (toNothingS "submission") (i18nCell MsgSubmission) . magnify _dbrOutput $ + submissionCell <$> view _1 + <*> view _2 + <*> view (_3 . _entityKey) +-- , sortable (Just "edit") (i18nCell MsgSubmissionEditUser) $ do +-- regTime <- view $ _dbrOutput . _4 +-- return $ maybe mempty timeCell regTime + , sortable (Just "edit") (i18nCell MsgLastEditByUser) $ + maybe mempty timeCell <$> view (_dbrOutput . _4) + ] + + validator = def -- DUPLICATED CODE: Handler.Corrections + & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information + & restrictSorting (\name _ -> name /= "corrector") + & defaultSorting [("edit",SortDesc)] + dbtSorting' uid = Map.fromList + [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseShorthand) + , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseTerm ) + , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseSchool ) + , ( "sheet" , SortColumn $ withType $ \(_ `E.InnerJoin` sheet `E.InnerJoin` _ `E.InnerJoin` _) -> sheet E.^. SheetName ) + , ( "edit" , SortColumn $ withType $ \(_ `E.InnerJoin` _ `E.InnerJoin` submission `E.InnerJoin` _) -> lastSubEdit uid submission ) + ] + dbtFilter = Map.fromList + [ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand) + , ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) + , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) + ] + in \uid -> let dbtSQLQuery = dbtSQLQuery' uid + dbtSorting = dbtSorting' uid + in dbTableWidget' validator $ DBTable {..} +-- in do dbtSQLQuery <- dbtSQLQuery' +-- dbtSorting <- dbtSorting' +-- return $ dbTableWidget' validator $ DBTable {..} + + + +mkSubmissionGroupTable :: UserId -> Handler Widget +-- Table listing all submissions for the given user +mkSubmissionGroupTable = + let dbtIdent = "subGroups" :: Text + dbtStyle = def + withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroup) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroupUser) )->a) + -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroup) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroupUser) )->a) + withType = id + + dbtSQLQuery' uid = \(course `E.InnerJoin` sgroup `E.InnerJoin` sguser) -> do + E.on $ sguser E.^. SubmissionGroupUserSubmissionGroup E.==. sgroup E.^. SubmissionGroupId + E.on $ sgroup E.^. SubmissionGroupCourse E.==. course E.^. CourseId + E.where_ $ sguser E.^. SubmissionGroupUserUser E.==. E.val uid + let crse = ( course E.^. CourseTerm + , course E.^. CourseSchool + , course E.^. CourseShorthand + ) + return (crse, sgroup, lastSGEdit sgroup) + + lastSGEdit sgroup = -- latest Edit-Time of this Submission Group by a user + E.sub_select . E.from $ \(user `E.InnerJoin` sgEdit) -> do + E.on $ user E.^. UserId E.==. sgEdit E.^. SubmissionGroupEditUser + E.where_ $ sgEdit E.^. SubmissionGroupEditSubmissionGroup E.==. sgroup E.^. SubmissionGroupId + return . E.max_ $ sgEdit E.^. SubmissionGroupEditTime + + dbtProj = \x -> return $ x + & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)) + & _dbrOutput . _3 %~ E.unValue + + dbtColonnade = mconcat + [ dbRow + , sortable (Just "term") (i18nCell MsgTerm) $ + termCell <$> view (_dbrOutput . _1 . _1) + , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $ + schoolCell <$> view ( _1. re _Just) + <*> view ( _2 ) + , sortable (Just "course") (i18nCell MsgCourse) $ + courseCellCL <$> view (_dbrOutput . _1) + , sortable (Just "submissiongroup") (i18nCell MsgSubmissionGroupName) . magnify (_dbrOutput . _2 . _entityVal) $ + maybe mempty textCell <$> view _submissionGroupName + , sortable (Just "edit") (i18nCell MsgLastEdit) $ + maybe mempty timeCell <$> view (_dbrOutput . _3) + ] + + validator = def -- DUPLICATED CODE: Handler.Corrections + & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information + & restrictSorting (\name _ -> name /= "corrector") + & defaultSorting [("edit",SortDesc)] + dbtSorting = Map.fromList + [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseShorthand) + , ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm ) + , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseSchool ) + , ( "submissiongroup" , SortColumn $ withType $ \(_ `E.InnerJoin` sgroup `E.InnerJoin` _) -> sgroup E.^. SubmissionGroupName ) + , ( "edit" , SortColumn $ withType $ \(_ `E.InnerJoin` sgroup `E.InnerJoin` _ ) -> lastSGEdit sgroup) + ] + dbtFilter = Map.fromList + [ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand) + , ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) + , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) + ] + in \uid -> let dbtSQLQuery = dbtSQLQuery' uid + in dbTableWidget' validator $ DBTable {..} + + + +mkCorrectionsTable :: UserId -> Handler Widget +-- Table listing all corrections made by the given user +mkCorrectionsTable = + let dbtIdent = "corrections" :: Text + dbtStyle = def +-- TODO Continue here + withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a) + -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a) + withType = id + + dbtSQLQuery' uid = \(course `E.InnerJoin` sheet `E.InnerJoin` corrector) -> do + E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet + E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid + let crse = ( course E.^. CourseTerm + , course E.^. CourseSchool + , course E.^. CourseShorthand + ) + return (crse, sheet E.^. SheetName, corrector) + + dbtProj = \x -> return $ x + & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)) + & _dbrOutput . _2 %~ E.unValue + + dbtColonnade = mconcat + [ dbRow + , sortable (Just "term") (i18nCell MsgTerm) $ + termCellCL <$> view (_dbrOutput . _1) + , sortable (Just "school") (i18nCell MsgCourseSchool) $ + schoolCellCL <$> view (_dbrOutput . _1) + , sortable (Just "course") (i18nCell MsgCourse) $ + courseCellCL <$> view (_dbrOutput . _1) + , sortable (Just "sheet") (i18nCell MsgSheet) . magnify _dbrOutput $ + sheetCell <$> view _1 <*> view _2 + , sortable (Just "cstate") (i18nCell MsgCorState) $ + correctorStateCell <$> view (_dbrOutput . _3 . _entityVal) + , sortable (toNothing "cload") (i18nCell MsgCorProportion) $ + correctorLoadCell <$> view (_dbrOutput . _3 . _entityVal) + ] + + validator = def & defaultSorting [("term",SortDesc),("school",SortAsc),("course",SortAsc),("sheet",SortAsc)] + dbtSorting = Map.fromList + [ ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm ) + , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseSchool ) + , ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseShorthand) + , ( "sheet" , SortColumn $ withType $ \(_ `E.InnerJoin` sheet `E.InnerJoin` _) -> sheet E.^. SheetName ) + , ( "cstate", SortColumn $ withType $ \(_ `E.InnerJoin` _ `E.InnerJoin` cs) -> cs E.^. SheetCorrectorState ) + ] + dbtFilter = Map.fromList + [ ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm ) + , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool ) + , ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand) + ] + in \uid -> let dbtSQLQuery = dbtSQLQuery' uid + in dbTableWidget' validator $ DBTable {..} + + diff --git a/src/Handler/School.hs b/src/Handler/School.hs new file mode 100644 index 000000000..9952a682d --- /dev/null +++ b/src/Handler/School.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} + +module Handler.School where + +import Import + +-- import Control.Lens +-- import Utils.Lens +-- import Utils.TH +-- import Handler.Utils +-- import Handler.Utils.Table.Cells +-- +-- -- import Data.Time +-- import qualified Data.Text as T +-- import Data.Function ((&)) +-- -- import Yesod.Form.Bootstrap3 +-- +-- import qualified Data.Set as Set +-- import qualified Data.Map as Map +-- +-- import Colonnade hiding (fromMaybe,bool) +-- +-- import qualified Database.Esqueleto as E +-- +-- import qualified Data.UUID.Cryptographic as UUID + + +getSchoolListR :: Handler Html +getSchoolListR = do + -- muid <- maybeAuthId + defaultLayout $ do + [whamlet|TODO: Liste aller Institute |] -- TODO + + +getSchoolShowR :: SchoolId -> Handler Html +getSchoolShowR ssh = do -- TODO + -- muid <- maybeAuthId + defaultLayout $ do + [whamlet|TODO: Informationen zu einem Institut |] -- TODO + diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 8ea156247..efaacf2e1 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -274,7 +274,7 @@ getSShowR tid ssh csh shn = do -- return desired columns return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) let colonnadeFiles = widgetColonnade $ mconcat - [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> stringCell ftype + [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> i18nCell ftype , sortable (Just "path") "Dateiname" $ anchorCell' (\(E.Value fName,_,E.Value fType) -> CSheetR tid ssh csh shn (SFileR fType fName)) (\(E.Value fName,_,_) -> str2widget fName) , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget @@ -349,7 +349,32 @@ getSFileR tid ssh csh shn typ title = do getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getSheetNewR tid ssh csh = do - let template = Nothing -- TODO: provide convenience by interpolating name/nr/dates+7days + lastSheets <- runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.orderBy [E.desc (sheet E.^. SheetActiveFrom)] + E.limit 1 + return sheet + let template = case lastSheets of + ((Entity {entityVal=Sheet{..}}):_) -> Just $ SheetForm + { sfName = stepTextCounterCI sheetName + , sfDescription = sheetDescription + , sfType = sheetType + , sfGrouping = sheetGrouping + , sfMarkingText = sheetMarkingText + , sfVisibleFrom = addOneWeek <$> sheetVisibleFrom + , sfActiveFrom = addOneWeek sheetActiveFrom + , sfActiveTo = addOneWeek sheetActiveTo + , sfSheetF = Nothing + , sfHintFrom = addOneWeek <$> sheetHintFrom + , sfHintF = Nothing + , sfSolutionFrom = addOneWeek <$> sheetSolutionFrom + , sfSolutionF = Nothing + , sfMarkingF = Nothing + } + _other -> Nothing let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing insertUnique $ newSheet handleSheetEdit tid ssh csh Nothing template action diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index e55a8a25f..a39a5a62e 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -23,6 +23,7 @@ import Import hiding (joinPath) -- import Yesod.Form.Bootstrap3 import Handler.Utils +import Handler.Utils.Table.Cells import Network.Mime @@ -30,6 +31,7 @@ import Control.Monad.Trans.Maybe import Control.Monad.State.Class import Control.Monad.Trans.State.Strict (StateT) +import Data.Monoid (Any(..)) import Data.Maybe (fromJust) import qualified Data.Maybe import qualified Data.Text as Text @@ -56,9 +58,9 @@ import Colonnade hiding (bool, fromMaybe) import qualified Yesod.Colonnade as Yesod import qualified Text.Blaze.Html5.Attributes as HA - -numberOfSubmissionEditDates :: Int64 -numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production. +-- DEPRECATED: We always show all edits! +-- numberOfSubmissionEditDates :: Int64 +-- numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production. makeSubmissionForm :: Maybe SubmissionId -> Bool -> SheetGroup -> [UserEmail] -> Form (Maybe (Source Handler File), [UserEmail]) @@ -105,8 +107,11 @@ getSubmissionOwnR tid ssh csh shn = do submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SubmissionMode -> Handler Html submissionHelper tid ssh csh shn (SubmissionMode mcid) = do - uid <- requireAuthId - msmid <- traverse decrypt mcid + uid <- requireAuthId + msmid <- traverse decrypt mcid + actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute + maySubmit <- (== Authorized) <$> isAuthorized actionUrl True -- affects visibility of Edit-Dates, Submission-Button, etc. + (Entity shid Sheet{..}, buddies, lastEdits) <- runDB $ do sheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn case msmid of @@ -135,7 +140,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid E.orderBy [E.asc $ user E.^. UserEmail] return $ user E.^. UserEmail - return (sheet,buddies,[]) + return (sheet, map E.unValue buddies, []) (E.Value smid:_) -> do cID <- encrypt smid addMessageI "info" $ MsgSubmissionAlreadyExists @@ -145,23 +150,31 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do shid' <- submissionSheet <$> get404 smid -- fetch buddies from current submission - buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do - E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId) - E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smid - E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid - E.orderBy [E.asc $ user E.^. UserEmail] - return $ user E.^. UserEmail - -- mLastEdit <- selectFirst [SubmissionEditSubmission ==. smid] [Desc SubmissionEditTime] - lastEditValues <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do - E.on (user E.^. UserId E.==. submissionEdit E.^. SubmissionEditUser) - E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid - E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime] - E.limit numberOfSubmissionEditDates - return $ (user E.^. UserDisplayName, submissionEdit E.^. SubmissionEditTime) - lastEdits <- forM lastEditValues $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time + (Any isOwner, buddies) <- do + submittors <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do + E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId) + E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smid + E.orderBy [E.asc $ user E.^. UserEmail] + return $ (user E.^. UserId, user E.^. UserEmail) + let breakUserFromBuddies (E.Value userID, E.Value email) + | uid == userID = (Any True , []) + | otherwise = (Any False, [email]) + return $ foldMap breakUserFromBuddies submittors + + lastEdits <- do + raw <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do + E.on (user E.^. UserId E.==. submissionEdit E.^. SubmissionEditUser) + E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid + E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime] + -- E.limit numberOfSubmissionEditDates -- DEPRECATED we always show all edit times + let userName = if isOwner || maySubmit + then E.just $ user E.^. UserDisplayName + else E.nothing + return $ (userName, submissionEdit E.^. SubmissionEditTime) + forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time return (sheet,buddies,lastEdits) let unpackZips = True -- undefined -- TODO - ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid unpackZips sheetGrouping $ map E.unValue buddies + ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid unpackZips sheetGrouping buddies mCID <- runDB $ do res' <- case res of (FormMissing ) -> return $ FormMissing @@ -242,13 +255,10 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do Just cID -> redirect $ CSubmissionR tid ssh csh shn cID SubShowR Nothing -> return () - actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute - maySubmit <- (== Authorized) <$> isAuthorized actionUrl True - -- Maybe construct a table to display uploaded archive files let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerT UniWorX IO) ()) colonnadeFiles cid = mconcat - [ sortable (Just "path") (textCell MsgFileTitle) $ \(coalesce -> (mOrig, mCorr)) -> let + [ sortable (Just "path") (i18nCell MsgFileTitle) $ \(coalesce -> (mOrig, mCorr)) -> let Just fileTitle' = fileTitle . entityVal . snd <$> (mOrig <|> mCorr) origIsFile = fmap (isJust . fileContent . entityVal . snd) mOrig corrIsFile = fmap (isJust . fileContent . entityVal . snd) mCorr @@ -257,17 +267,17 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do | Just True <- origIsFile -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionOriginal fileTitle') ([whamlet|#{fileTitle'}|]) | otherwise -> textCell $ bool (<> "/") id isFile fileTitle' - , sortable Nothing (cell mempty) $ \(coalesce -> (_, mCorr)) -> case mCorr of + , sortable (toNothing "state") (i18nCell MsgCorState) $ \(coalesce -> (_, mCorr)) -> case mCorr of Nothing -> cell mempty Just (_, Entity _ File{..}) | isJust fileContent -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionCorrected fileTitle) ([whamlet|_{MsgFileCorrected}|]) - | otherwise -> textCell MsgFileCorrected - , sortable (Just "time") (textCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let + | otherwise -> i18nCell MsgCorrected + , sortable (Just "time") (i18nCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let origTime = fileModified . entityVal . snd <$> mOrig corrTime = fileModified . entityVal . snd <$> mCorr Just fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime - in textCell $ display fileTime + in timeCell fileTime ] coalesce :: ((Maybe (Entity SubmissionFile), Maybe (Entity File)), (Maybe (Entity SubmissionFile), Maybe (Entity File))) -> (Maybe (Entity SubmissionFile, Entity File), Maybe (Entity SubmissionFile, Entity File)) coalesce ((ma, mb), (mc, md)) = ((,) <$> ma <*> mb, (,) <$> mc <*> md) @@ -303,6 +313,8 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do defaultLayout $ do setTitleI $ MsgSubmissionEditHead tid ssh csh shn + let urlArchive cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionCorrected)) + urlOriginal cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal)) $(widgetFile "submission") diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index ae6e07c64..ccedb3f71 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -33,9 +33,9 @@ getUsersR = do let dbtColonnade = dbColonnade . mconcat $ [ dbRow - , sortable (Just "display-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM + , sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM (AdminUserR <$> encrypt uid) - (toWidget . display $ userDisplayName) + (nameWidget userDisplayName userSurname) , sortable (Just "matriculation") (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM (AdminUserR <$> encrypt uid) (toWidget . display $ userMatrikelnummer) @@ -73,22 +73,22 @@ getUsersR = do |] ] psValidator = def - & defaultSorting [("display-name", SortAsc)] + & defaultSorting [("name", SortAsc),("display-name", SortAsc)] ((), userList) <- dbTable psValidator $ DBTable { dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User)) , dbtColonnade , dbtProj = return , dbtSorting = Map.fromList - [ ( "display-name" + [ ( "name" + , SortColumn $ \user -> user E.^. UserSurname + ) + , ( "display-name" , SortColumn $ \user -> user E.^. UserDisplayName ) , ( "matriculation" , SortColumn $ \user -> user E.^. UserMatrikelnummer ) --- , ( "last-name" --- , SortColumn $ \user -> (last . impureNonNull . words) <$> (user E.^. UserDisplayName) --- ) ] , dbtFilter = mempty , dbtStyle = def diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index d9710c119..f2902da57 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -11,6 +11,8 @@ module Handler.Utils import Import +import qualified Data.Text as T + import Handler.Utils.DateTime as Handler.Utils import Handler.Utils.Form as Handler.Utils import Handler.Utils.Table as Handler.Utils @@ -31,3 +33,15 @@ downloadFiles = do Nothing -> do AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings return userDefaultDownloadFiles + + +nameWidget :: Text -> Text -> Widget +nameWidget displayName surname + | null surname = toWidget displayName + | otherwise = case reverse $ T.splitOn surname displayName of + [_notContained] -> [whamlet|#{displayName} (#{surname})|] + (suffix:prefixes) -> + let prefix = T.intercalate surname $ reverse prefixes + in [whamlet|#{prefix}#{surname}#{suffix}|] + [] -> error "Data.Text.splitOn returned empty list in violation of specification." + diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index c9d465366..679539202 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -8,10 +8,10 @@ module Handler.Utils.DateTime ( utcToLocalTime , localTimeToUTC, TZ.LocalToUTCResult(..) - , formatTime' - , formatTime + , formatTime, formatTime', formatTimeW , getTimeLocale, getDateTimeFormat , validDateTimeFormats, dateTimeFormatOptions + , addOneWeek ) where import Import @@ -20,6 +20,7 @@ import Data.Time.Zones hiding (localTimeToUTCFull) import qualified Data.Time.Zones as TZ import Data.Time hiding (formatTime, localTimeToUTC, utcToLocalTime) +import Data.Time.Clock (addUTCTime,nominalDay) import qualified Data.Time.Format as Time import Data.Set (Set) @@ -51,6 +52,12 @@ formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> p formatTime :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> t -> m Text formatTime proj t = flip formatTime' t =<< (unDateTimeFormat <$> getDateTimeFormat proj) +-- formatTimeH :: (HasLocalTime t) => SelDateTimeFormat -> t -> Handler Text +-- formatTimeH = formatTime + +formatTimeW :: (HasLocalTime t) => SelDateTimeFormat -> t -> Widget +formatTimeW s t = toWidget =<< formatTime s t + getTimeLocale :: (MonadHandler m, HandlerSite m ~ UniWorX) => m TimeLocale getTimeLocale = getTimeLocale' <$> languages @@ -125,3 +132,10 @@ dateTimeFormatOptions sel = do return $ (dateTime, fmt) optionsPairs <=< mapM toOption . Set.toList $ validDateTimeFormats tl sel + + +addOneWeek :: UTCTime -> UTCTime +addOneWeek = addUTCTime (7 * nominalDay) + +-- addOneTerm? -> Move Handler.Utils.DateTime + diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs new file mode 100644 index 000000000..bb658c68c --- /dev/null +++ b/src/Handler/Utils/Table/Cells.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE FlexibleContexts #-} + +module Handler.Utils.Table.Cells where + +import Import + +import Data.Monoid (Any(..)) +import Control.Monad.Writer.Class (MonadWriter(..)) + +import Utils.Lens +import Handler.Utils + + +type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles ! + +-------------------- +-- Special cells + +indicatorCell :: IsDBTable m Any => DBCell m Any -- For dbTables that return a Bool to indicate content +indicatorCell = mempty & cellContents %~ (tell (Any True) *>) + +-- Datatype cells +timeCell :: IsDBTable m a => UTCTime -> DBCell m a +timeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget + +userCell :: IsDBTable m a => Text -> Text -> DBCell m a +userCell displayName surname = cell $ nameWidget displayName surname + +-- Just for documentation purposes; inline this code instead: +maybeTimeCell :: IsDBTable m a => Maybe UTCTime -> DBCell m a +maybeTimeCell = maybe mempty timeCell + +termCell :: IsDBTable m a => TermId -> DBCell m a +termCell tid = anchorCell link name + where + link = TermCourseListR tid + name = text2widget $ display tid + +termCellCL :: IsDBTable m a => CourseLink -> DBCell m a +termCellCL (tid,_,_) = termCell tid + +schoolCell :: IsDBTable m a => Maybe TermId -> SchoolId -> DBCell m a +schoolCell (Just tid) ssh = anchorCell link name + where + link = TermSchoolCourseListR tid ssh + name = text2widget $ display ssh +schoolCell Nothing ssh = anchorCell link name + where + link = SchoolShowR ssh + name = text2widget $ display ssh + +schoolCellCL :: IsDBTable m a => CourseLink -> DBCell m a +schoolCellCL (tid,ssh,_) = schoolCell (Just tid) ssh + +courseCellCL :: IsDBTable m a => CourseLink -> DBCell m a +courseCellCL (tid,ssh,csh) = anchorCell link name + where + link = CourseR tid ssh csh CShowR + name = citext2widget csh + +courseCell :: IsDBTable m a => Course -> DBCell m a +courseCell (Course {..}) = anchorCell link name `mappend` desc + where + link = CourseR courseTerm courseSchool courseShorthand CShowR + name = citext2widget courseName + desc = case courseDescription of + Nothing -> mempty + (Just descr) -> cell [whamlet| ^{modalStatic descr} |] + +sheetCell :: IsDBTable m a => CourseLink -> SheetName -> DBCell m a +sheetCell crse shn = + let tid = crse ^. _1 + ssh = crse ^. _2 + csh = crse ^. _3 + link= CSheetR tid ssh csh shn SShowR + in anchorCell link $ display2widget shn + +submissionCell :: IsDBTable m a => CourseLink -> SheetName -> SubmissionId -> DBCell m a +submissionCell crse shn sid = + let tid = crse ^. _1 + ssh = crse ^. _2 + csh = crse ^. _3 + mkCid = encrypt sid + mkRoute cid = CSubmissionR tid ssh csh shn cid SubShowR + mkText cid = display2widget cid + in anchorCellM' mkCid mkRoute mkText + +correctorStateCell :: IsDBTable m a => SheetCorrector -> DBCell m a +correctorStateCell sc = + i18nCell $ sheetCorrectorState sc + +correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a +correctorLoadCell sc = + i18nCell $ sheetCorrectorLoad sc diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index c550356d1..c779842d6 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -21,7 +21,7 @@ module Handler.Utils.Table.Pagination ( SortColumn(..), SortDirection(..) , FilterColumn(..), IsFilterColumn - , DBRow(..), HasDBRow(..) + , DBRow(..), _dbrOutput, _dbrIndex, _dbrCount , DBStyle(..), DBEmptyStyle(..) , DBTable(..), IsDBTable(..), DBCell(..) , cellAttrs, cellContents @@ -34,7 +34,7 @@ module Handler.Utils.Table.Pagination , dbTableWidget, dbTableWidget' , widgetColonnade, formColonnade, dbColonnade , cell, textCell, stringCell, i18nCell - , anchorCell, anchorCell', anchorCellM + , anchorCell, anchorCell', anchorCellM, anchorCellM' , tickmarkCell , listCell , formCell, DBFormResult, getDBFormResult @@ -45,6 +45,7 @@ module Handler.Utils.Table.Pagination ) where import Handler.Utils.Table.Pagination.Types +import Utils.Lens.TH import Import hiding (Proxy(..)) import qualified Database.Esqueleto as E @@ -134,7 +135,7 @@ data PaginationSettings = PaginationSettings , psShortcircuit :: Bool } -makeClassy_ ''PaginationSettings +makeLenses_ ''PaginationSettings instance Default PaginationSettings where def = PaginationSettings @@ -153,7 +154,7 @@ data PaginationInput = PaginationInput , piShortcircuit :: Bool } -makeClassy_ ''PaginationInput +makeLenses_ ''PaginationInput piIsUnset :: PaginationInput -> Bool piIsUnset PaginationInput{..} = and @@ -169,7 +170,7 @@ data DBRow r = DBRow , dbrIndex, dbrCount :: Int64 } deriving (Show, Read, Eq, Ord) -makeClassy_ ''DBRow +makeLenses_ ''DBRow instance Functor DBRow where fmap f DBRow{..} = DBRow{ dbrOutput = f dbrOutput, .. } @@ -485,10 +486,14 @@ dbColonnade = id cell :: IsDBTable m a => Widget -> DBCell m a cell wgt = dbCell # ([], return wgt) -textCell, stringCell, i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a +textCell, stringCell :: (MonoFoldable msg, Element msg ~ Char, IsDBTable m a) => msg -> DBCell m a +textCell = cell . toWidget . (pack :: [Char] -> Text) . otoList stringCell = textCell -i18nCell = textCell -textCell msg = cell [whamlet|_{msg}|] + +i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a +i18nCell msg = cell $ do + mr <- getMessageRender + toWidget $ mr msg tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a tickmarkCell True = textCell (tickmark :: Text) @@ -498,6 +503,7 @@ tickmarkCell False = mempty anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a anchorCell = anchorCellM . return +{-# DEPRECATED anchorCell' "For compatibility with Colonnade; better use anchorCell instead." #-} anchorCell' :: IsDBTable m a => (r -> Route UniWorX) -> (r -> Widget) @@ -505,13 +511,18 @@ anchorCell' :: IsDBTable m a anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val) anchorCellM :: IsDBTable m a => (WidgetT UniWorX IO (Route UniWorX)) -> Widget -> DBCell m a -anchorCellM routeM widget = cell $ do - route <- routeM - authResult <- liftHandlerT $ isAuthorized route False +anchorCellM routeM widget = anchorCellM' routeM id (const widget) + +anchorCellM' :: IsDBTable m a => (WidgetT UniWorX IO x) -> (x -> Route UniWorX) -> (x -> Widget) -> DBCell m a +anchorCellM' xM x2route x2widget = cell $ do + x <- xM + let route = x2route x + widget = x2widget x + authResult <- liftHandlerT $ isAuthorized route False + case authResult of + Authorized -> $(widgetFile "table/cell/link") -- show allowed link + _otherwise -> widget -- don't show prohibited link - if - | Authorized <- authResult -> $(widgetFile "table/cell/link") - | otherwise -> widget listCell :: (IsDBTable m a, Traversable f) => f r' -> (r' -> DBCell m a) -> DBCell m a listCell xs mkCell = review dbCell . ([], ) $ do @@ -544,12 +555,12 @@ formCell genIndex genForm input = FormCell -- Predefined colonnades dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a) -dbRow = Colonnade.singleton (headednessPure $ textCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex +dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex dbSelect :: forall h r i a. (Headedness h, Ord i, PathPiece i) => Setter' a Bool -> (r -> MForm (HandlerT UniWorX IO) i) -> Colonnade h r (DBCell ((RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO))) (FormResult (DBFormResult r i a))) -dbSelect resLens genIndex = Colonnade.singleton (headednessPure $ textCell MsgSelectColumn) $ \r -> flip (formCell genIndex) r $ \_ i -> do +dbSelect resLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ \r -> flip (formCell genIndex) r $ \_ i -> do (selResult, selWidget) <- mreq checkBoxField ("" { fsName = Just $ "select-" <> toPathPiece i }) (Just False) return (set resLens <$> selResult, [whamlet|^{fvInput selWidget}|]) diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 8d16d1d1e..723ccd964 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -12,6 +12,8 @@ module Model.Migration import ClassyPrelude.Yesod +import Utils (lastMaybe) + import Model import Model.Migration.Version import Data.Map (Map) @@ -23,6 +25,7 @@ import qualified Data.Set as Set import Database.Persist.Sql import Database.Persist.Postgresql +import Text.Read (readMaybe) import Data.CaseInsensitive (CI) -- Database versions must follow https://pvp.haskell.org: @@ -151,6 +154,26 @@ customMigrations = Map.fromListWith (>>) ALTER TABLE "school" ADD PRIMARY KEY (shorthand); |] ) + , ( AppliedMigrationKey [migrationVersion|2.0.0|] [version|3.0.0|] + , whenM (tableExists "sheet_corrector") $ do -- Load is encoded as JSON now. + correctorLoads <- [sqlQQ| SELECT "id", "load" FROM "sheet_corrector"; |] + forM_ correctorLoads $ \(uid, Single str) -> case readMaybe str of + Just load -> update uid [SheetCorrectorLoad =. load] + _other -> error $ "Could not parse Load: " <> show str + [executeQQ| + ALTER TABLE "sheet_corrector" ALTER COLUMN "load" TYPE json USING "load"::json; + |] + ) + , ( AppliedMigrationKey [migrationVersion|3.0.0|] [version|3.1.0|] + , whenM (tableExists "user") $ do + userDisplayNames <- [sqlQQ| SELECT "id", "display_name" FROM "user"; |] + [executeQQ| + ALTER TABLE "user" ADD COLUMN "surname" text DEFAULT ' '; + |] + forM_ userDisplayNames $ \(uid, Single str) -> case lastMaybe $ words str of + Just name -> update uid [UserSurname =. name] + _other -> error $ "Empty userDisplayName found" + ) ] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index a84f6ba7a..386d828e7 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -88,6 +88,8 @@ pToI = fromPoints fromPoints :: Integral a => Points -> a -- deprecated fromPoints = round +instance DisplayAble Points + data SheetType = Bonus { maxPoints :: Points } | Normal { maxPoints :: Points } @@ -201,7 +203,12 @@ data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rati , byProportion :: Rational -- ^ workload proportion of all submission not assigned to tutorial leaders } deriving (Show, Read, Eq, Ord) -derivePersistField "Load" + +deriveJSON defaultOptions ''Load +derivePersistFieldJSON ''Load + + + instance Semigroup Load where (Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop') @@ -237,6 +244,8 @@ seasonFromChar c where (~=) = (==) `on` CI.mk +instance DisplayAble Season + data TermIdentifier = TermIdentifier { year :: Integer -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar' , season :: Season @@ -337,6 +346,8 @@ data StudyFieldType = FieldPrimary | FieldSecondary deriving (Eq, Ord, Enum, Show, Read, Bounded) derivePersistField "StudyFieldType" +instance DisplayAble StudyFieldType + data Theme = ThemeDefault | ThemeLavender diff --git a/src/Utils.hs b/src/Utils.hs index e472e72ca..c15a0c29a 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1,8 +1,9 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} {-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-} {-# LANGUAGE QuasiQuotes, TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} @@ -15,7 +16,7 @@ module Utils import ClassyPrelude.Yesod -- import Data.Double.Conversion.Text -- faster implementation for textPercent? -import Data.Foldable as Fold +import Data.Foldable as Fold hiding (length) import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI @@ -27,6 +28,11 @@ import Utils.PathPiece as Utils import Text.Blaze (Markup, ToMarkup) +import Data.Char (isDigit) +import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight) +import Numeric (showFFloat) + +import Control.Lens import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map) @@ -45,6 +51,8 @@ import Instances.TH.Lift () import Text.Shakespeare.Text (st) + + ----------- -- Yesod -- ----------- @@ -80,6 +88,7 @@ unsupportedAuthPredicate = do |] + --------------------- -- Text and String -- --------------------- @@ -112,15 +121,21 @@ str2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => String -> WidgetT site m () str2widget s = [whamlet|#{s}|] +display2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m, DisplayAble a) => + a -> WidgetT site m () +display2widget = text2widget . display -withFragment :: ( Monad m - ) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ()) +withFragment :: Monad m => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ()) withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget) --- Convert anything to Text, and I don't care how +-- Types that can be converted to Text for direct displayed to User! (Show for debugging, Display for Production) +{-# DEPRECATED display "Create RenderMessage Instances instead!" #-} class DisplayAble a where display :: a -> Text + -- Default definitions for types belonging to Show (allows empty instance declarations) + default display :: Show a => a -> Text + display = pack . show instance DisplayAble Text where display = id @@ -128,6 +143,19 @@ instance DisplayAble Text where instance DisplayAble String where display = pack +instance DisplayAble Int +instance DisplayAble Int64 +instance DisplayAble Integer + +instance DisplayAble Rational where + display r = showFFloat (Just 2) (rat2float r) "" + & pack + & dropWhileEnd ('0'==) + & dropWhileEnd ('.'==) + where + rat2float :: Rational -> Double + rat2float = fromRational + instance DisplayAble a => DisplayAble (Maybe a) where display Nothing = "" display (Just x) = display x @@ -138,9 +166,12 @@ instance DisplayAble a => DisplayAble (E.Value a) where instance DisplayAble a => DisplayAble (CI a) where display = display . CI.original --- The easy way out of UndecidableInstances (TypeFamilies would have been proper, but are much more complicated) -instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where +{- We do not want DisplayAble for every Show-Class: + We want to explicitly verify that the resulting text can be displayed to the User! + For example: UTCTime values were shown without proper format rendering! +instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where -- The easy way out of UndecidableInstances (TypeFamilies would have been proper, but are much more complicated) display = pack . show +-} textPercent :: Double -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead? textPercent x = lz <> (pack $ show rx) <> "%" @@ -151,6 +182,24 @@ textPercent x = lz <> (pack $ show rx) <> "%" rx = fromIntegral (round' $ 1000.0*x) / 10.0 lz = if rx < 10.0 then "0" else "" +stepTextCounterCI :: CI Text -> CI Text -- find and increment rightmost-number, preserving leading zeroes +stepTextCounterCI = CI.map stepTextCounter + +stepTextCounter :: Text -> Text -- find and increment rightmost-number, preserving leading zeroes +stepTextCounter text + | (Just i) <- readMay number = + let iplus1 = tshow (succ i :: Int) + zeroip = justifyRight (length number) '0' iplus1 + in prefix <> zeroip <> suffix + | otherwise = text + where -- no splitWhile nor findEnd in Data.Text + suffix = takeWhileEnd (not . isDigit) text + number = takeWhileEnd isDigit $ dropWhileEnd (not . isDigit) text + prefix = dropWhileEnd isDigit $ dropWhileEnd (not . isDigit) text + +-- Data.Text.groupBy ((==) `on` isDigit) $ Data.Text.pack "12.ProMo Ue3bung00322 34 (H)" +-- ["12",".ProMo Ue","3","bung","00322"," ","34"," (H)"] + ------------ -- Tuples -- @@ -168,12 +217,22 @@ trd3 (_,_,z) = z -- snd3 = $(projNI 3 2) + ----------- -- Lists -- ----------- -- notNull = not . null +lastMaybe :: [a] -> Maybe a +lastMaybe [] = Nothing +lastMaybe [h] = Just h +lastMaybe (_:t) = lastMaybe t + +lastMaybe' :: [a] -> Maybe a +lastMaybe' l = fmap snd $ l ^? _Snoc + + mergeAttrs :: [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)] mergeAttrs = mergeAttrs' `on` sort where @@ -191,6 +250,8 @@ mergeAttrs = mergeAttrs' `on` sort mergeAttrs' [] xs2 = xs2 mergeAttrs' xs1 [] = xs1 + + ---------- -- Maps -- ---------- @@ -210,6 +271,8 @@ partMap = Map.fromListWith mappend invertMap :: (Ord k, Ord v) => Map k v -> Map v (Set k) invertMap = groupMap . map swap . Map.toList + + ----------- -- Maybe -- ----------- @@ -218,6 +281,12 @@ toMaybe :: Bool -> a -> Maybe a toMaybe True = Just toMaybe False = const Nothing +toNothing :: a -> Maybe b +toNothing = const Nothing + +toNothingS :: String -> Maybe b +toNothingS = const Nothing + maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap maybeAdd (Just x) (Just y) = Just (x + y) maybeAdd Nothing y = y @@ -252,6 +321,8 @@ instance Ord a => Ord (NTop (Maybe a)) where compare _ (NTop Nothing) = LT compare (NTop (Just x)) (NTop (Just y)) = compare x y + + --------------- -- Exception -- --------------- @@ -281,16 +352,17 @@ catchIfMExceptT :: (MonadCatch m, Exception e) => (e -> m e') -> (e -> Bool) -> catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err) + ------------ -- Monads -- ------------ shortCircuitM :: Monad m => (a -> Bool) -> m a -> m a -> (a -> a -> a) -> m a -shortCircuitM sc mx my op = do +shortCircuitM sc mx my bop = do x <- mx case sc x of True -> return x - False -> op <$> pure x <*> my + False -> bop <$> pure x <*> my guardM :: MonadPlus m => m Bool -> m () diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 084adf0e1..ce23adae7 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -10,10 +10,20 @@ import ClassyPrelude.Yesod import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map - +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Database.Esqueleto as E -- import Database.Persist -- currently not needed here + +emptyOrIn :: PersistField typ => + E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool) +emptyOrIn criterion testSet + | Set.null testSet = E.val True + | otherwise = criterion `E.in_` E.valList (Set.toList testSet) + + entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs index cb9135120..1b82dbe12 100644 --- a/src/Utils/DateTime.hs +++ b/src/Utils/DateTime.hs @@ -28,6 +28,7 @@ import Instances.TH.Lift () deriving instance Lift TimeZone deriving instance Lift TimeLocale + -- $(timeLocaleMap _) :: [Lang] -> TimeLocale timeLocaleMap :: [(Lang, String)] -- ^ Languages and matching locales, first is taken as default -> ExpQ diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index f198e9a6b..55f8d406c 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -7,9 +7,28 @@ module Utils.Lens ( module Utils.Lens ) where import Import.NoFoundation import Control.Lens as Utils.Lens +import Utils.Lens.TH -makeClassy_ ''Entity +import qualified Database.Esqueleto as E (Value(..),InnerJoin(..)) -makeClassy_ ''SheetCorrector +_unValue :: Lens' (E.Value a) a +_unValue f (E.Value a) = E.Value <$> f a + +_InnerJoinLeft :: Lens' (E.InnerJoin l r) l -- forall f. Functor f => (a -> f a) -> s -> f s +_InnerJoinLeft f (E.InnerJoin l r) = (`E.InnerJoin` r) <$> f l + +_InnerJoinRight :: Lens' (E.InnerJoin l r) r +_InnerJoinRight f (E.InnerJoin l r) = (l `E.InnerJoin`) <$> f r + + +makeLenses_ ''Entity + +makeLenses_ ''Course + +makeLenses_ ''SheetCorrector + +makeLenses_ ''SubmissionGroup -- makeClassy_ ''Load + + diff --git a/src/Utils/Lens/TH.hs b/src/Utils/Lens/TH.hs new file mode 100644 index 000000000..6f5bf4c14 --- /dev/null +++ b/src/Utils/Lens/TH.hs @@ -0,0 +1,47 @@ +module Utils.Lens.TH where + +import Control.Lens +import Control.Lens.Internal.FieldTH +import Language.Haskell.TH + +-- import Control.Lens.Misc +{- NOTE: The code for lensRules_ and makeLenses_ was stolen from package lens-misc-0.0.2.0, + which was currently unavailable in our stack snapshot. + See https://github.com/louispan/lens-misc +-} + +-- | A 'LensRules' used by 'makeLenses_'. +lensRules_ :: LensRules +lensRules_ = lensRules + & lensField .~ \_ _ n -> [TopName (mkName ('_':nameBase n))] + +-- | Build lenses (and traversals) with a sensible default configuration. +-- Works the same as 'makeLenses' except that +-- the resulting lens is also prefixed with an underscore. +-- +-- /e.g./ +-- +-- @ +-- data FooBar +-- = Foo { x, y :: 'Int' } +-- | Bar { x :: 'Int' } +-- 'makeLenses' ''FooBar +-- @ +-- +-- will create +-- +-- @ +-- _x :: 'Lens'' FooBar 'Int' +-- _x f (Foo a b) = (\\a\' -> Foo a\' b) \<$\> f a +-- _x f (Bar a) = Bar \<$\> f a +-- _y :: 'Traversal'' FooBar 'Int' +-- _y f (Foo a b) = (\\b\' -> Foo a b\') \<$\> f b +-- _y _ c\@(Bar _) = pure c +-- @ +-- +-- @ +-- 'makeLenses_' = 'makeLensesWith' 'lensRules_' +-- @ + +makeLenses_ :: Name -> DecsQ +makeLenses_ = makeFieldOptics lensRules_ diff --git a/src/Utils/PathPiece.hs b/src/Utils/PathPiece.hs index a56358638..13f79cff9 100644 --- a/src/Utils/PathPiece.hs +++ b/src/Utils/PathPiece.hs @@ -38,14 +38,14 @@ nullaryToPathPiece nullaryType manglers = do splitCamel :: Text -> [Text] splitCamel = map Text.pack . reverse . helper (error "hasChange undefined at start of string") [] "" . Text.unpack where - helper hadChange words thisWord [] = reverse thisWord : words - helper hadChange words [] (c:cs) = helper True words [c] cs - helper hadChange words ws@(w:ws') (c:cs) + helper _hadChange items thisWord [] = reverse thisWord : items + helper _hadChange items [] (c:cs) = helper True items [c] cs + helper hadChange items ws@(w:ws') (c:cs) | sameCategory w c - , null ws' = helper False words (c:ws) cs - | sameCategory w c = helper hadChange words (c:ws) cs - | null ws' = helper True words (c:ws) cs - | not hadChange = helper True (reverse ws':words) [c,w] cs - | otherwise = helper True (reverse ws:words) [c] cs + , null ws' = helper False items (c:ws) cs + | sameCategory w c = helper hadChange items (c:ws) cs + | null ws' = helper True items (c:ws) cs + | not hadChange = helper True (reverse ws':items) [c,w] cs + | otherwise = helper True (reverse ws :items) [c] cs sameCategory = (==) `on` Char.generalCategory diff --git a/src/Utils/TH.hs b/src/Utils/TH.hs index 04eebdfa2..45bc84c7e 100644 --- a/src/Utils/TH.hs +++ b/src/Utils/TH.hs @@ -17,14 +17,12 @@ import Language.Haskell.TH ------------ -- Alternatively uses lenses: "^. _3" projects the 3rd component of an n-tuple for any n >=3, requires import Control.Lens -{- projNI :: Int -> Int -> ExpQ -- generic projection gives I-th element of N-tuple, i.e. snd3 = $(projNI 3 2) --ghci -fth -- $(projN n m) :: (t1,..,tn) -> tm (for m<=n) projNI n i = lamE [pat] rhs where pat = tupP (map varP xs) rhs = varE (xs !! (i - 1)) xs = [ mkName $ "x" ++ show j | j <- [1..n] ] --} --------------- -- Functions -- diff --git a/src/index.md b/src/index.md index fee16d2ba..eb0870ba4 100644 --- a/src/index.md +++ b/src/index.md @@ -74,7 +74,10 @@ Handler.Utils.Table.Pagination Handler.Utils.Table.Pagination.Types : `Sortable`-Headedness for colonnade - + +Handler.Utils.Table.Cells + : extends dbTable with UniWorX specific functions, such as special courseCell + Handler.Utils.Templates : Modals diff --git a/templates/correction-user.hamlet b/templates/correction-user.hamlet index 7bdd3e25d..d0b8976e2 100644 --- a/templates/correction-user.hamlet +++ b/templates/correction-user.hamlet @@ -1,39 +1,39 @@
- - - - - - - -
_{MsgSubmission} - #{display cid} + _{MsgSubmission} + #{display cid} $maybe Entity _ User{..} <- corrector
_{MsgRatingBy} - #{display userDisplayName} + _{MsgRatingBy} + #{display userDisplayName} $maybe time <- submissionRatingTime
_{MsgRatingTime} - #{display time} + _{MsgRatingTime} + ^{formatTimeW SelFormatDateTime time} $maybe points <- submissionRatingPoints $case sheetType $of Bonus{..}
_{MsgAchievedBonusPoints} - _{MsgAchievedOf points maxPoints} + _{MsgAchievedBonusPoints} + _{MsgAchievedOf points maxPoints} $of Normal{..}
_{MsgAchievedNormalPoints} - _{MsgAchievedOf points maxPoints} + _{MsgAchievedNormalPoints} + _{MsgAchievedOf points maxPoints} $of Pass{..}
_{MsgPassedResult} + _{MsgPassedResult} $if points >= passingPoints _{MsgPassed} $else _{MsgNotPassed}
_{MsgAchievedPassPoints} - _{MsgPassAchievedOf points passingPoints maxPoints} + _{MsgAchievedPassPoints} + _{MsgPassAchievedOf points passingPoints maxPoints} $of NotGraded $maybe comment <- ratingComment
_{MsgRatingComment} - #{comment} + _{MsgRatingComment} + #{comment} diff --git a/templates/course.hamlet b/templates/course.hamlet index f63629fee..76bd9ba2a 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -5,11 +5,22 @@
#{schoolName school} + $maybe descr <- courseDescription course
_{MsgCourseDescription}
#{descr} + + $with numlecs <- length lecturers + $if numlecs > 1 +
_{MsgLecturersFor} + $else +
_{MsgLecturerFor} +
+
+ #{T.intercalate ", " lecturers} + $maybe link <- courseLinkExternal course
Website
diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet index 87827d44f..788577105 100644 --- a/templates/default-layout.hamlet +++ b/templates/default-layout.hamlet @@ -15,6 +15,8 @@

+ $maybe headline <- contentHeadline ^{headline} $nothing diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index f55073584..96b838972 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -1,7 +1,7 @@ :root { /* THEME INDEPENDENT COLORS */ - --color-error: #ff3860; - --color-warning: #ffdd57; + --color-error: #8c0707; + --color-warning: #fc9900; --color-success: #23d160; --color-info: #c4c4c4; --color-lightblack: #1A2A36; diff --git a/templates/dsgvDisclaimer.hamlet b/templates/dsgvDisclaimer.hamlet index ca8ab35fe..4551b7c84 100644 --- a/templates/dsgvDisclaimer.hamlet +++ b/templates/dsgvDisclaimer.hamlet @@ -14,4 +14,3 @@ Bitte melden Sie etwaige Probleme an # jost@tcs.ifi.lmu.de - diff --git a/templates/dsgvDisclaimer.lucius b/templates/dsgvDisclaimer.lucius index 96cf818dc..d92349d1d 100644 --- a/templates/dsgvDisclaimer.lucius +++ b/templates/dsgvDisclaimer.lucius @@ -3,10 +3,9 @@ border-radius: 3px; padding: 10px 20px 20px; margin: 40px 0; - color: var(--color-lighter); + color: var(--color-dark); box-shadow: 0 0 4px 2px inset currentColor; padding-left: 20%; - color: #318dc5 ; &::before { content: 'i'; diff --git a/templates/profile.hamlet b/templates/profile.hamlet index 51cbc913c..44116dc60 100644 --- a/templates/profile.hamlet +++ b/templates/profile.hamlet @@ -59,10 +59,10 @@
Teilnehmer
- $forall (E.Value tid, E.Value ssh, E.Value csh, regSince) <- participant + $forall (E.Value tid, E.Value ssh, E.Value csh, E.Value regSince) <- participant
#{display tid}-#{display ssh}-#{display csh}
- seit #{display regSince} + seit ^{formatTimeW SelFormatDateTime regSince} ^{settingsForm} diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 163063188..d50327a83 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -8,10 +8,44 @@ TODO: Hier alle Daten in Tabellen anzeigen! + $if hasRows +
+

Eigene Kurse +
+ ^{ownedCoursesTable} +

Kursanmeldungen
- ^{courseTable} + ^{enrolledCoursesTable} + +
+

Noten +
+ ^{examTable} + +
+

Übungsgruppen +
+ ^{tutorialTable} + +
+

Abgabegruppen +
+ ^{submissionGroupTable} + +
+

Abgaben +
+ ^{submissionTable} + Hinweis: + Bei Gruppenabgaben wird kein Datum angezeigt, + falls Sie die Gruppenabgabe nie selbst hochgeladen haben. + +
+

_{MsgCorrector} +
+ ^{correctionsTable}

TODO: Knopf zum Löschen aller Daten erstellen diff --git a/templates/standalone/alerts.julius b/templates/standalone/alerts.julius index b3820f60a..28b3f7c29 100644 --- a/templates/standalone/alerts.julius +++ b/templates/standalone/alerts.julius @@ -6,7 +6,7 @@ window.utils.alert = function(alertEl) { var closeEl = document.createElement('DIV'); var dataDecay = alertEl.dataset.decay; - var autoDecay = 3; + var autoDecay = 30; if (dataDecay) { autoDecay = parseInt(dataDecay, 10); } diff --git a/templates/standalone/alerts.lucius b/templates/standalone/alerts.lucius index d8118762f..9501f1329 100644 --- a/templates/standalone/alerts.lucius +++ b/templates/standalone/alerts.lucius @@ -2,13 +2,13 @@ /** .alert Regular Info Alert - Disappears automatically after 3 seconds - Disappears after x seconds if sepcified via data-decay='x' + Disappears automatically after 30 seconds + Disappears after x seconds if explicitly specified via data-decay='x' on html element Can be told not to disappear with data-decay='0' .alert-warning, .alert-error Warning or Error alert - Don't disappear, only difference is color + These don't disappear, only difference is color .alert-warning is orange regardless of user's selected theme .alert-error is red regardless of user's selected theme @@ -23,20 +23,12 @@ flex-direction: column; } -@media (min-width: 768px) { - - .alerts { - top: 150px; - bottom: auto; - } -} - .alert { position: relative; display: inline-block; background-color: var(--color-dark); font-size: 1rem; - color: #f3f3f3; + color: var(--color-lightwhite); z-index: 0; max-height: 200px; transition: all .3s ease-in-out; @@ -116,8 +108,6 @@ top: 0; width: 60px; height: 100%; - /* TODO: remove next line as soon as messagerenderer-error in julius gets resolved */ - color: var(--color-dark); transition: all .3s ease; z-index: 40; @@ -138,7 +128,6 @@ top: 50%; left: 50%; display: flex; - color: rgba(255, 255, 255, 0.5); align-items: center; justify-content: center; transform: translate(-50%, -50%); @@ -158,31 +147,11 @@ .alert-warning { background-color: var(--color-warning); - color: var(--color-dark); - - .alert__close { - color: var(--color-warning); - - /* TODO: remove me as soon as messagerenderer-error in julius gets resolved */ - &::before { - color: var(--color-dark); - } - } } .alert-danger, .alert-error { background-color: var(--color-error); - color: var(--color-lightwhite); - - .alert__close { - color: var(--color-error); - - /* TODO: remove me as soon as messagerenderer-error in julius gets resolved */ - &::before { - color: var(--color-lightwhite); - } - } } .alert--invisible { diff --git a/templates/standalone/tooltip.julius b/templates/standalone/tooltip.julius index 41ee803ad..42f283dd8 100644 --- a/templates/standalone/tooltip.julius +++ b/templates/standalone/tooltip.julius @@ -3,7 +3,6 @@ window.utils = window.utils || {}; - // allows for multiple file uploads with separate inputs window.utils.tooltip = function(tt) { var handle = tt.querySelector('.tooltip__handle'); var content = tt.querySelector('.tooltip__content'); @@ -55,13 +54,15 @@ document.addEventListener('DOMContentLoaded', function() { - // initialize tooltips set via `data-tooltip` - Array.from(document.querySelectorAll('[data-tooltip]')).forEach(function(el) { - window.utils.tooltipFromAttribute(el) - }); + // JS-TOOLTIPS NOT USED CURRENTLY. + + // initialize tooltips set via `data-tooltip` + // Array.from(document.querySelectorAll('[data-tooltip]')).forEach(function(el) { + // window.utils.tooltipFromAttribute(el) + // }); // initialize tooltips - Array.from(document.querySelectorAll('.js-tooltip')).forEach(function(tt) { - window.utils.tooltip(tt); - }); + // Array.from(document.querySelectorAll('.js-tooltip')).forEach(function(tt) { + // window.utils.tooltip(tt); + // }); }); diff --git a/templates/standalone/tooltip.lucius b/templates/standalone/tooltip.lucius index b123609c6..27e85f270 100644 --- a/templates/standalone/tooltip.lucius +++ b/templates/standalone/tooltip.lucius @@ -2,8 +2,8 @@ position: relative; display: inline-block; - .hidden { - display: none; + &:hover .tooltip__content { + display: inline-block; } } @@ -17,15 +17,16 @@ color: white; display: inline-block; text-align: center; - cursor: default; margin: 0 10px; + cursor: default; } .tooltip__content { position: absolute; + display: none; top: -10px; transform: translateY(-100%); - left: 3px; + right: 3px; width: 275px; z-index: 10; background-color: #fafafa; @@ -33,16 +34,6 @@ padding: 13px 17px; box-shadow: 0 0 20px 4px rgba(0, 0, 0, 0.1); - &.to-left { - left: auto; - right: 3px; - - &::after { - left: auto; - right: 10px; - } - } - &::after { content: ''; width: 16px; @@ -50,7 +41,7 @@ background-color: #fafafa; transform: rotate(45deg); position: absolute; - left: 10px; + right: 10px; bottom: -8px; } } diff --git a/templates/submission.hamlet b/templates/submission.hamlet index d22ae8ec0..d5044150b 100644 --- a/templates/submission.hamlet +++ b/templates/submission.hamlet @@ -1,17 +1,23 @@ $maybe cID <- mcid

- Archiv - (Original) - $if not (null lastEdits) -

_{MsgLastEdits} -
    - $forall (name,time) <- lastEdits -
  • _{MsgEditedBy name time} + Archiv + (Original) + $maybe fileTable <- mFileTable

    _{MsgSubmissionFiles} ^{fileTable} + $if not (null lastEdits) +

    _{MsgLastEdits} +
      + $forall (mbName,time) <- lastEdits + $maybe name <- mbName +
    • _{MsgEditedBy name time} + $nothing +
    • #{display time} + + $if maySubmit
      diff --git a/templates/widgets/asidenav.lucius b/templates/widgets/asidenav.lucius index 3e0613284..37db31849 100644 --- a/templates/widgets/asidenav.lucius +++ b/templates/widgets/asidenav.lucius @@ -181,6 +181,7 @@ width: 0; overflow: hidden; z-index: -1; + box-shadow: 0 0 13px rgba(0, 0, 0, 0.4); } @media (max-width: 425px) { diff --git a/templates/widgets/pageactionprime.hamlet b/templates/widgets/pageactionprime.hamlet index b12d7ae24..cce7e13e3 100644 --- a/templates/widgets/pageactionprime.hamlet +++ b/templates/widgets/pageactionprime.hamlet @@ -7,9 +7,6 @@ $if hasPageActions $of PageActionPrime (MenuItem label _mIcon route _callback)
    • #{label} - $of _ - $forall menuType <- menuTypes - $case menuType $of PageActionSecondary (MenuItem label _mIcon route _callback)
    • #{label}