diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 78d9bb3d6..075848b85 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -366,6 +366,7 @@ UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator. UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen. UnauthorizedAdminEscalation: Sie sind nicht Administrator für alle Institute, für die dieser Nutzer Administrator oder Veranstalter ist. UnauthorizedExamOffice: Sie sind nicht Teil eines Prüfungsamts. +UnauthorizedExamExamOffice: Es existieren keine Prüfungsergebnisse für Nutzer, für die Sie Teil eines assoziierten Prüfungsamts sind. UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen. UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen. UnauthorizedAllocationLecturer: Sie sind nicht als Veranstalter für eine Veranstaltung dieser Zentralanmeldung eingetragen. @@ -1046,6 +1047,7 @@ MenuExamList: Prüfungen MenuExamNew: Neue Prüfung anlegen MenuExamEdit: Bearbeiten MenuExamUsers: Teilnehmer +MenuExamGrades: Prüfungsleistungen MenuExamAddMembers: Prüfungsteilnehmer hinzufügen MenuExamOfficeExams: Prüfungen MenuExamOfficeFields: Fächer @@ -1339,6 +1341,8 @@ ExamRoomDescription: Beschreibung ExamTimeTip: Nur zur Information der Studierenden, die tatsächliche Zeitangabe erfolgt pro Prüfung ExamRoomRegistered: Zugeteilt +ExamOccurrenceStart: Prüfungsbeginn + ExamFormTimes: Zeiten ExamFormOccurrences: Prüfungstermine/Räume ExamFormAutomaticFunctions: Automatische Funktionen @@ -1402,6 +1406,18 @@ ExamUserAssignOccurrence: Termin/Raum zuweisen ExamUsersDeregistered count@Int64: #{show count} Teilnehmer von der Prüfung abgemeldet ExamUsersOccurrenceUpdated count@Int64: Termin/Raum für #{show count} Teilnehmer gesetzt +ExamUserSynchronised: Synchronisiert +ExamUserSyncOfficeName: Name +ExamUserSyncTime: Zeitpunkt +ExamUserSyncSchools: Institute +ExamUserSyncLastChange: Zuletzt geändert +ExamUserMarkSynchronised: Prüfungsleistung als synchronisiert markieren + +ExamUserMarkSynchronisedCsv: Prüfungsleistungen beim Export als synchronisiert markieren +ExamUserMarkedSynchronised n@Int: #{n} #{pluralDE n "Prüfungsleistung" "Prüfungsleistungen"} als synchronisiert markiert + +ExamOfficeExamUsersHeading: Prüfungsleistungen + CsvFile: CSV-Datei CsvModifyExisting: Existierende Einträge angleichen CsvAddNew: Neue Einträge einfügen @@ -1420,6 +1436,9 @@ CsvImportExplanationLabel: Hinweise zum CSV-Import Proportion c@Text of@Text prop@Rational: #{c}/#{of} (#{rationalToFixed2 (100 * prop)}%) +ExamUserCsvName tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase examn}-teilnehmer +CourseApplicationsTableCsvName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-bewerbungen + CsvColumnsExplanationsLabel: Spalten CsvColumnsExplanationsTip: Bedeutung der in der CSV-Datei enthaltenen Spalten CsvColumnExamUserSurname: Nachname(n) des Teilnehmers @@ -1436,6 +1455,9 @@ CsvColumnExamUserExercisePasses: Anzahl von Übungsblättern, die der Teilnehmer CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Prüfungstermin bestehen hätte können CsvColumnExamUserResult: Erreichte Prüfungsleistung; "passed", "failed", "no-show", "voided", oder eine Note ("1.0", "1.3", "1.7", ..., "4.0", "5.0") CsvColumnExamUserCourseNote: Notizen zum Teilnehmer + +CsvColumnExamOfficeExamUserOccurrenceStart: Prüfungstermin (ISO 8601) + CsvColumnApplicationsAllocation: Zentralanmeldung über die die Bewerbung eingegangen ist CsvColumnApplicationsApplication: Eindeutige Nummer der Bewerbung (zur Zuordnung im ZIP-Archiv aller Bewerbungsdateien) CsvColumnApplicationsName: Voller Name des Bewerbers diff --git a/models/courses b/models/courses index dd1099e55..206a6879e 100644 --- a/models/courses +++ b/models/courses @@ -71,6 +71,12 @@ CourseUserNoteEdit -- who edited a participants course note when time UTCTime note CourseUserNoteId -- PROBLEM: deleted notes have no modification date any more +CourseUserExamOfficeOptOut + course CourseId + user UserId + school SchoolId + UniqueCourseUserExamOfficeOptOut course user school + CourseApplication course CourseId user UserId diff --git a/models/exam-office b/models/exam-office index 5963cabb4..0941faf1d 100644 --- a/models/exam-office +++ b/models/exam-office @@ -9,6 +9,6 @@ ExamOfficeUser UniqueExamOfficeUser office user ExamOfficeResultSynced office UserId - result ExamResult + result ExamResultId time UTCTime UniqueExamOfficeResultSynced office result \ No newline at end of file diff --git a/routes b/routes index 3210505bb..0e854a0b6 100644 --- a/routes +++ b/routes @@ -168,8 +168,7 @@ /users/new EAddUserR GET POST /users/invite EInviteR GET POST /register ERegisterR POST !timeANDcourse-registeredAND¬exam-registered !timeANDexam-registeredAND¬exam-result - /grades EGradesR GET !exam-office - /grades/read EGradesReadR POST !exam-office + /grades EGradesR GET POST !exam-office /apps CApplicationsR GET POST !/apps/files CAppsFilesR GET /apps/#CryptoFileNameCourseApplication CourseApplicationR: diff --git a/src/Application.hs b/src/Application.hs index 06bb5309a..7d5fa3c39 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -44,7 +44,6 @@ import qualified Data.UUID as UUID import qualified Data.UUID.V4 as UUID import System.Directory -import System.FilePath import Jobs diff --git a/src/Data/Time/Clock/Instances.hs b/src/Data/Time/Clock/Instances.hs index 88ad3c047..d1b0af22e 100644 --- a/src/Data/Time/Clock/Instances.hs +++ b/src/Data/Time/Clock/Instances.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Time.Clock.Instances - ( + ( iso8601OutputFormat, iso8601ParseFormat ) where import ClassyPrelude @@ -17,6 +17,8 @@ import Data.Time.Clock import Data.Time.Calendar.Instances () import Web.PathPieces +import qualified Data.Csv as Csv + instance Hashable DiffTime where hashWithSalt s = hashWithSalt s . toRational @@ -29,12 +31,23 @@ instance PersistFieldSql NominalDiffTime where sqlType _ = sqlType (Proxy @Rational) +iso8601OutputFormat, iso8601ParseFormat :: String +iso8601OutputFormat = "%0Y-%m-%dT%H:%M:%S%Q%z" +iso8601ParseFormat = "%Y-%m-%dT%H:%M:%S%Q%z" + + deriving instance Generic UTCTime instance Hashable UTCTime instance PathPiece UTCTime where - toPathPiece = pack . formatTime defaultTimeLocale "%0Y-%m-%dT%H:%M:%S%Q%z" - fromPathPiece = parseTimeM False defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%z" . unpack + toPathPiece = pack . formatTime defaultTimeLocale iso8601OutputFormat + fromPathPiece = parseTimeM False defaultTimeLocale iso8601ParseFormat . unpack + +instance Csv.ToField UTCTime where + toField = Csv.toField . formatTime defaultTimeLocale iso8601OutputFormat + +instance Csv.FromField UTCTime where + parseField = parseTimeM False defaultTimeLocale iso8601ParseFormat <=< Csv.parseField instance Binary DiffTime where diff --git a/src/Data/Time/LocalTime/Instances.hs b/src/Data/Time/LocalTime/Instances.hs index 39c0d70f0..6bdf4610d 100644 --- a/src/Data/Time/LocalTime/Instances.hs +++ b/src/Data/Time/LocalTime/Instances.hs @@ -12,6 +12,12 @@ import Data.Binary (Binary) import qualified Language.Haskell.TH.Syntax as TH +import qualified Data.Csv as Csv + +import Data.Time.Clock.Instances + ( iso8601OutputFormat, iso8601ParseFormat + ) + deriving instance Generic TimeOfDay deriving instance Typeable TimeOfDay @@ -21,3 +27,9 @@ instance Binary TimeOfDay deriving instance TH.Lift TimeZone + +instance Csv.ToField ZonedTime where + toField = Csv.toField . formatTime defaultTimeLocale iso8601OutputFormat + +instance Csv.FromField ZonedTime where + parseField = parseTimeM False defaultTimeLocale iso8601ParseFormat <=< Csv.parseField diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index b8ca06295..a71b0b811 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -6,7 +6,6 @@ module Database.Esqueleto.Utils , isInfixOf, hasInfix , or, and , any, all - , SqlIn(..) , mkExactFilter, mkExactFilterWith , mkContainsFilter, mkContainsFilterWith , mkExistsFilter @@ -19,6 +18,7 @@ module Database.Esqueleto.Utils , sha256 , maybe , SqlProject(..) + , module Database.Esqueleto.Utils.TH ) where diff --git a/src/Foundation.hs b/src/Foundation.hs index 2637ccb13..2ad31c41a 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -66,6 +66,7 @@ import qualified Control.Monad.Catch as C import Handler.Utils.StudyFeatures import Handler.Utils.SchoolLdap +import Handler.Utils.ExamOffice.Exam.Auth import Utils.Form import Utils.Sheet import Utils.SystemMessage @@ -652,7 +653,22 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] [] guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin) return Authorized -tagAccessPredicate AuthExamOffice = APDB $ \mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do +tagAccessPredicate AuthExamOffice = APDB $ \mAuthId route _ -> case route of + CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + hasUsers <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do + E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId + E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId + + 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.&&. exam E.^. ExamName E.==. E.val examn + + E.where_ $ examOfficeExamResultAuth (E.val authId) examResult + guardMExceptT hasUsers (unauthorizedI MsgUnauthorizedExamExamOffice) + return Authorized + _other -> $cachedHereBinary mAuthId . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice] [] guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedExamOffice) @@ -1836,7 +1852,8 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (CExamR tid ssh csh examn EShowR) = return (original examn, Just $ CourseR tid ssh csh CExamListR) breadcrumb (CExamR tid ssh csh examn EEditR) = return ("Bearbeiten", Just $ CExamR tid ssh csh examn EShowR) breadcrumb (CExamR tid ssh csh examn EUsersR) = return ("Teilnehmer", Just $ CExamR tid ssh csh examn EShowR) - breadcrumb (CExamR tid ssh csh examn EAddUserR) = return ("Prüfungsteilnehmer hinzufügen", Just $ CExamR tid ssh csh examn EUsersR) + breadcrumb (CExamR tid ssh csh examn EAddUserR) = return ("Prüfungsteilnehmer hinzufügen", Just $ CExamR tid ssh csh examn EUsersR) + breadcrumb (CExamR tid ssh csh examn EGradesR) = return ("Prüfungsleistungen", Just $ CExamR tid ssh csh examn EShowR) breadcrumb (CTutorialR tid ssh csh tutn TUsersR) = return (original tutn, Just $ CourseR tid ssh csh CTutorialListR) breadcrumb (CTutorialR tid ssh csh tutn TEditR) = return ("Bearbeiten", Just $ CTutorialR tid ssh csh tutn TUsersR) @@ -2617,6 +2634,14 @@ pageActions (CExamR tid ssh csh examn EShowR) = , menuItemModal = False , menuItemAccessCallback' = return True } + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuExamGrades + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EGradesR + , menuItemModal = False + , menuItemAccessCallback' = return True + } ] pageActions (CExamR tid ssh csh examn EUsersR) = [ MenuItem diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 9d8c03552..1427533d3 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -21,7 +21,6 @@ import Database.Persist.Sql (fromSqlKey) import qualified Database.Esqueleto as E import Database.Esqueleto.Utils (mkExactFilter, mkContainsFilter) -import Handler.Utils.Table.Cells import qualified Handler.Utils.TermCandidates as Candidates -- import Colonnade hiding (fromMaybe) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index f36f157d5..d2049c7ca 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -4,10 +4,9 @@ import Import -- import System.FilePath (takeFileName) import Jobs -import Handler.Utils +import Handler.Utils hiding (colSchool) import Handler.Utils.Corrections import Handler.Utils.Submission -import Handler.Utils.Table.Cells import Handler.Utils.SheetType import Handler.Utils.Delete -- import Handler.Utils.Zip diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index f4056e878..4ca11700d 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -7,7 +7,6 @@ module Handler.Course.Application.List import Import import Handler.Utils -import Handler.Utils.Table.Columns import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E @@ -213,6 +212,7 @@ postCApplicationsR tid ssh csh = do table <- runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + csvName <- getMessageRender <*> pure (MsgCourseApplicationsTableCsvName tid ssh csh) let allocationLink :: Allocation -> SomeRoute UniWorX allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR @@ -320,8 +320,7 @@ postCApplicationsR tid ssh csh = do } dbtParams = def - dbtCsvEncode :: DBTCsvEncode CourseApplicationsTableData CourseApplicationsTableCsv - dbtCsvEncode = DictJust . C.mapM . runReaderT $ CourseApplicationsTableCsv + dbtCsvEncode = simpleCsvEncodeM csvName $ CourseApplicationsTableCsv <$> preview (resultAllocation . _entityVal . _allocationShorthand) <*> (preview (resultCourseApplication . _entityKey) >>= traverse encrypt) <*> preview (resultUser . _entityVal . _userDisplayName) diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs index 4a8a63703..650047327 100644 --- a/src/Handler/Course/List.hs +++ b/src/Handler/Course/List.hs @@ -12,8 +12,7 @@ import Data.Maybe (fromJust) import Utils.Form -- import Utils.DB -import Handler.Utils -import Handler.Utils.Table.Cells +import Handler.Utils hiding (colSchoolShort) import Data.Function ((&)) diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 17125062d..47796f8da 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -7,7 +7,6 @@ import Import import Utils.Form import Handler.Utils -import Handler.Utils.Table.Cells import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index ab74991a1..7b12d45d0 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -11,9 +11,6 @@ import Import import Utils.Form import Handler.Utils -import Handler.Utils.Database -import Handler.Utils.Table.Cells -import Handler.Utils.Table.Columns import Database.Persist.Sql (deleteWhereCount) import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH diff --git a/src/Handler/Exam/List.hs b/src/Handler/Exam/List.hs index 752d8e3c1..8a8aef894 100644 --- a/src/Handler/Exam/List.hs +++ b/src/Handler/Exam/List.hs @@ -5,7 +5,6 @@ module Handler.Exam.List import Import import Handler.Utils -import Handler.Utils.Table.Cells import qualified Data.Map as Map diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 692a69c3c..53f3d0b6c 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -8,8 +8,6 @@ import Import import Handler.Utils import Handler.Utils.Exam -import Handler.Utils.Table.Columns -import Handler.Utils.Table.Cells import Handler.Utils.Csv import qualified Database.Esqueleto as E @@ -242,6 +240,8 @@ postEUsersR tid ssh csh examn = do resultView :: ExamResultGrade -> ExamResultPassedGrade resultView = fmap $ bool (Left . view passingGrade) Right examShowGrades + csvName <- getMessageRender <*> pure (MsgExamUserCsvName tid ssh csh examn) + let examUsersDBTable = DBTable{..} where @@ -357,8 +357,7 @@ postEUsersR tid ssh csh examn = do } dbtIdent :: Text dbtIdent = "exam-users" - dbtCsvEncode :: DBTCsvEncode ExamUserTableData ExamUserTableCsv - dbtCsvEncode = DictJust . C.map $ ExamUserTableCsv + dbtCsvEncode = simpleCsvEncode csvName $ ExamUserTableCsv <$> view (resultUser . _entityVal . _userSurname . to Just) <*> view (resultUser . _entityVal . _userFirstName . to Just) <*> view (resultUser . _entityVal . _userDisplayName . to Just) diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs index 9583df560..3854cd4c6 100644 --- a/src/Handler/ExamOffice/Exam.hs +++ b/src/Handler/ExamOffice/Exam.hs @@ -1,14 +1,370 @@ module Handler.ExamOffice.Exam - ( getEGradesR - , postEGradesReadR + ( getEGradesR, postEGradesR ) where import Import +import Handler.Utils +import Handler.Utils.Exam +import Handler.Utils.Csv +import Handler.Utils.ExamOffice.Exam.Auth +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E + +import qualified Data.Csv as Csv + +import qualified Data.Set as Set +import qualified Data.Map as Map + +import qualified Data.Conduit.List as C +import qualified Colonnade + + +type ExamUserTableExpr = ( E.SqlExpr (Entity ExamResult) + `E.InnerJoin` E.SqlExpr (Entity User) + ) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamRegistration)) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) + `E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity CourseParticipant)) + `E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity StudyFeatures)) + `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) + `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)) + ) + ) +type ExamUserTableData = DBRow ( Entity ExamResult + , Entity User + , Maybe (Entity ExamOccurrence) + , Maybe (Entity StudyFeatures) + , Maybe (Entity StudyDegree) + , Maybe (Entity StudyTerms) + , Maybe (Entity ExamRegistration) + , [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)] + ) + +queryExamRegistration :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity ExamRegistration))) +queryExamRegistration = to $ $(E.sqlLOJproj 4 2) + +queryUser :: Getter ExamUserTableExpr (E.SqlExpr (Entity User)) +queryUser = to $ $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 4 1) + +queryExamOccurrence :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity ExamOccurrence))) +queryExamOccurrence = to $(E.sqlLOJproj 4 3) + +queryCourseParticipant :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity CourseParticipant))) +queryCourseParticipant = to $ $(E.sqlLOJproj 2 1) . $(E.sqlLOJproj 4 4) + +queryStudyFeatures :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity StudyFeatures))) +queryStudyFeatures = to $ $(E.sqlIJproj 3 1) . $(E.sqlLOJproj 2 2) . $(E.sqlLOJproj 4 4) + +queryStudyDegree :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity StudyDegree))) +queryStudyDegree = to $ $(E.sqlIJproj 3 2) . $(E.sqlLOJproj 2 2) . $(E.sqlLOJproj 4 4) + +queryStudyField :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity StudyTerms))) +queryStudyField = to $ $(E.sqlIJproj 3 3) . $(E.sqlLOJproj 2 2) . $(E.sqlLOJproj 4 4) + +queryExamResult :: Getter ExamUserTableExpr (E.SqlExpr (Entity ExamResult)) +queryExamResult = to $ $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 4 1) + +-- resultExamRegistration :: Traversal' ExamUserTableData (Entity ExamRegistration) +-- resultExamRegistration = _dbrOutput . _7 . _Just + +queryIsSynced :: Getter ExamUserTableExpr (E.SqlExpr (E.Value Bool)) +queryIsSynced = to . runReader $ do + examResult <- view queryExamResult + let + lastSync = E.sub_select . E.from $ \examOfficeResultSynced -> do + E.where_ $ examOfficeResultSynced E.^. ExamOfficeResultSyncedResult E.==. examResult E.^. ExamResultId + return . E.max_ $ examOfficeResultSynced E.^. ExamOfficeResultSyncedTime + return $ E.maybe E.false (E.>=. examResult E.^. ExamResultLastChanged) lastSync + +resultUser :: Lens' ExamUserTableData (Entity User) +resultUser = _dbrOutput . _2 + +resultStudyFeatures :: Traversal' ExamUserTableData (Entity StudyFeatures) +resultStudyFeatures = _dbrOutput . _4 . _Just + +resultStudyDegree :: Traversal' ExamUserTableData (Entity StudyDegree) +resultStudyDegree = _dbrOutput . _5 . _Just + +resultStudyField :: Traversal' ExamUserTableData (Entity StudyTerms) +resultStudyField = _dbrOutput . _6 . _Just + +resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence) +resultExamOccurrence = _dbrOutput . _3 . _Just + +resultExamResult :: Lens' ExamUserTableData (Entity ExamResult) +resultExamResult = _dbrOutput . _1 + +resultSynchronised :: Traversal' ExamUserTableData (UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand) +resultSynchronised = _dbrOutput . _8 . traverse + +data ExamUserTableCsv = ExamUserTableCsv + { csvEUserSurname :: Text + , csvEUserFirstName :: Text + , csvEUserName :: Text + , csvEUserMatriculation :: Maybe Text + , csvEUserField :: Maybe Text + , csvEUserDegree :: Maybe Text + , csvEUserSemester :: Maybe Int + , csvEUserOccurrenceStart :: Maybe ZonedTime + , csvEUserExamResult :: ExamResultPassedGrade + } + deriving (Generic) +makeLenses_ ''ExamUserTableCsv + +examUserTableCsvOptions :: Csv.Options +examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 } + +instance ToNamedRecord ExamUserTableCsv where + toNamedRecord = Csv.genericToNamedRecord examUserTableCsvOptions + +instance DefaultOrdered ExamUserTableCsv where + headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions + +instance CsvColumnsExplained ExamUserTableCsv where + csvColumnsExplanations = genericCsvColumnsExplanations examUserTableCsvOptions $ Map.fromList + [ ('csvEUserSurname , MsgCsvColumnExamUserSurname ) + , ('csvEUserFirstName , MsgCsvColumnExamUserFirstName ) + , ('csvEUserName , MsgCsvColumnExamUserName ) + , ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation ) + , ('csvEUserField , MsgCsvColumnExamUserField ) + , ('csvEUserDegree , MsgCsvColumnExamUserDegree ) + , ('csvEUserSemester , MsgCsvColumnExamUserSemester ) + , ('csvEUserOccurrenceStart , MsgCsvColumnExamOfficeExamUserOccurrenceStart ) + , ('csvEUserExamResult , MsgCsvColumnExamUserResult ) + ] + +data ExamUserAction = ExamUserMarkSynchronised + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + +instance Universe ExamUserAction +instance Finite ExamUserAction +nullaryPathPiece ''ExamUserAction $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''ExamUserAction id + +data ExamUserActionData = ExamUserMarkSynchronisedData + +data ExamUserCsvExportData = ExamUserCsvExportData + { csvEUserMarkSynchronised :: Bool + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + + -- | View a list of all users' grades that the current user has access to -getEGradesR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html -getEGradesR = fail "not implemented" +getEGradesR, postEGradesR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html +getEGradesR = postEGradesR +postEGradesR tid ssh csh examn = do + uid <- requireAuthId + now <- liftIO getCurrentTime + (usersResult, examUsersTable) <- runDB $ do + Entity eid Exam{..} <- fetchExam tid ssh csh examn --- | Mark all users' grades that the current user has access to as "read" -postEGradesReadR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html -postEGradesReadR = fail "not implemented" + csvName <- getMessageRender <*> pure (MsgExamUserCsvName tid ssh csh examn) + isLecturer <- hasReadAccessTo $ CExamR tid ssh csh examn EUsersR + + let + participantLink :: MonadCrypto m => UserId -> m (SomeRoute UniWorX) + participantLink partId = do + cID <- encrypt partId + return . SomeRoute . CourseR tid ssh csh $ CUserR cID + + examUsersDBTable = DBTable{..} + where + dbtSQLQuery = runReaderT $ do + examResult <- view queryExamResult + user <- view queryUser + examRegistration <- view queryExamRegistration + occurrence <- view queryExamOccurrence + courseParticipant <- view queryCourseParticipant + studyFeatures <- view queryStudyFeatures + studyDegree <- view queryStudyDegree + studyField <- view queryStudyField + + lift $ do + E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField + E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree + E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField) + E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse) + E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId) + E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid) + E.&&. occurrence E.?. ExamOccurrenceId E.==. E.joinV (examRegistration E.?. ExamRegistrationOccurrence) + E.on $ examRegistration E.?. ExamRegistrationUser E.==. E.just (user E.^. UserId) + E.on $ examResult E.^. ExamResultUser E.==. user E.^. UserId + E.&&. examResult E.^. ExamResultExam E.==. E.val eid + + E.where_ $ examResult E.^. ExamResultExam E.==. E.val eid + + unless isLecturer $ + E.where_ $ examOfficeExamResultAuth (E.val uid) examResult + + return (examResult, user, occurrence, studyFeatures, studyDegree, studyField, examRegistration) + dbtRowKey = views queryExamResult (E.^. ExamResultId) + + dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) ExamUserTableData + dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ + (,,,,,,,) + <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5 <*> view _6 <*> view _7 + <*> getSynchronised + where + getSynchronised :: ReaderT _ (MaybeT (YesodDB UniWorX)) [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)] + getSynchronised = do + resId <- view $ _1 . _entityKey + syncs <- lift . lift . E.select . E.from $ \((examOfficeResultSynced `E.InnerJoin` user) `E.LeftOuterJoin` userFunction) -> do + E.on $ userFunction E.?. UserFunctionUser E.==. E.just (user E.^. UserId) + E.&&. userFunction E.?. UserFunctionFunction E.==. E.just (E.val SchoolExamOffice) + E.on $ examOfficeResultSynced E.^. ExamOfficeResultSyncedOffice E.==. user E.^. UserId + E.where_ $ examOfficeResultSynced E.^. ExamOfficeResultSyncedResult E.==. E.val resId + return ( examOfficeResultSynced E.^. ExamOfficeResultSyncedOffice + , ( user E.^. UserDisplayName + , user E.^. UserSurname + , examOfficeResultSynced E.^. ExamOfficeResultSyncedTime + , userFunction E.?. UserFunctionSchool + ) + ) + let syncs' = Map.fromListWith + (\(dn, sn, t, sshs) (_, _, _, sshs') -> (dn, sn, t, Set.union sshs sshs')) + [ (officeId, (dn, sn, t, maybe Set.empty Set.singleton ssh')) + | (E.Value officeId, (E.Value dn, E.Value sn, E.Value t, fmap unSchoolKey . E.unValue -> ssh')) <- syncs + ] + return $ Map.elems syncs' + + colSynced = Colonnade.singleton (fromSortable . Sortable (Just "is-synced") $ i18nCell MsgExamUserSynchronised) $ \x -> cell . flip runReaderT x $ do + syncs <- asks $ sortOn (Down . view _3) . toListOf resultSynchronised + lastChange <- view $ resultExamResult . _entityVal . _examResultLastChanged + user <- view $ resultUser . _entityVal + let + lastSync = maximumOf (folded . _3) syncs + hasSyncs = has folded syncs + + syncs' = [ Right sync | sync@(_, _, t, _) <- syncs, t > lastChange] + ++ [ Left lastChange ] + ++ [ Right sync | sync@(_, _, t, _) <- syncs, t <= lastChange] + + syncIcon :: Widget + syncIcon = case lastSync of + Nothing -> mempty + Just ts + | ts >= lastChange + -> toWidget iconOK + | otherwise + -> toWidget iconNotOK + + syncsModal :: Widget + syncsModal = $(widgetFile "exam-office/exam-result-synced") + lift $ bool id (flip modal $ Right syncsModal) hasSyncs syncIcon + + dbtColonnade :: Colonnade Sortable _ _ + dbtColonnade = mconcat + [ dbSelect (applying _2) id $ return . view (resultExamResult . _entityKey) + , colSynced + , anchorColonnadeM (views (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname) + , colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer) + , emptyOpticColonnade (resultStudyField . _entityVal) colStudyTerms + , emptyOpticColonnade (resultStudyDegree . _entityVal) colStudyDegree + , emptyOpticColonnade (resultStudyFeatures . _entityVal . _studyFeaturesSemester) colStudyFeaturesSemester + , emptyOpticColonnade (resultExamOccurrence . _entityVal . _examOccurrenceStart <> like examStart . _Just) colOccurrenceStart + , colExamResult examShowGrades (resultExamResult . _entityVal . _examResultResult) + ] + dbtSorting = mconcat + [ sortUserName' (queryUser . to ((,) <$> (E.^. UserDisplayName) <*> (E.^. UserSurname))) + , sortUserMatriculation (queryUser . to (E.^. UserMatrikelnummer)) + , sortStudyTerms queryStudyField + , sortStudyDegree queryStudyDegree + , sortStudyFeaturesSemester (queryStudyFeatures . to (E.?. StudyFeaturesSemester)) + , sortOccurrenceStart (queryExamOccurrence . to (E.maybe (E.val examStart) E.just . (E.?. ExamOccurrenceStart))) + , maybeOpticSortColumn (sortExamResult examShowGrades) (queryExamResult . to (E.^. ExamResultResult)) + , singletonMap "is-synced" . SortColumn $ view queryIsSynced + ] + dbtFilter = mconcat + [ fltrUserName' (queryUser . to (E.^. UserDisplayName)) + , fltrUserMatriculation (queryUser . to (E.^. UserMatrikelnummer)) + , fltrStudyTerms queryStudyField + , fltrStudyDegree queryStudyDegree + , fltrStudyFeaturesSemester (queryStudyFeatures . to (E.?. StudyFeaturesSemester)) + , fltrExamResultPoints examShowGrades (queryExamResult . to (E.^. ExamResultResult)) + , singletonMap "is-synced" . FilterColumn $ E.mkExactFilter (view queryIsSynced) + ] + dbtFilterUI = mconcat + [ fltrUserNameUI' + , fltrUserMatriculationUI + , fltrStudyTermsUI + , fltrStudyDegreeUI + , fltrStudyFeaturesSemesterUI + , fltrExamResultPointsUI examShowGrades + , \mPrev -> prismAForm (singletonFilter "is-synced" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgExamUserSynchronised) + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtParams = DBParamsForm + { dbParamsFormMethod = POST + , dbParamsFormAction = Just . SomeRoute $ CExamR tid ssh csh examn EGradesR + , dbParamsFormAttrs = [] + , dbParamsFormSubmit = FormSubmit + , dbParamsFormAdditional = \csrf -> do + let + actionMap :: Map ExamUserAction (AForm Handler ExamUserActionData) + actionMap = Map.fromList + [ ( ExamUserMarkSynchronised + , pure ExamUserMarkSynchronisedData + ) + ] + (res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf + let formRes = (, mempty) . First . Just <$> res + return (formRes, formWgt) + , dbParamsFormEvaluate = liftHandlerT . runFormPost + , dbParamsFormResult = id + , dbParamsFormIdent = def + } + dbtIdent :: Text + dbtIdent = "exam-results" + dbtCsvEncode = Just DBTCsvEncode + { dbtCsvExportForm = ExamUserCsvExportData + <$> apopt checkBoxField (fslI MsgExamUserMarkSynchronisedCsv) (Just True) + , dbtCsvDoEncode = \ExamUserCsvExportData{..} -> C.mapM $ \(E.Value k, row) -> do + when csvEUserMarkSynchronised $ + void $ upsert ExamOfficeResultSynced + { examOfficeResultSyncedOffice = uid + , examOfficeResultSyncedResult = k + , examOfficeResultSyncedTime = now + } + [ ExamOfficeResultSyncedTime =. now + ] + return $ ExamUserTableCsv + (row ^. resultUser . _entityVal . _userSurname) + (row ^. resultUser . _entityVal . _userFirstName) + (row ^. resultUser . _entityVal . _userDisplayName) + (row ^. resultUser . _entityVal . _userMatrikelnummer) + (row ^? resultStudyField . _entityVal . to (\StudyTerms{..} -> fromMaybe (tshow studyTermsKey) $ studyTermsName <|> studyTermsShorthand)) + (row ^? resultStudyDegree . _entityVal . to (\StudyDegree{..} -> fromMaybe (tshow studyDegreeKey) $ studyDegreeName <|> studyDegreeShorthand)) + (row ^? resultStudyFeatures . _entityVal . _studyFeaturesSemester) + (row ^? (resultExamOccurrence . _entityVal . _examOccurrenceStart <> like examStart . _Just) . to utcToZonedTime) + (row ^. resultExamResult . _entityVal . _examResultResult . to (fmap $ bool (Left . view passingGrade) Right examShowGrades)) + , dbtCsvName = unpack csvName + , dbtCsvNoExportData = Nothing + } + dbtCsvDecode = Nothing + + examUsersDBTableValidator = def & defaultSorting [SortAscBy "is-synced", SortAscBy "user-name"] + & defaultPagesize PagesizeAll + + postprocess :: FormResult (First ExamUserActionData, DBFormResult ExamResultId Bool ExamUserTableData) -> FormResult (ExamUserActionData, Set ExamResultId) + postprocess inp = do + (First (Just act), regMap) <- inp + let regSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) regMap + return (act, regSet) + over _1 postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable + + formResult usersResult $ \case + (ExamUserMarkSynchronisedData, selectedResults) -> do + runDB . forM_ selectedResults $ \resId -> + void $ upsert ExamOfficeResultSynced + { examOfficeResultSyncedOffice = uid + , examOfficeResultSyncedResult = resId + , examOfficeResultSyncedTime = now + } + [ ExamOfficeResultSyncedTime =. now + ] + addMessageI Success $ MsgExamUserMarkedSynchronised (length selectedResults) + redirect $ CExamR tid ssh csh examn EGradesR + + siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamOfficeExamUsersHeading) $ do + setTitleI $ prependCourseTitle tid ssh csh MsgExamOfficeExamUsersHeading + $(widgetFile "exam-office/exam-results") diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 30beb116a..4d48043f2 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -3,8 +3,6 @@ module Handler.Home where import Import import Handler.Utils -import Handler.Utils.Table.Cells - import qualified Data.Map as Map import Database.Esqueleto.Utils.TH diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 791475e71..85c7ca08d 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -17,8 +17,6 @@ import Database.Esqueleto.Utils.TH import Utils.Form import Handler.Utils import Handler.Utils.Delete -import Handler.Utils.Table.Cells -import Handler.Utils.Table.Columns import Control.Monad.Writer (MonadWriter(..), execWriterT) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index b4a38f4f3..fd04d4ae0 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -3,7 +3,6 @@ module Handler.Profile where import Import import Handler.Utils -import Handler.Utils.Table.Cells -- import Colonnade hiding (fromMaybe, singleton) -- import Yesod.Colonnade diff --git a/src/Handler/School.hs b/src/Handler/School.hs index f97130264..1f665fb15 100644 --- a/src/Handler/School.hs +++ b/src/Handler/School.hs @@ -2,7 +2,6 @@ module Handler.School where import Import import Handler.Utils -import Handler.Utils.Table.Columns import qualified Database.Esqueleto as E diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 331922434..784afcff1 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -10,8 +10,6 @@ import Jobs.Queue import Utils.Sheet import Handler.Utils -- import Handler.Utils.Zip -import Handler.Utils.Table.Cells --- import Handler.Utils.Table.Columns import Handler.Utils.SheetType import Handler.Utils.Delete import Handler.Utils.Invitations diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index fe52740d4..febfe9aa4 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -11,7 +11,6 @@ import Jobs import Handler.Utils import Handler.Utils.Delete import Handler.Utils.Submission -import Handler.Utils.Table.Cells import Handler.Utils.Invitations -- import Control.Monad.Trans.Maybe diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index b2c7ef90f..5198338bc 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -9,7 +9,6 @@ import qualified Data.Set as Set import qualified Data.List.NonEmpty as NonEmpty import Handler.Utils -import Handler.Utils.Table.Cells import qualified Database.Esqueleto as E diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index ba4be993c..85b81efb9 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -2,7 +2,6 @@ module Handler.Term where import Import import Handler.Utils -import Handler.Utils.Table.Cells import qualified Data.Map as Map import qualified Database.Esqueleto as E diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index babe6563f..0aa65b045 100644 --- a/src/Handler/Tutorial.hs +++ b/src/Handler/Tutorial.hs @@ -7,7 +7,6 @@ module Handler.Tutorial import Import import Handler.Utils import Handler.Utils.Tutorial -import Handler.Utils.Table.Cells import Handler.Utils.Delete import Handler.Utils.Communication import Handler.Utils.Form.Occurrences diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index a5441c01d..3c3921960 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -8,7 +8,6 @@ import Utils.Form -- import Utils.DB import Handler.Utils import Handler.Utils.Tutorial -import Handler.Utils.Table.Columns import Database.Persist.Sql (deleteWhereCount) import qualified Data.CaseInsensitive as CI diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index a9d46dfae..a5cab4907 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -10,7 +10,6 @@ import Handler.Utils import Handler.Utils.Tokens import Handler.Utils.Users import Handler.Utils.Invitations -import Handler.Utils.Table.Cells import qualified Auth.LDAP as Auth diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 0d181cbbd..18a94bb9f 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -4,21 +4,15 @@ module Handler.Utils import Import -import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.Set as Set -import Data.CaseInsensitive (original) --- import qualified Data.CaseInsensitive as CI import qualified Data.Conduit.List as Conduit -import Text.Hamlet (shamletFile) - import Handler.Utils.DateTime as Handler.Utils import Handler.Utils.Form as Handler.Utils import Handler.Utils.Table as Handler.Utils -import Handler.Utils.Table.Pagination as Handler.Utils import Handler.Utils.Zip as Handler.Utils import Handler.Utils.Rating as Handler.Utils hiding (extractRatings) @@ -27,6 +21,8 @@ import Handler.Utils.Sheet as Handler.Utils import Handler.Utils.Mail as Handler.Utils import Handler.Utils.ContentDisposition as Handler.Utils import Handler.Utils.I18n as Handler.Utils +import Handler.Utils.Widgets as Handler.Utils +import Handler.Utils.Database as Handler.Utils import System.FilePath.Posix (takeFileName) @@ -88,91 +84,6 @@ serveZipArchive archiveName source = do source .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder - ---------- --- Simple utilities for consistent display --- Please use these throughout, to ensure that users have a consistent experience - -tidFromText :: Text -> Maybe TermId -tidFromText = fmap TermKey . maybeRight . termFromText - --- | Display given UTCTime and maybe an invisible icon if it is in the future --- --- Also see `Handler.Utils.Table.Cells.dateTimeCellVisible` for a similar function (in case of refactoring) -visibleUTCTime :: SelDateTimeFormat -> UTCTime -> Widget -visibleUTCTime dtf t = do - let timeStampWgt = formatTimeW dtf t - now <- liftIO getCurrentTime - if now >= t - then timeStampWgt - else $(widgetFile "widgets/date-time/yet-invisible") - - --- | Simple link to a known route -simpleLink :: Widget -> Route UniWorX -> Widget -simpleLink lbl url = [whamlet|^{lbl}|] - -simpleLinkI :: SomeMessage UniWorX -> Route UniWorX -> Widget -simpleLinkI lbl url = [whamlet|_{lbl}|] - --- | toWidget-Version of @nameHtml@, for convenience -nameWidget :: Text -- ^ userDisplayName - -> Text -- ^ userSurname - -> Widget -nameWidget displayName surname = toWidget $ nameHtml displayName surname - --- | toWidget-Version of @nameEmailHtml@, for convenience -nameEmailWidget :: UserEmail -- ^ userEmail - -> Text -- ^ userDisplayName - -> Text -- ^ userSurname - -> Widget -nameEmailWidget email displayName surname = toWidget $ nameEmailHtml email displayName surname - --- | uncurried Version for @nameEmailWidget@ needed in hamlet, where TH cannot be used -nameEmailWidget' :: (UserEmail, Text, Text)-> Widget -nameEmailWidget' = $(uncurryN 3) nameEmailWidget - --- | Show user's displayName, highlighting the surname if possible. --- Otherwise appends the surname in parenthesis -nameHtml :: Text -> Text -> Html -nameHtml displayName surname - | null surname = toHtml displayName - | otherwise = case reverse $ T.splitOn surname displayName of - [_notContained] -> [shamlet|$newline never - #{displayName} ( - #{surname} - )|] - (suffix:prefixes) -> - let prefix = T.intercalate surname $ reverse prefixes - in [shamlet|$newline never - #{prefix} - #{surname} - #{suffix} - |] - [] -> error "Data.Text.splitOn returned empty list in violation of specification." - --- | Like nameHtml just show a users displayname with hightlighted surname, --- but also wrap the name with a mailto-link -nameEmailHtml :: UserEmail -> Text -> Text -> Html -nameEmailHtml email displayName surname = - wrapMailto email $ nameHtml displayName surname - --- | Wrap mailto around given Html using single hamlet-file for consistency -wrapMailto :: UserEmail -> Html -> Html -wrapMailto (original -> email) linkText - | null email = linkText - | otherwise = $(shamletFile "templates/widgets/link-email.hamlet") - --- | Just show an email address in a standard way, for convenience inside hamlet files. -mailtoHtml :: UserEmail -> Html -mailtoHtml email = wrapMailto email $(shamletFile "templates/widgets/email.hamlet") - --- | Generic i18n text for "edited at sometime by someone" -editedByW :: SelDateTimeFormat -> UTCTime -> Text -> Widget -editedByW fmt tm usr = do - ft <- handlerToWidget $ formatTime fmt tm - [whamlet|_{MsgEditedBy usr ft}|] - -- | Prefix a message with a short course id, -- eg. for window title bars, etc. -- This function should help to make this consistent everywhere diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index cee1573df..159ad7779 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -1,5 +1,5 @@ module Handler.Utils.DateTime - ( utcToLocalTime + ( utcToLocalTime, utcToZonedTime , localTimeToUTC, TZ.LocalToUTCResult(..) , toMidnight, beforeMidnight, toMidday, toMorning , formatDiffDays @@ -20,7 +20,7 @@ import Import import Data.Time.Zones import qualified Data.Time.Zones as TZ -import Data.Time hiding (formatTime, localTimeToUTC, utcToLocalTime) +import Data.Time hiding (formatTime, localTimeToUTC, utcToLocalTime, utcToZonedTime) -- import Data.Time.Clock (addUTCTime,nominalDay) import qualified Data.Time.Format as Time @@ -37,6 +37,9 @@ import Data.Time.Clock.System (systemEpochDay) utcToLocalTime :: UTCTime -> LocalTime utcToLocalTime = TZ.utcToLocalTimeTZ appTZ +utcToZonedTime :: UTCTime -> ZonedTime +utcToZonedTime = ZonedTime <$> TZ.utcToLocalTimeTZ appTZ <*> TZ.timeZoneForUTCTime appTZ + localTimeToUTC :: LocalTime -> LocalToUTCResult localTimeToUTC = TZ.localTimeToUTCFull appTZ diff --git a/src/Handler/Utils/ExamOffice/Exam/Auth.hs b/src/Handler/Utils/ExamOffice/Exam/Auth.hs new file mode 100644 index 000000000..3d8bff67a --- /dev/null +++ b/src/Handler/Utils/ExamOffice/Exam/Auth.hs @@ -0,0 +1,34 @@ +module Handler.Utils.ExamOffice.Exam.Auth + ( examOfficeExamResultAuth + ) where + +import Import.NoFoundation + +import qualified Database.Esqueleto as E + + +examOfficeExamResultAuth :: E.SqlExpr (E.Value UserId) -- ^ office + -> E.SqlExpr (Entity ExamResult) + -> E.SqlExpr (E.Value Bool) +examOfficeExamResultAuth authId examResult = authByUser E.||. authByField + where + authByField = E.exists . E.from $ \(examOfficeField `E.InnerJoin` studyFeatures) -> do + E.on $ studyFeatures E.^. StudyFeaturesField E.==. examOfficeField E.^. ExamOfficeFieldField + E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. examResult E.^. ExamResultUser + E.&&. examOfficeField E.^. ExamOfficeFieldOffice E.==. authId + E.&&. examOfficeField E.^. ExamOfficeFieldField E.==. studyFeatures E.^. StudyFeaturesField + E.where_ $ examOfficeField E.^. ExamOfficeFieldForced + E.||. E.exists (E.from $ \userFunction -> + E.where_ $ userFunction E.^. UserFunctionUser E.==. authId + E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice + E.&&. E.not_ (E.exists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` courseUserExamOfficeOptOut) -> do + E.on $ courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutCourse E.==. course E.^. CourseId + E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId + E.where_ $ exam E.^. ExamId E.==. examResult E.^. ExamResultExam + E.where_ $ courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutUser E.==. examResult E.^. ExamResultUser + E.&&. courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutSchool E.==. userFunction E.^. UserFunctionSchool + ) + ) + authByUser = E.exists . E.from $ \examOfficeUser -> + E.where_ $ examOfficeUser E.^. ExamOfficeUserOffice E.==. authId + E.&&. examOfficeUser E.^. ExamOfficeUserUser E.==. examResult E.^. ExamResultUser diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index 1884cbe09..ecc5af873 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -32,7 +32,6 @@ import qualified Data.ByteString.Lazy as Lazy.ByteString import Text.Read (readEither) -import System.FilePath import qualified System.FilePath.Cryptographic as FilePath (decrypt) import qualified Database.Esqueleto as E diff --git a/src/Handler/Utils/Table.hs b/src/Handler/Utils/Table.hs index 626fa7e11..2e204b2cc 100644 --- a/src/Handler/Utils/Table.hs +++ b/src/Handler/Utils/Table.hs @@ -1,4 +1,6 @@ -module Handler.Utils.Table where +module Handler.Utils.Table + ( module Handler.Utils.Table + ) where -- General Utilities for Tables import Import @@ -8,13 +10,18 @@ import Control.Monad.Except import Text.Blaze as B import Colonnade -import Yesod.Colonnade +import Yesod.Colonnade as Yesod import Data.List ((!!)) import Data.Either + +import Handler.Utils.Table.Pagination as Handler.Utils.Table +import Handler.Utils.Table.Columns as Handler.Utils.Table +import Handler.Utils.Table.Cells as Handler.Utils.Table -- Table design +{-# DEPRECATED tableDefault, tableSortable "Use dbTable" #-} tableDefault :: Attribute tableDefault = customAttribute "class" "table table-striped table-hover" @@ -22,6 +29,7 @@ tableSortable :: Attribute tableSortable = customAttribute "class" "js-sortable" -- Colonnade Tools +{-# DEPRECATED numberColonnade, pairColonnade "Use dbTable" #-} numberColonnade :: (IsString c) => Colonnade Headed Int c numberColonnade = headed "Nr" (fromString.show) @@ -30,6 +38,7 @@ pairColonnade a b = mconcat [ lmap fst a, lmap snd b] -- Table Modification +{-# DEPRECATED encodeHeadedWidgetTableNumbered, headedRowSelector "Use dbTable" #-} encodeHeadedWidgetTableNumbered :: Attribute -> Colonnade Headed a (WidgetT site IO ()) -> [a] -> WidgetT site IO () encodeHeadedWidgetTableNumbered attrs colo tdata = encodeWidgetTable attrs (mconcat [numberCol, lmap snd colo]) (zip [1..] tdata) @@ -76,7 +85,7 @@ headedRowSelector toExternal fromExternal attrs colonnade tdata = do let selColonnade :: Colonnade Headed Int (Cell UniWorX) - selColonnade = headed "Markiert" $ cell . fvInput . (selectionBoxes !!) + selColonnade = headed "Markiert" $ Yesod.cell . fvInput . (selectionBoxes !!) collectResult :: [FormResult a] -> FormResult [a] collectResult [] = FormSuccess [] diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 2cb7df96c..625198a14 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -13,7 +13,9 @@ import Control.Monad.Trans.Writer (WriterT) import Text.Blaze (ToMarkup(..)) -import Handler.Utils +import Handler.Utils.Table.Pagination +import Handler.Utils.DateTime +import Handler.Utils.Widgets import Utils.Occurrences diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 595b5ebe8..0bbfaf1b1 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -15,8 +15,10 @@ import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils (mkExactFilter, mkExactFilterWith, mkContainsFilter, mkContainsFilterWith, anyFilter) -import Handler.Utils import Handler.Utils.Table.Cells +import Handler.Utils.Table.Pagination +import Handler.Utils.Form +import Handler.Utils.Widgets import qualified Data.CaseInsensitive as CI @@ -25,6 +27,8 @@ import Colonnade.Encode (Colonnade(..), OneColonnade(..)) import Text.Blaze (toMarkup) +import qualified Data.Set as Set + -------------------------------- -- Generic Columns @@ -199,6 +203,57 @@ fltrAllocationActiveUI :: DBFilterUI fltrAllocationActiveUI mPrev = prismAForm (singletonFilter "active" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgAllocationActive) +--------------------- +-- Exam occurences -- +--------------------- + +colOccurrenceStart :: OpticColonnade UTCTime +colOccurrenceStart resultStart = Colonnade.singleton (fromSortable header) body + where + header = Sortable (Just "occurrence-start") (i18nCell MsgExamOccurrenceStart) + body = views resultStart dateTimeCell + +sortOccurrenceStart :: PersistField utctime => OpticSortColumn utctime +sortOccurrenceStart queryStart = singletonMap "occurrence-start" . SortColumn $ view queryStart + +------------------ +-- Exam results -- +------------------ + +colExamResult :: Bool -- ^ Show grades? + -> OpticColonnade ExamResultGrade +colExamResult showGrades resultResult = Colonnade.singleton (fromSortable header) body + where + header = Sortable (Just "exam-result") (i18nCell MsgExamResult) + body = views resultResult $ bool (i18nCell . fmap (view passingGrade)) i18nCell showGrades + +sortExamResult :: Bool -- ^ Show grades? + -> OpticSortColumn (Maybe ExamResultGrade) +sortExamResult showGrades queryResult = singletonMap "exam-result" $ if + | showGrades -> SortColumn $ view queryResult + | otherwise -> SortColumn . views queryResult $ E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50] + +fltrExamResultPoints :: Bool -- ^ Show grades? + -> OpticFilterColumn t ExamResultGrade +fltrExamResultPoints showGrades queryExamResult = singletonMap "exam-result" . FilterColumn $ \row criteria -> if + | Set.null criteria -> E.true + | otherwise -> let matches :: [ExamResultGrade] + matches = filter (\res -> oany (((==) `on` viewResult) res) criteria) universeF + + viewResult + | showGrades = id + | otherwise = fmap (view $ passingGrade . from passingGrade) + in view queryExamResult row `E.in_` E.valList matches + + +fltrExamResultPointsUI :: Bool -- ^ Show grades? + -> DBFilterUI +fltrExamResultPointsUI showGrades mPrev = prismAForm (singletonFilter "exam-result" . maybePrism _PathPiece) mPrev $ aopt field (fslI MsgExamResult) + where + field + | showGrades = examResultField examGradeField + | otherwise = convertField (over _examResult $ review passingGrade) (over _examResult $ view passingGrade) $ examResultField examPassedField + ------------------------- -- Course Applications -- ------------------------- @@ -709,12 +764,16 @@ anchorColonnadeM mkUrl = imapColonnade anchorColonnade' emptyOpticColonnade :: forall h r' focus c. ( Monoid c ) - => Fold r' focus -- ^ View on @focus@ within @r'@ that may produce any number of results + => Getting (Endo [focus]) r' focus -- ^ View on @focus@ within @r'@ that may produce any number of results -> ((forall focus'. Getting focus' r' focus) -> Colonnade h r' c) -- ^ `OpticColonnade focus` -> Colonnade h r' c --- ^ Generalize an `OpticColonnade` from `Getter` to `Fold` by defaulting results of zero or more than one values to `mempty` -emptyOpticColonnade l c = Colonnade $ oldColonnade <&> \column -> column { oneColonnadeEncode = \s -> defaultColumn s $ oneColonnadeEncode column } +-- ^ Generalize an `OpticColonnade` from `Getter` to `Fold` by defaulting results of zero values to `mempty` +emptyOpticColonnade l' c + = Colonnade $ oldColonnade <&> \column -> column { oneColonnadeEncode = \s -> defaultColumn s $ oneColonnadeEncode column } where + l :: Fold r' focus + l = folding (toListOf l') + Colonnade oldColonnade = c $ singular l -- This is safe (as long as we don't evaluate the `oneColonnadeEncode`s) -- because `Getter s a` is of kind @k -> *@ and can thus only be inspected @@ -722,7 +781,9 @@ emptyOpticColonnade l c = Colonnade $ oldColonnade <&> \column -> column { oneCo -- and the definition of `OneColonnade` defaultColumn :: r' -> (r' -> c) -> c - defaultColumn x f = case x ^.. l of - [_] -> f x - _ -> mempty + defaultColumn x f + | has l x = f x + | otherwise = mempty +maybeOpticSortColumn :: OpticSortColumn (Maybe val) -> OpticSortColumn val +maybeOpticSortColumn sortColumn = \queryFocus -> sortColumn $ queryFocus . to E.just diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 9aad2bdeb..99616ae6e 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -11,8 +11,9 @@ module Handler.Utils.Table.Pagination , module Handler.Utils.Table.Pagination.CsvColumnExplanations , DBCsvActionMode(..) , DBCsvDiff(..), _DBCsvDiffNew, _DBCsvDiffExisting, _DBCsvDiffMissing, _dbCsvOldKey, _dbCsvOld, _dbCsvNewKey, _dbCsvNew - , DBTCsvEncode, DBTCsvDecode(..) - , DBTable(..), DBFilterUI, noCsvEncode, IsDBTable(..), DBCell(..) + , DBTCsvEncode(..), DBTCsvDecode(..) + , DBTable(..), DBFilterUI, IsDBTable(..), DBCell(..) + , noCsvEncode, simpleCsvEncode, simpleCsvEncodeM , singletonFilter , DBParams(..) , cellAttrs, cellContents @@ -108,6 +109,8 @@ import qualified Data.Conduit.List as C import Handler.Utils.DateTime (formatTimeRangeW) import qualified Control.Monad.Catch as Catch +import Data.Dynamic + #if MIN_VERSION_base(4,11,0) type Monoid' = Monoid @@ -337,6 +340,8 @@ instance Button UniWorX ButtonCsvMode where data DBCsvMode = DBCsvNormal | DBCsvExport + { dbCsvExportData :: Dynamic + } | DBCsvImport { dbCsvFiles :: [FileInfo] } @@ -507,7 +512,16 @@ singletonFilter key = prism' fromInner (fmap Just . fromOuter) fromOuter = Map.lookup key >=> listToMaybe -type DBTCsvEncode r' csv = DictMaybe (ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv) (Conduit r' (YesodDB UniWorX) csv) +data DBTCsvEncode r' k' csv = forall exportData. + ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv + , DBTableKey k' + , Typeable exportData + ) => DBTCsvEncode + { dbtCsvExportForm :: AForm (YesodDB UniWorX) exportData + , dbtCsvDoEncode :: exportData -> Conduit (k', r') (YesodDB UniWorX) csv + , dbtCsvName :: FilePath + , dbtCsvNoExportData :: Maybe (AnIso' exportData ()) + } data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException. ( FromNamedRecord csv, ToNamedRecord csv, DefaultOrdered csv , DBTableKey k' @@ -542,16 +556,41 @@ data DBTable m x = forall a r r' h i t k k' csv. , dbtFilterUI :: DBFilterUI , dbtStyle :: DBStyle r' , dbtParams :: DBParams m x - , dbtCsvEncode :: DBTCsvEncode r' csv + , dbtCsvEncode :: Maybe (DBTCsvEncode r' k' csv) , dbtCsvDecode :: Maybe (DBTCsvDecode r' k' csv) , dbtIdent :: i } type DBFilterUI = Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) -noCsvEncode :: DictMaybe (ToNamedRecord Void, DefaultOrdered Void, CsvColumnsExplained Void) (Conduit r' (YesodDB UniWorX) Void) +noCsvEncode :: Maybe (DBTCsvEncode r' k' Void) noCsvEncode = Nothing +simpleCsvEncode :: ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv + , DBTableKey k' + , Textual fp + ) + => fp -> (r' -> csv) -> Maybe (DBTCsvEncode r' k' csv) +simpleCsvEncode fName f = Just DBTCsvEncode + { dbtCsvExportForm = pure () + , dbtCsvDoEncode = \() -> C.map (f . view _2) + , dbtCsvName = unpack fName + , dbtCsvNoExportData = Just id + } + +simpleCsvEncodeM :: ( ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv + , DBTableKey k' + , Textual fp + ) + => fp -> ReaderT r' (YesodDB UniWorX) csv -> Maybe (DBTCsvEncode r' k' csv) +simpleCsvEncodeM fName f = Just DBTCsvEncode + { dbtCsvExportForm = pure () + , dbtCsvDoEncode = \() -> C.mapM (runReaderT f . view _2) + , dbtCsvName = unpack fName + , dbtCsvNoExportData = Just id + } + + class (MonadHandler m, HandlerSite m ~ UniWorX, Monoid' x, Monoid' (DBCell m x), Default (DBParams m x)) => IsDBTable (m :: * -> *) (x :: *) where data DBParams m x :: * type DBResult m x :: * @@ -752,6 +791,7 @@ instance Monoid' x => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang instance IsDBTable m a => IsString (DBCell m a) where fromString = cell . fromString + -- | DB-backed tables with pagination, may short-circuit a handler if the frontend only asks for the table content, i.e. handler actions after calls to dbTable may not happen at all. dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> DB (DBResult m x) dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. } = do @@ -838,7 +878,20 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db tblLink' :: (QueryText -> QueryText) -> Widget tblLink' = toWidget <=< toTextUrl . tblLink - ((csvExportRes, csvExportWdgt), csvExportEnctype) <- lift . runFormGet . identifyForm FIDDBTableCsvExport . set (mapped . mapped . _1 . mapped) DBCsvExport $ buttonForm' [BtnCsvExport] + let noExportData + | Just DBTCsvEncode{..} <- dbtCsvEncode + = is _Just dbtCsvNoExportData + | otherwise + = True + + ((csvExportRes, csvExportWdgt), csvExportEnctype) <- bool runFormPost runFormGet noExportData . identifyForm FIDDBTableCsvExport . renderAForm FormDBTableCsvExport . fmap DBCsvExport $ case dbtCsvEncode of + Just DBTCsvEncode{..} + | Just (cloneIso -> noExportData') <- dbtCsvNoExportData + -> toDyn . view (noExportData' . from noExportData') <$> dbtCsvExportForm + | otherwise + -> toDyn <$> dbtCsvExportForm + Nothing + -> pure $ toDyn () ((csvImportRes, csvImportWdgt), csvImportEnctype) <- lift . runFormPost . identifyForm FIDDBTableCsvImport . renderAForm FormDBTableCsvImport $ DBCsvImport <$> areq fileFieldMultiple (fslI MsgCsvFile) Nothing @@ -848,13 +901,13 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db , csvImportRes <* guard (is _Just dbtCsvDecode) , FormSuccess DBCsvNormal ] - csvExportWdgt' = wrapForm csvExportWdgt FormSettings - { formMethod = GET + csvExportWdgt' = wrapForm' BtnCsvExport csvExportWdgt FormSettings + { formMethod = bool POST GET noExportData , formAction = Just $ tblLink id , formEncoding = csvExportEnctype - , formAttrs = [("target", "_blank"), ("class", "form--inline")] - , formSubmit = FormNoSubmit - , formAnchor = Nothing :: Maybe Text + , formAttrs = [] + , formSubmit = FormSubmit + , formAnchor = Just $ wIdent "csv-export" } csvImportWdgt' = wrapForm' BtnCsvImport csvImportWdgt FormSettings { formMethod = POST @@ -862,11 +915,11 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db , formEncoding = csvImportEnctype , formAttrs = [] , formSubmit = FormSubmit - , formAnchor = Nothing :: Maybe Text + , formAnchor = Just $ wIdent "csv-import" } csvImportExplanation = modal [whamlet|_{MsgCsvImportExplanationLabel}|] $ Right $(i18nWidgetFile "table/csv-import-explanation") csvColExplanations = case dbtCsvEncode of - (Just (Dict, _) :: DBTCsvEncode _ csv) -> assertM' (not . null) . Map.toList . csvColumnsExplanations $ Proxy @csv + Just (DBTCsvEncode{} :: DBTCsvEncode r' k' csv) -> assertM' (not . null) . Map.toList . csvColumnsExplanations $ Proxy @csv Nothing -> Nothing csvColExplanations' = case csvColExplanations of Just csvColExplanations'' -> modal [whamlet|_{MsgCsvColumnsExplanationsLabel}|] $ Right $(widgetFile "table/csv-column-explanations") @@ -877,7 +930,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db res <- dbtSQLQuery t E.orderBy $ concatMap (sqlSortDirection t) psSorting' case csvMode of - FormSuccess DBCsvExport -> return () + FormSuccess DBCsvExport{} -> return () FormSuccess DBCsvImport{} -> return () _other -> do case previousKeys of @@ -908,10 +961,12 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db formResult csvMode $ \case - DBCsvExport - | Just (Dict, dbtCsvEncode') <- dbtCsvEncode -> do - setContentDisposition' . Just $ unpack dbtIdent <.> unpack extensionCsv - sendResponse <=< liftHandlerT . respondCsvDB $ C.sourceList rows .| dbtCsvEncode' + DBCsvExport{..} + | Just DBTCsvEncode{..} <- dbtCsvEncode + , Just exportData <- fromDynamic dbCsvExportData -> do + let ensureExtension ext fName = bool (addExtension ext) id (ext `isExtensionOf` fName) fName + setContentDisposition' . Just $ ensureExtension (unpack extensionCsv) dbtCsvName + sendResponse <=< liftHandlerT . respondCsvDB $ C.sourceList (zip currentKeys rows) .| dbtCsvDoEncode exportData >> lift E.transactionSave DBCsvImport{..} | Just (DBTCsvDecode{ dbtCsvClassifyAction = dbtCsvClassifyAction :: csvAction -> csvActionClass , .. diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs new file mode 100644 index 000000000..7668e706b --- /dev/null +++ b/src/Handler/Utils/Widgets.hs @@ -0,0 +1,94 @@ +module Handler.Utils.Widgets where + +import Import +import qualified Data.Text as T +import qualified Data.CaseInsensitive as CI + +import Text.Hamlet (shamletFile) + +import Handler.Utils.DateTime + + +--------- +-- Simple utilities for consistent display +-- Please use these throughout, to ensure that users have a consistent experience + +tidFromText :: Text -> Maybe TermId +tidFromText = fmap TermKey . maybeRight . termFromText + +-- | Display given UTCTime and maybe an invisible icon if it is in the future +-- +-- Also see `Handler.Utils.Table.Cells.dateTimeCellVisible` for a similar function (in case of refactoring) +visibleUTCTime :: SelDateTimeFormat -> UTCTime -> Widget +visibleUTCTime dtf t = do + let timeStampWgt = formatTimeW dtf t + now <- liftIO getCurrentTime + if now >= t + then timeStampWgt + else $(widgetFile "widgets/date-time/yet-invisible") + + +-- | Simple link to a known route +simpleLink :: Widget -> Route UniWorX -> Widget +simpleLink lbl url = [whamlet|^{lbl}|] + +simpleLinkI :: SomeMessage UniWorX -> Route UniWorX -> Widget +simpleLinkI lbl url = [whamlet|_{lbl}|] + +-- | toWidget-Version of @nameHtml@, for convenience +nameWidget :: Text -- ^ userDisplayName + -> Text -- ^ userSurname + -> Widget +nameWidget displayName surname = toWidget $ nameHtml displayName surname + +-- | toWidget-Version of @nameEmailHtml@, for convenience +nameEmailWidget :: UserEmail -- ^ userEmail + -> Text -- ^ userDisplayName + -> Text -- ^ userSurname + -> Widget +nameEmailWidget email displayName surname = toWidget $ nameEmailHtml email displayName surname + +-- | uncurried Version for @nameEmailWidget@ needed in hamlet, where TH cannot be used +nameEmailWidget' :: (UserEmail, Text, Text)-> Widget +nameEmailWidget' = $(uncurryN 3) nameEmailWidget + +-- | Show user's displayName, highlighting the surname if possible. +-- Otherwise appends the surname in parenthesis +nameHtml :: Text -> Text -> Html +nameHtml displayName surname + | null surname = toHtml displayName + | otherwise = case reverse $ T.splitOn surname displayName of + [_notContained] -> [shamlet|$newline never + #{displayName} ( + #{surname} + )|] + (suffix:prefixes) -> + let prefix = T.intercalate surname $ reverse prefixes + in [shamlet|$newline never + #{prefix} + #{surname} + #{suffix} + |] + [] -> error "Data.Text.splitOn returned empty list in violation of specification." + +-- | Like nameHtml just show a users displayname with hightlighted surname, +-- but also wrap the name with a mailto-link +nameEmailHtml :: UserEmail -> Text -> Text -> Html +nameEmailHtml email displayName surname = + wrapMailto email $ nameHtml displayName surname + +-- | Wrap mailto around given Html using single hamlet-file for consistency +wrapMailto :: UserEmail -> Html -> Html +wrapMailto (CI.original -> email) linkText + | null email = linkText + | otherwise = $(shamletFile "templates/widgets/link-email.hamlet") + +-- | Just show an email address in a standard way, for convenience inside hamlet files. +mailtoHtml :: UserEmail -> Html +mailtoHtml email = wrapMailto email $(shamletFile "templates/widgets/email.hamlet") + +-- | Generic i18n text for "edited at sometime by someone" +editedByW :: SelDateTimeFormat -> UTCTime -> Text -> Widget +editedByW fmt tm usr = do + ft <- handlerToWidget $ formatTime fmt tm + [whamlet|_{MsgEditedBy usr ft}|] diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index e0068c291..7d8b81322 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -60,6 +60,8 @@ import Data.Semigroup as Import (Semigroup, Min(..), Max(..)) import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..), Endo(..), Alt(..)) import Data.Binary as Import (Binary) +import System.FilePath as Import hiding (joinPath, normalise, isValid, makeValid) + import Numeric.Natural as Import (Natural) import Data.Ratio as Import ((%)) @@ -74,12 +76,16 @@ import Control.Monad.Random.Class as Import (MonadRandom(..)) import Control.Monad.Morph as Import import Control.Monad.Trans.Resource as Import (ReleaseKey) +import Control.Monad.Trans.Reader as Import + ( reader, Reader, runReader, mapReader, withReader + , ReaderT(..), mapReaderT, withReaderT + ) import Jose.Jwt as Import (Jwt) import Data.Time.Calendar as Import import Data.Time.Clock as Import -import Data.Time.LocalTime as Import hiding (utcToLocalTime, localTimeToUTC) +import Data.Time.LocalTime as Import hiding (utcToLocalTime, utcToZonedTime, localTimeToUTC) import Time.Types as Import (WeekDay(..)) import Network.Mime as Import diff --git a/src/Utils.hs b/src/Utils.hs index 0e81738d1..e3201af90 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -286,7 +286,7 @@ cutOffPercent :: Double -> Double -> Double -> Double cutOffPercent offset full achieved | full <= achieved = 0 | full <= 0 = 0 -  | otherwise = offset + (1-offset) * (1 - percent) + | otherwise = offset + (1-offset) * (1 - percent) where percent = achieved / full @@ -300,6 +300,9 @@ cutOffPercent offset full achieved notUsed :: Monoid m => a -> m notUsed = const mempty +guardMonoid :: Monoid m => Bool -> m -> m +guardMonoid False _ = mempty +guardMonoid True x = x ------------ -- Tuples -- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index feb7d21c9..88fbb1155 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -676,6 +676,9 @@ cfStrip = guardField (not . T.null . repack) . convertField (repack . T.strip . cfCI :: (Functor m, CI.FoldCase s) => Field m s -> Field m (CI s) cfCI = convertField CI.mk CI.original +isoField :: Functor m => AnIso' a b -> Field m a -> Field m b +isoField (cloneIso -> fieldIso) = convertField (view fieldIso) (review fieldIso) + selectField' :: ( Eq a , RenderMessage (HandlerSite m) FormMessage @@ -761,7 +764,7 @@ wrapForm' btn formWidget FormSettings{..} = do ------------------- -- | Use this type to pass information to the form template -data FormLayout = FormStandard | FormDBTableFilter | FormDBTablePagesize | FormDBTableCsvImport +data FormLayout = FormStandard | FormDBTableFilter | FormDBTablePagesize | FormDBTableCsvImport | FormDBTableCsvExport data AFormMessage = MsgAFormFieldRequiredTip diff --git a/templates/exam-office/exam-result-synced.hamlet b/templates/exam-office/exam-result-synced.hamlet new file mode 100644 index 000000000..a121c879e --- /dev/null +++ b/templates/exam-office/exam-result-synced.hamlet @@ -0,0 +1,32 @@ +$newline never +

