feat(exam-office): grade export
This commit is contained in:
Gregor Kleen
parent
5cec146cb7
commit
72a7f6e8a8
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -9,6 +9,6 @@ ExamOfficeUser
|
||||
UniqueExamOfficeUser office user
|
||||
ExamOfficeResultSynced
|
||||
office UserId
|
||||
result ExamResult
|
||||
result ExamResultId
|
||||
time UTCTime
|
||||
UniqueExamOfficeResultSynced office result
|
||||
3
routes
3
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:
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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 ((&))
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -5,7 +5,6 @@ module Handler.Exam.List
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Table.Cells
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -2,7 +2,6 @@ module Handler.School where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Table.Columns
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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|<a href=@{url}>^{lbl}|]
|
||||
|
||||
simpleLinkI :: SomeMessage UniWorX -> Route UniWorX -> Widget
|
||||
simpleLinkI lbl url = [whamlet|<a href=@{url}>_{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} (
|
||||
<b .surname>#{surname}
|
||||
)|]
|
||||
(suffix:prefixes) ->
|
||||
let prefix = T.intercalate surname $ reverse prefixes
|
||||
in [shamlet|$newline never
|
||||
#{prefix}
|
||||
<b .surname>#{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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
34
src/Handler/Utils/ExamOffice/Exam/Auth.hs
Normal file
34
src/Handler/Utils/ExamOffice/Exam/Auth.hs
Normal file
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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 []
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
, ..
|
||||
|
||||
94
src/Handler/Utils/Widgets.hs
Normal file
94
src/Handler/Utils/Widgets.hs
Normal file
@ -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|<a href=@{url}>^{lbl}|]
|
||||
|
||||
simpleLinkI :: SomeMessage UniWorX -> Route UniWorX -> Widget
|
||||
simpleLinkI lbl url = [whamlet|<a href=@{url}>_{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} (
|
||||
<b .surname>#{surname}
|
||||
)|]
|
||||
(suffix:prefixes) ->
|
||||
let prefix = T.intercalate surname $ reverse prefixes
|
||||
in [shamlet|$newline never
|
||||
#{prefix}
|
||||
<b .surname>#{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}|]
|
||||
@ -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
|
||||
|
||||
@ -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 --
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
32
templates/exam-office/exam-result-synced.hamlet
Normal file
32
templates/exam-office/exam-result-synced.hamlet
Normal file
@ -0,0 +1,32 @@
|
||||
$newline never
|
||||
<h1>
|
||||
^{nameWidget (userDisplayName user) (userSurname user)}
|
||||
|
||||
<table .table .table--striped .table--hover>
|
||||
<thead>
|
||||
<tr .table__row .table__row--head>
|
||||
<td>
|
||||
<td .table__th>_{MsgExamUserSyncOfficeName}
|
||||
<td .table__th>_{MsgExamUserSyncTime}
|
||||
<td .table__th>_{MsgExamUserSyncSchools}
|
||||
$forall sync <- syncs'
|
||||
$case sync
|
||||
$of Right (officeDisplayName, officeSurname, time, sshs)
|
||||
<tr .table__row>
|
||||
<td>
|
||||
<td .table__td>
|
||||
^{nameWidget officeDisplayName officeSurname}
|
||||
<td .table__td>
|
||||
^{formatTimeW SelFormatDateTime time}
|
||||
<td .table__td>
|
||||
<ul .list--inline .list--comma-separated>
|
||||
$forall ssh' <- sshs
|
||||
#{ssh'}
|
||||
$of Left lastChange
|
||||
<tr .table__row>
|
||||
<td .table__td style="text-align: right">
|
||||
_{MsgExamUserSyncLastChange}
|
||||
<td .table__td>
|
||||
<td .table__td>
|
||||
^{formatTimeW SelFormatDateTime lastChange}
|
||||
<td .table__td>
|
||||
2
templates/exam-office/exam-results.hamlet
Normal file
2
templates/exam-office/exam-results.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
^{examUsersTable}
|
||||
@ -3,5 +3,3 @@
|
||||
$forall (colName, colExplanation) <- csvColExplanations''
|
||||
<dt .deflist__dt>#{decodeUtf8 colName}
|
||||
<dd .deflist__dd>^{colExplanation}
|
||||
<div>
|
||||
^{csvExportWdgt'}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user