+ ^{nameWidget (userDisplayName user) (userSurname user)} + + + + + + +
+ _{MsgExamUserSyncOfficeName} + _{MsgExamUserSyncTime} + _{MsgExamUserSyncSchools} + $forall sync <- syncs' + $case sync + $of Right (officeDisplayName, officeSurname, time, sshs) +
+ + ^{nameWidget officeDisplayName officeSurname} + + ^{formatTimeW SelFormatDateTime time} + +
    + $forall ssh' <- sshs + #{ssh'} + $of Left lastChange +
+ _{MsgExamUserSyncLastChange} + + + ^{formatTimeW SelFormatDateTime lastChange} + diff --git a/templates/exam-office/exam-results.hamlet b/templates/exam-office/exam-results.hamlet new file mode 100644 index 000000000..dea20c2a7 --- /dev/null +++ b/templates/exam-office/exam-results.hamlet @@ -0,0 +1,2 @@ +$newline never +^{examUsersTable} diff --git a/templates/table/csv-column-explanations.hamlet b/templates/table/csv-column-explanations.hamlet index c39403fe7..bc72a43f9 100644 --- a/templates/table/csv-column-explanations.hamlet +++ b/templates/table/csv-column-explanations.hamlet @@ -3,5 +3,3 @@ $forall (colName, colExplanation) <- csvColExplanations''
#{decodeUtf8 colName}
^{colExplanation} -
- ^{csvExportWdgt'}