Merge branch 'master' into 186-nutzer-ohne-ldap
This commit is contained in:
Gregor Kleen
commit
a1242ad2c3
@ -9,6 +9,8 @@
|
||||
Unterstützung von Tabellenzusammenfassungen, z.B. Punktsummen
|
||||
|
||||
Intelligente Verteilung von Abgaben auf Korrektoren (z.B. bei Krankheit)
|
||||
|
||||
Übungsblätter können Abgabe von Dateien verbieten und angeben ob ZIP-Archive entpackt werden sollen
|
||||
|
||||
* Version 06.08.2018
|
||||
|
||||
|
||||
7
db.hs
7
db.hs
@ -196,11 +196,11 @@ fillDb = do
|
||||
void . insert $ DegreeCourse ffp sdMst sdInf
|
||||
void . insert $ Lecturer jost ffp
|
||||
void . insert $ Lecturer gkleen ffp
|
||||
sheetkey <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing
|
||||
sheetkey <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True)
|
||||
insert_ $ SheetEdit gkleen now sheetkey
|
||||
sheetkey <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing
|
||||
sheetkey <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True)
|
||||
insert_ $ SheetEdit gkleen now sheetkey
|
||||
sheetkey <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing
|
||||
sheetkey <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True)
|
||||
insert_ $ SheetEdit gkleen now sheetkey
|
||||
-- EIP
|
||||
eip <- insert Course
|
||||
@ -284,6 +284,7 @@ fillDb = do
|
||||
, sheetVisibleFrom = Just now
|
||||
, sheetActiveFrom = now
|
||||
, sheetActiveTo = (14 * nominalDay) `addUTCTime` now
|
||||
, sheetUploadMode = Upload True
|
||||
, sheetHintFrom = Nothing
|
||||
, sheetSolutionFrom = Nothing
|
||||
}
|
||||
|
||||
@ -41,10 +41,10 @@ CourseRegisterOk: Sie wurden angemeldet
|
||||
CourseDeregisterOk: Sie wurden abgemeldet
|
||||
CourseSecretWrong: Falsches Kennwort
|
||||
CourseSecret: Zugangspasswort
|
||||
CourseNewOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde erfolgreich erstellt.
|
||||
CourseEditOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde erfolgreich geändert.
|
||||
CourseNewDupShort tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
|
||||
CourseEditDupShort tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
|
||||
CourseNewOk tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} wurde erfolgreich erstellt.
|
||||
CourseEditOk tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} wurde erfolgreich geändert.
|
||||
CourseNewDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{csh} in diesem Semester.
|
||||
CourseEditDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{csh} in diesem Semester.
|
||||
FFSheetName: Name
|
||||
TermCourseListHeading tid@TermId: Kursübersicht #{display tid}
|
||||
TermSchoolCourseListHeading tid@TermId school@SchoolName: Kursübersicht #{display tid} für #{display school}
|
||||
@ -52,7 +52,7 @@ CourseListTitle: Alle Kurse
|
||||
TermCourseListTitle tid@TermId: Kurse #{display tid}
|
||||
TermSchoolCourseListTitle tid@TermId school@SchoolName: Kurse #{display tid} für #{display school}
|
||||
CourseNewHeading: Neuen Kurs anlegen
|
||||
CourseEditHeading tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} editieren
|
||||
CourseEditHeading tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} editieren
|
||||
CourseEditTitle: Kurs editieren/anlegen
|
||||
CourseMembers: Teilnehmer
|
||||
CourseMembersCount num@Int64: #{display num}
|
||||
@ -71,20 +71,25 @@ CourseRegisterFromTip: Ohne Datum ist keine Anmeldung möglich
|
||||
CourseRegisterToTip: Anmeldung darf auch ohne Begrenzung möglich sein
|
||||
CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein
|
||||
|
||||
NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht.
|
||||
NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht.
|
||||
NoSuchCourseShorthand csh@CourseShorthand: Kein Kurs mit Kürzel #{display csh} bekannt.
|
||||
NoSuchCourse: Keinen passenden Kurs gefunden.
|
||||
|
||||
Sheet: Blatt
|
||||
SheetList tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: #{display tid}-#{display ssh}-#{courseShortHand} Übersicht Übungsblätter
|
||||
SheetNewHeading tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: #{display tid}-#{display ssh}-#{courseShortHand} Neues Übungsblatt anlegen
|
||||
SheetNewOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{sheetName} wurde als neues Übungsblatt im Kurs #{display tid}-#{display ssh}-#{courseShortHand} erfolgreich erstellt.
|
||||
SheetTitle tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}
|
||||
SheetTitleNew tid@TermId ssh@SchoolId courseShortHand@CourseShorthand : #{display tid}-#{display ssh}-#{courseShortHand}: Neues Übungsblatt
|
||||
SheetEditHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName} editieren
|
||||
SheetEditOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde gespeichert.
|
||||
SheetNameDup tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{courseShortHand}.
|
||||
SheetDelHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} herauslöschen?
|
||||
SheetList tid@TermId ssh@SchoolId csh@CourseShorthand: #{display tid}-#{display ssh}-#{csh} Übersicht Übungsblätter
|
||||
SheetNewHeading tid@TermId ssh@SchoolId csh@CourseShorthand: #{display tid}-#{display ssh}-#{csh} Neues Übungsblatt anlegen
|
||||
SheetNewOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wurde als neues Übungsblatt im Kurs #{display tid}-#{display ssh}-#{csh} erfolgreich erstellt.
|
||||
SheetTitle tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName}
|
||||
SheetTitleNew tid@TermId ssh@SchoolId csh@CourseShorthand : #{display tid}-#{display ssh}-#{csh}: Neues Übungsblatt
|
||||
SheetEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName} editieren
|
||||
SheetEditOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{csh} wurde gespeichert.
|
||||
SheetNameDup tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{csh}.
|
||||
SheetDelHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{csh} herauslöschen?
|
||||
SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{display submissionNo} Abgaben.
|
||||
SheetDelOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand}: #{sheetName} gelöscht.
|
||||
SheetDelOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh}: #{sheetName} gelöscht.
|
||||
|
||||
SheetUploadMode: Abgabe von Dateien
|
||||
SheetExercise: Aufgabenstellung
|
||||
SheetHint: Hinweis
|
||||
SheetHintFrom: Hinweis ab
|
||||
@ -116,12 +121,12 @@ Deadline: Abgabe
|
||||
Done: Eingereicht
|
||||
|
||||
Submission: Abgabenummer
|
||||
SubmissionsCourse tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Alle Abgaben Kurs #{display tid}-#{display ssh}-#{courseShortHand}
|
||||
SubmissionsCourse tid@TermId ssh@SchoolId csh@CourseShorthand: Alle Abgaben Kurs #{display tid}-#{display ssh}-#{csh}
|
||||
SubmissionsSheet sheetName@SheetName: Abgaben für #{sheetName}
|
||||
SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
|
||||
SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.
|
||||
SubmissionEditHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen
|
||||
CorrectionHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}: Korrektur
|
||||
SubmissionEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName}: Abgabe editieren/anlegen
|
||||
CorrectionHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{display tid}-#{display ssh}-#{csh} #{sheetName}: Korrektur
|
||||
SubmissionMember g@Int: Mitabgebende(r) ##{display g}
|
||||
SubmissionArchive: Zip-Archiv der Abgabedatei(en)
|
||||
SubmissionFile: Datei zur Abgabe
|
||||
@ -163,7 +168,7 @@ TooManyParticipants: Es wurden zu viele Mitabgebende angegeben
|
||||
|
||||
AddCorrector: Zusätzlicher Korrektor
|
||||
CorrectorExists email@UserEmail: #{email} ist bereits als Korrektor eingetragen
|
||||
SheetCorrectorsTitle tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}
|
||||
SheetCorrectorsTitle tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{display ssh}-#{csh} #{sheetName}
|
||||
CountTutProp: Tutorien zählen gegen Proportion
|
||||
Corrector: Korrektor
|
||||
Correctors: Korrektoren
|
||||
@ -184,7 +189,7 @@ Users: Benutzer
|
||||
HomeHeading: Aktuelle Termine
|
||||
LoginHeading: Authentifizierung
|
||||
LoginTitle: Authentifizierung
|
||||
ProfileHeading: Benutzerprofil und Einstellungen
|
||||
ProfileHeading: Benutzereinstellungen
|
||||
ProfileDataHeading: Gespeicherte Benutzerdaten
|
||||
ImpressumHeading: Impressum
|
||||
|
||||
@ -285,3 +290,16 @@ DummyLoginTitle: Development-Login
|
||||
CorrectorNormal: Normal
|
||||
CorrectorMissing: Abwesend
|
||||
CorrectorExcused: Entschuldigt
|
||||
|
||||
DayIsAHoliday tid@TermId date@Text: #{date} ist ein Feiertag
|
||||
DayIsOutOfLecture tid@TermId date@Text: #{date} ist außerhalb der Vorlesungszeit des #{display tid}
|
||||
DayIsOutOfTerm tid@TermId date@Text: #{date} liegt nicht im #{display tid}
|
||||
|
||||
UploadModeNone: Kein Upload
|
||||
UploadModeUnpack: Upload, einzelne Datei
|
||||
UploadModeNoUnpack: Upload, ZIP-Archive entpacken
|
||||
|
||||
SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen.
|
||||
|
||||
FieldPrimary: Hauptfach
|
||||
FieldSecondary: Nebenfach
|
||||
|
||||
13
models
13
models
@ -54,14 +54,14 @@ School json
|
||||
shorthand (CI Text)
|
||||
UniqueSchool name
|
||||
UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text
|
||||
Primary shorthand -- newtype Key School = School { unSchoolKey :: SchoolShorthand }
|
||||
Primary shorthand -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand }
|
||||
deriving Eq
|
||||
DegreeCourse json
|
||||
course CourseId
|
||||
degree StudyDegreeId
|
||||
terms StudyTermsId
|
||||
UniqueDegreeCourse course degree terms
|
||||
Course
|
||||
Course
|
||||
name (CI Text)
|
||||
description Html Maybe
|
||||
linkExternal Text Maybe
|
||||
@ -108,6 +108,7 @@ Sheet
|
||||
activeTo UTCTime
|
||||
hintFrom UTCTime Maybe
|
||||
solutionFrom UTCTime Maybe
|
||||
uploadMode UploadMode
|
||||
CourseSheet course name
|
||||
SheetEdit
|
||||
user UserId
|
||||
@ -132,10 +133,10 @@ File
|
||||
deriving Show Eq
|
||||
Submission
|
||||
sheet SheetId
|
||||
ratingPoints Points Maybe
|
||||
ratingComment Text Maybe
|
||||
ratingBy UserId Maybe
|
||||
ratingTime UTCTime Maybe
|
||||
ratingPoints Points Maybe -- "Just" does not mean done
|
||||
ratingComment Text Maybe -- "Just" does not mean done
|
||||
ratingBy UserId Maybe -- assigned corrector
|
||||
ratingTime UTCTime Maybe -- "Just" here indicates done!
|
||||
deriving Show
|
||||
SubmissionEdit
|
||||
user UserId
|
||||
|
||||
@ -178,6 +178,12 @@ instance RenderMessage UniWorX TermIdentifier where
|
||||
Winter -> renderMessage' $ MsgWinterTerm year
|
||||
where renderMessage' = renderMessage foundation ls
|
||||
|
||||
instance RenderMessage UniWorX StudyFieldType where
|
||||
renderMessage foundation ls = \case
|
||||
FieldPrimary -> renderMessage' MsgFieldPrimary
|
||||
FieldSecondary -> renderMessage' MsgFieldSecondary
|
||||
where renderMessage' = renderMessage foundation ls
|
||||
|
||||
newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier
|
||||
deriving (Eq, Ord, Read, Show)
|
||||
|
||||
@ -677,7 +683,7 @@ instance YesodBreadcrumbs UniWorX where
|
||||
breadcrumb TermCurrentR = return ("Aktuell" , Just TermShowR)
|
||||
breadcrumb TermEditR = return ("Neu" , Just TermCurrentR)
|
||||
breadcrumb (TermEditExistR tid) = return ("Editieren" , Just $ TermCourseListR tid)
|
||||
breadcrumb (TermCourseListR (unTermKey -> tid)) = getMessageRender <&> \mr -> (mr $ ShortTermIdentifier tid, Just TermShowR)
|
||||
breadcrumb (TermCourseListR (unTermKey -> tid)) = getMessageRender <&> \mr -> (mr $ ShortTermIdentifier tid, Nothing)
|
||||
|
||||
breadcrumb (TermSchoolCourseListR tid ssh) = return (CI.original $ unSchoolKey ssh, Just $ TermCourseListR tid)
|
||||
|
||||
@ -737,7 +743,7 @@ defaultLinks = -- Define the menu items of the header.
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, NavbarRight $ MenuItem
|
||||
{ menuItemLabel = "Profile"
|
||||
{ menuItemLabel = "Profil"
|
||||
, menuItemIcon = Just "cogs"
|
||||
, menuItemRoute = ProfileR
|
||||
, menuItemAccessCallback' = isJust <$> maybeAuthPair
|
||||
|
||||
@ -20,6 +20,7 @@ import Import
|
||||
import Control.Lens
|
||||
import Utils.Lens
|
||||
import Utils.TH
|
||||
-- import Utils.DB
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Table.Cells
|
||||
|
||||
@ -28,6 +29,7 @@ import qualified Data.Text as T
|
||||
import Data.Function ((&))
|
||||
-- import Yesod.Form.Bootstrap3
|
||||
|
||||
import Data.Maybe
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
@ -313,21 +315,78 @@ postCRegisterR tid ssh csh = do
|
||||
|
||||
getCourseNewR :: Handler Html
|
||||
getCourseNewR = do
|
||||
-- TODO: Defaults für Semester hier ermitteln und übergeben
|
||||
courseEditHandler True Nothing
|
||||
uid <- requireAuthId
|
||||
params <- runInputGetResult $ (,,)
|
||||
<$> ireq ciTextField "csh"
|
||||
<*> iopt textField "tid"
|
||||
<*> iopt ciTextField "ssh"
|
||||
let noTemplateAction = courseEditHandler True Nothing
|
||||
case params of
|
||||
FormMissing -> noTemplateAction
|
||||
FormFailure msgs -> forM_ msgs ((addMessage "error") . toHtml)
|
||||
>> noTemplateAction
|
||||
FormSuccess (csh,mbTid,mbSsh) -> do
|
||||
tid <- ifMaybeM mbTid Nothing $ \tid ->
|
||||
case termFromText tid of
|
||||
Left err -> addMessage "error" (toHtml err) >> return Nothing
|
||||
Right t -> return $ Just $ TermKey t
|
||||
getCourseNewTemplateR tid (SchoolKey <$> mbSsh) csh
|
||||
|
||||
getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> CourseShorthand -> Handler Html
|
||||
getCourseNewTemplateR mbTid mbSsh csh = do
|
||||
uid <- requireAuthId
|
||||
oldCourses <- runDB $ do
|
||||
E.select $ E.from $ \course -> do
|
||||
E.where_ $ course E.^. CourseShorthand E.==. E.val csh
|
||||
whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool E.==. E.val ssh
|
||||
whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
||||
let lecturersSchool =
|
||||
E.exists $ E.from $ \lecturer -> do
|
||||
E.where_ $ lecturer E.^. UserLecturerUser E.==. E.val uid
|
||||
E.&&. lecturer E.^. UserLecturerSchool E.==. course E.^. CourseSchool
|
||||
let courseCreated c =
|
||||
E.sub_select . E.from $ \edit -> do -- oldest edit must be creation
|
||||
E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId
|
||||
return $ E.min_ $ edit E.^. CourseEditTime
|
||||
E.orderBy [ E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer from schools of lecturer
|
||||
, E.desc $ courseCreated course] -- most recent created course
|
||||
E.limit 1
|
||||
return course
|
||||
template <- case listToMaybe oldCourses of
|
||||
(Just oldTemplate) ->
|
||||
let newTemplate = (courseToForm oldTemplate) in
|
||||
return $ Just $ newTemplate
|
||||
{ cfCourseId = Nothing
|
||||
, cfTerm = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
|
||||
, cfRegFrom = Nothing
|
||||
, cfRegTo = Nothing
|
||||
, cfDeRegUntil = Nothing
|
||||
}
|
||||
Nothing -> do
|
||||
(tidOk,sshOk,cshOk) <- runDB $ (,,)
|
||||
<$> ifMaybeM mbTid True existsKey
|
||||
<*> ifMaybeM mbSsh True existsKey
|
||||
<*> ((not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
|
||||
unless tidOk $ addMessageI "warning" $ MsgNoSuchTerm $ fromJust mbTid -- safe, since tidOk==True otherwise
|
||||
unless sshOk $ addMessageI "warning" $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise
|
||||
unless cshOk $ addMessageI "warning" $ MsgNoSuchCourseShorthand csh
|
||||
when (tidOk && sshOk && cshOk) $ addMessageI "warning" MsgNoSuchCourse
|
||||
return Nothing
|
||||
courseEditHandler True template
|
||||
|
||||
postCourseNewR :: Handler Html
|
||||
postCourseNewR = courseEditHandler False Nothing
|
||||
postCourseNewR = courseEditHandler False Nothing -- Note: Nothing is safe here, since we will create a new course.
|
||||
|
||||
getCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCEditR tid ssh csh = do
|
||||
course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh
|
||||
courseEditHandler True course
|
||||
getCEditR, postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCEditR = pgCEditR True
|
||||
postCEditR = pgCEditR False
|
||||
|
||||
postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
postCEditR tid ssh csh = do
|
||||
pgCEditR :: Bool -> TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
pgCEditR isGetReq tid ssh csh = do
|
||||
course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh
|
||||
courseEditHandler False course
|
||||
-- IMPORTANT: both GET and POST Handler must use the same template,
|
||||
-- since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons.
|
||||
courseEditHandler isGetReq $ courseToForm <$> course
|
||||
|
||||
|
||||
courseDeleteHandler :: Handler Html -- not called anywhere yet
|
||||
@ -341,11 +400,14 @@ courseDeleteHandler = undefined
|
||||
redirect $ TermCourseListR $ cfTerm res
|
||||
-}
|
||||
|
||||
courseEditHandler :: Bool -> Maybe (Entity Course) -> Handler Html
|
||||
courseEditHandler isGet course = do
|
||||
-- $logDebug "€€€€€€ courseEditHandler started"
|
||||
|
||||
-- | Course Creation and Editing
|
||||
-- | IMPORTANT: in case of Edit, Post/Get Request is provided with the same CourseForm template (cannot be Nothing),
|
||||
-- | since an edit is identified via cfCourseId which is not contained in the received form data for security reasons!
|
||||
courseEditHandler :: Bool -> Maybe CourseForm -> Handler Html
|
||||
courseEditHandler isGet mbCourseForm = do
|
||||
aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
|
||||
((result, formWidget), formEnctype) <- runFormPost . newCourseForm =<< for course courseToForm
|
||||
((result, formWidget), formEnctype) <- runFormPost $ newCourseForm mbCourseForm
|
||||
case result of
|
||||
(FormSuccess res@(
|
||||
CourseForm { cfCourseId = Nothing
|
||||
@ -396,7 +458,7 @@ courseEditHandler isGet course = do
|
||||
, courseDescription = cfDesc res
|
||||
, courseLinkExternal = cfLink res
|
||||
, courseShorthand = cfShort res
|
||||
, courseTerm = cfTerm res
|
||||
, courseTerm = cfTerm res -- dangerous
|
||||
, courseSchool = cfSchool res
|
||||
, courseCapacity = cfCapacity res
|
||||
, courseRegisterSecret = cfSecret res
|
||||
@ -438,9 +500,8 @@ data CourseForm = CourseForm
|
||||
, cfDeRegUntil :: Maybe UTCTime
|
||||
}
|
||||
|
||||
courseToForm :: MonadCrypto m => Entity Course -> m CourseForm
|
||||
courseToForm (Entity cid Course{..}) = do
|
||||
return $ CourseForm
|
||||
courseToForm :: Entity Course -> CourseForm
|
||||
courseToForm (Entity cid Course{..}) = CourseForm
|
||||
{ cfCourseId = Just cid
|
||||
, cfName = courseName
|
||||
, cfDesc = courseDescription
|
||||
@ -462,8 +523,11 @@ newCourseForm template = identForm FIDcourse $ \html -> do
|
||||
userId <- liftHandlerT requireAuthId
|
||||
(fmap concat . sequence)
|
||||
[ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] []
|
||||
, map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. userId] []
|
||||
, map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. userId] []
|
||||
]
|
||||
let termsField = case template of
|
||||
(Just cform) | (Just _) <- cfCourseId cform -> termsSetField [cfTerm cform]
|
||||
_allOtherCases -> termsActiveField
|
||||
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
|
||||
<$> pure (cfCourseId =<< template)
|
||||
<*> areq (ciField textField) (fslI MsgCourseName) (cfName <$> template)
|
||||
@ -474,7 +538,7 @@ newCourseForm template = identForm FIDcourse $ \html -> do
|
||||
-- & addAttr "disabled" "disabled"
|
||||
& setTooltip MsgCourseShorthandUnique)
|
||||
(cfShort <$> template)
|
||||
<*> areq termActiveField (fslI MsgCourseSemester) (cfTerm <$> template)
|
||||
<*> areq termsField (fslI MsgCourseSemester) (cfTerm <$> template)
|
||||
<*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template)
|
||||
<*> aopt (natField "Kapazität") (fslI MsgCourseCapacity
|
||||
& setTooltip MsgCourseCapacityTip) (cfCapacity <$> template)
|
||||
|
||||
@ -94,7 +94,7 @@ getProfileR = do
|
||||
_ -> return ()
|
||||
|
||||
|
||||
(admin_rights,lecturer_rights,lecture_owner,lecture_corrector,participant,studies) <- runDB $ (,,,,,) <$>
|
||||
(admin_rights,lecturer_rights,lecture_corrector,studies) <- runDB $ (,,,) <$>
|
||||
(E.select $ E.from $ \(adright `E.InnerJoin` school) -> do
|
||||
E.where_ $ adright E.^. UserAdminUser E.==. E.val uid
|
||||
E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId
|
||||
@ -107,12 +107,6 @@ getProfileR = do
|
||||
return (school E.^. SchoolShorthand)
|
||||
)
|
||||
<*>
|
||||
(E.select $ E.from $ \(lecturer `E.InnerJoin` course) -> do
|
||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
|
||||
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
||||
return (course E.^. CourseTerm, course E.^.CourseSchool, course E.^. CourseShorthand)
|
||||
)
|
||||
<*>
|
||||
(E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
|
||||
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
||||
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
|
||||
@ -120,20 +114,18 @@ getProfileR = do
|
||||
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
|
||||
)
|
||||
<*>
|
||||
(E.select $ E.from $ \(participant `E.InnerJoin` course) -> do
|
||||
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
|
||||
E.on $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
||||
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand, participant E.^. CourseParticipantRegistration)
|
||||
)
|
||||
<*>
|
||||
(E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
|
||||
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
|
||||
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
|
||||
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
|
||||
return (studydegree E.^. StudyDegreeName
|
||||
,studyterms E.^. StudyTermsName
|
||||
,studyfeat E.^. StudyFeaturesType
|
||||
,studyfeat E.^. StudyFeaturesSemester)
|
||||
return ( ( studydegree E.^. StudyDegreeName
|
||||
, studydegree E.^. StudyDegreeKey
|
||||
)
|
||||
, ( studyterms E.^. StudyTermsName
|
||||
, studyterms E.^. StudyTermsKey
|
||||
)
|
||||
, studyfeat E.^. StudyFeaturesType
|
||||
, studyfeat E.^. StudyFeaturesSemester)
|
||||
)
|
||||
let formText = Just MsgSettings
|
||||
actionUrl = ProfileR
|
||||
@ -160,15 +152,17 @@ getProfileDataR = do
|
||||
-- Tabelle mit allen Teilnehmer: Kurs (link), Datum
|
||||
enrolledCoursesTable <- mkEnrolledCoursesTable uid
|
||||
-- Tabelle mit allen Klausuren und Noten
|
||||
examTable <- return [whamlet| TOOD: Klausuranmeldungen anzeigen |] -- TODO
|
||||
examTable <- return [whamlet| Klausuren werden momentan leider noch nicht unterstützt.|]
|
||||
-- Tabelle mit allen Abgaben und Abgabe-Gruppen
|
||||
submissionTable <- mkSubmissionTable uid
|
||||
-- Tabelle mit allen Abgabegruppen
|
||||
submissionGroupTable <- mkSubmissionGroupTable uid
|
||||
-- Tabelle mit allen Korrektor-Aufgaben
|
||||
correctionsTable <- mkCorrectionsTable uid
|
||||
-- Tabelle mit allen eigenen Tutorials
|
||||
ownTutorialTable <- return [whamlet| Übungsgruppen werden momentan leider noch nicht unterstützt.|]
|
||||
-- Tabelle mit allen Tutorials
|
||||
tutorialTable <- return [whamlet| TOOD: Tutorials anzeigen |] -- TODO
|
||||
tutorialTable <- return [whamlet| Übungsgruppen werden momentan leider noch nicht unterstützt.|]
|
||||
defaultLayout $ do
|
||||
$(widgetFile "profileData")
|
||||
$(widgetFile "dsgvDisclaimer")
|
||||
@ -417,7 +411,7 @@ mkSubmissionGroupTable =
|
||||
|
||||
|
||||
mkCorrectionsTable :: UserId -> Handler Widget
|
||||
-- Table listing all corrections made by the given user
|
||||
-- Table listing sum of corrections made by the given user per sheet
|
||||
mkCorrectionsTable =
|
||||
let dbtIdent = "corrections" :: Text
|
||||
dbtStyle = def
|
||||
@ -426,6 +420,17 @@ mkCorrectionsTable =
|
||||
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a)
|
||||
withType = id
|
||||
|
||||
corrsAssigned uid sheet = E.sub_select . E.from $ \submission -> do
|
||||
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
||||
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
|
||||
return $ E.countRows
|
||||
|
||||
corrsCorrected uid sheet = E.sub_select . E.from $ \submission -> do
|
||||
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
||||
E.&&. submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
|
||||
E.&&. (E.not_ $ E.isNothing $ submission E.^. SubmissionRatingTime)
|
||||
return $ E.countRows
|
||||
|
||||
dbtSQLQuery' uid = \(course `E.InnerJoin` sheet `E.InnerJoin` corrector) -> do
|
||||
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
|
||||
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
||||
@ -434,7 +439,7 @@ mkCorrectionsTable =
|
||||
, course E.^. CourseSchool
|
||||
, course E.^. CourseShorthand
|
||||
)
|
||||
return (crse, sheet E.^. SheetName, corrector)
|
||||
return (crse, sheet E.^. SheetName, corrector, (corrsAssigned uid sheet, corrsCorrected uid sheet))
|
||||
|
||||
dbtProj = \x -> return $ x
|
||||
& _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
|
||||
@ -454,6 +459,10 @@ mkCorrectionsTable =
|
||||
correctorStateCell <$> view (_dbrOutput . _3 . _entityVal)
|
||||
, sortable (toNothing "cload") (i18nCell MsgCorProportion) $
|
||||
correctorLoadCell <$> view (_dbrOutput . _3 . _entityVal)
|
||||
, sortable (toNothing "assigned") (i18nCell MsgCorProportion) $
|
||||
int64Cell <$> view (_dbrOutput . _4 . _1 . _unValue)
|
||||
, sortable (toNothing "corrected") (i18nCell MsgCorProportion) $
|
||||
int64Cell <$> view (_dbrOutput . _4 . _2 . _unValue)
|
||||
]
|
||||
|
||||
validator = def & defaultSorting [("term",SortDesc),("school",SortAsc),("course",SortAsc),("sheet",SortAsc)]
|
||||
@ -472,4 +481,3 @@ mkCorrectionsTable =
|
||||
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
|
||||
in dbTableWidget' validator $ DBTable {..}
|
||||
|
||||
|
||||
|
||||
@ -22,6 +22,7 @@ import System.FilePath (takeFileName)
|
||||
|
||||
import Handler.Utils
|
||||
-- import Handler.Utils.Zip
|
||||
import Handler.Utils.Table.Cells
|
||||
|
||||
-- import Data.Time
|
||||
-- import qualified Data.Text as T
|
||||
@ -81,6 +82,7 @@ data SheetForm = SheetForm
|
||||
, sfVisibleFrom :: Maybe UTCTime
|
||||
, sfActiveFrom :: UTCTime
|
||||
, sfActiveTo :: UTCTime
|
||||
, sfUploadMode :: UploadMode
|
||||
, sfSheetF :: Maybe (Source Handler (Either FileId File))
|
||||
, sfHintFrom :: Maybe UTCTime
|
||||
, sfHintF :: Maybe (Source Handler (Either FileId File))
|
||||
@ -106,11 +108,11 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
|
||||
mr <- getMsgRenderer
|
||||
ctime <- liftIO $ getCurrentTime
|
||||
(result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
|
||||
<$> areq (ciField textField) (fslI MsgSheetName) (sfName <$> template)
|
||||
<$> areq (ciField textField) (fslI MsgSheetName) (sfName <$> template)
|
||||
<*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template)
|
||||
<*> sheetTypeAFormReq (fslI MsgSheetType) (sfType <$> template)
|
||||
<*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template)
|
||||
<*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
|
||||
<*> sheetTypeAFormReq (fslI MsgSheetType) (sfType <$> template)
|
||||
<*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template)
|
||||
<*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
|
||||
<*> aopt utcTimeField (fslI MsgSheetVisibleFrom
|
||||
& setTooltip MsgSheetVisibleFromTip)
|
||||
((sfVisibleFrom <$> template) <|> pure (Just ctime))
|
||||
@ -118,10 +120,10 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
|
||||
& setTooltip MsgSheetActiveFromTip)
|
||||
(sfActiveFrom <$> template)
|
||||
<*> areq utcTimeField (fslI MsgSheetActiveTo) (sfActiveTo <$> template)
|
||||
<*> areq uploadModeField (fslI MsgSheetUploadMode) ((sfUploadMode <$> template) <|> pure (Upload True))
|
||||
<*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren"
|
||||
& setTooltip MsgSheetHintFromTip)
|
||||
(sfHintFrom <$> template)
|
||||
& setTooltip MsgSheetHintFromTip) (sfHintFrom <$> template)
|
||||
<*> aopt (multiFileField $ oldFileIds SheetHint) (fslI MsgSheetHint) (sfHintF <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgSheetSolutionFrom "Datum, sonst nur für Korrektoren"
|
||||
& setTooltip MsgSheetSolutionFromTip)
|
||||
@ -151,27 +153,25 @@ getSheetListR tid ssh csh = do
|
||||
muid <- maybeAuthId
|
||||
Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
let
|
||||
lastSheetEdit sheet = E.sub_select . E.from $ \sheetEdit -> do
|
||||
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
||||
return . E.max_ $ sheetEdit E.^. SheetEditTime
|
||||
sheetData :: E.SqlExpr (Entity Sheet) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity Submission)) `E.InnerJoin` (E.SqlExpr (Maybe (Entity SubmissionUser)))) -> E.SqlQuery (E.SqlExpr (Entity Sheet), E.SqlExpr (E.Value (Maybe UTCTime)),E.SqlExpr (Maybe (Entity Submission)))
|
||||
sheetData (sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) = do
|
||||
E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission
|
||||
E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet
|
||||
E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid
|
||||
let sheetEdit = E.sub_select . E.from $ \sheetEdit' -> do
|
||||
E.where_ $ sheetEdit' E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
||||
return . E.max_ $ sheetEdit' E.^. SheetEditTime
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||
return (sheet, sheetEdit, submission)
|
||||
return (sheet, lastSheetEdit sheet, submission)
|
||||
sheetCol = widgetColonnade . mconcat $
|
||||
[ sortable (Just "name") (i18nCell MsgSheet)
|
||||
$ \(Entity _ Sheet{..}, _, _) -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
|
||||
, sortable (Just "last-edit") (i18nCell MsgLastEdit)
|
||||
$ \(_, E.Value mEditTime, _) -> case mEditTime of
|
||||
Just editTime -> cell $ formatTime SelFormatDateTime (editTime :: UTCTime) >>= toWidget
|
||||
Nothing -> mempty
|
||||
$ \(_, E.Value mEditTime, _) -> maybe mempty timeCell mEditTime
|
||||
, sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
|
||||
$ \(Entity _ Sheet{..}, _, _) -> cell $ formatTime SelFormatDateTime sheetActiveFrom >>= toWidget
|
||||
$ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveFrom
|
||||
, sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
|
||||
$ \(Entity _ Sheet{..}, _, _) -> cell $ formatTime SelFormatDateTime sheetActiveTo >>= toWidget
|
||||
$ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveTo
|
||||
, sortable Nothing (i18nCell MsgSheetType)
|
||||
$ \(Entity _ Sheet{..}, _, _) -> textCell $ display sheetType
|
||||
, sortable Nothing (i18nCell MsgSubmission)
|
||||
@ -204,7 +204,7 @@ getSheetListR tid ssh csh = do
|
||||
in textCell $ textPercent $ realToFrac percent
|
||||
_other -> mempty
|
||||
_other -> mempty
|
||||
]
|
||||
]
|
||||
psValidator = def
|
||||
& defaultSorting [("submission-since", SortAsc)]
|
||||
(SheetTypeSummary{..}, table) <- dbTable psValidator $ DBTable
|
||||
@ -217,8 +217,7 @@ getSheetListR tid ssh csh = do
|
||||
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
|
||||
)
|
||||
, ( "last-edit"
|
||||
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> E.sub_select . E.from $ \sheetEdit -> E.distinctOnOrderBy [E.desc $ sheetEdit E.?. SheetEditTime] $ do
|
||||
return $ sheetEdit E.?. SheetEditTime
|
||||
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> lastSheetEdit sheet
|
||||
)
|
||||
, ( "submission-since"
|
||||
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveFrom
|
||||
@ -367,6 +366,7 @@ getSheetNewR tid ssh csh = do
|
||||
, sfVisibleFrom = addOneWeek <$> sheetVisibleFrom
|
||||
, sfActiveFrom = addOneWeek sheetActiveFrom
|
||||
, sfActiveTo = addOneWeek sheetActiveTo
|
||||
, sfUploadMode = sheetUploadMode
|
||||
, sfSheetF = Nothing
|
||||
, sfHintFrom = addOneWeek <$> sheetHintFrom
|
||||
, sfHintF = Nothing
|
||||
@ -400,6 +400,7 @@ getSEditR tid ssh csh shn = do
|
||||
, sfVisibleFrom = sheetVisibleFrom
|
||||
, sfActiveFrom = sheetActiveFrom
|
||||
, sfActiveTo = sheetActiveTo
|
||||
, sfUploadMode = sheetUploadMode
|
||||
, sfSheetF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise
|
||||
, sfHintFrom = sheetHintFrom
|
||||
, sfHintF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetHint
|
||||
@ -428,7 +429,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
|
||||
actTime <- liftIO getCurrentTime
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
let newSheet = Sheet
|
||||
{ sheetCourse = cid
|
||||
{ sheetCourse = cid
|
||||
, sheetName = sfName
|
||||
, sheetDescription = sfDescription
|
||||
, sheetType = sfType
|
||||
@ -439,10 +440,11 @@ handleSheetEdit tid ssh csh msId template dbAction = do
|
||||
, sheetActiveTo = sfActiveTo
|
||||
, sheetHintFrom = sfHintFrom
|
||||
, sheetSolutionFrom = sfSolutionFrom
|
||||
, sheetUploadMode = sfUploadMode
|
||||
}
|
||||
mbsid <- dbAction newSheet
|
||||
case mbsid of
|
||||
Nothing -> False <$ addMessageI "danger" (MsgSheetNameDup tid ssh csh sfName)
|
||||
Nothing -> False <$ addMessageI "error" (MsgSheetNameDup tid ssh csh sfName)
|
||||
(Just sid) -> do -- save files in DB:
|
||||
whenIsJust sfSheetF $ insertSheetFile' sid SheetExercise
|
||||
whenIsJust sfHintF $ insertSheetFile' sid SheetHint
|
||||
@ -450,12 +452,16 @@ handleSheetEdit tid ssh csh msId template dbAction = do
|
||||
whenIsJust sfMarkingF $ insertSheetFile' sid SheetMarking
|
||||
insert_ $ SheetEdit aid actTime sid
|
||||
addMessageI "info" $ MsgSheetEditOk tid ssh csh sfName
|
||||
-- Sanity checks generating warnings only, but not errors!
|
||||
warnTermDays tid [sfVisibleFrom, Just sfActiveFrom, Just sfActiveTo, sfHintFrom, sfSolutionFrom]
|
||||
return True
|
||||
when saveOkay $ redirect $ case msId of
|
||||
Just _ -> CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB
|
||||
Nothing -> CSheetR tid ssh csh sfName SCorrR
|
||||
(FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
|
||||
_ -> return ()
|
||||
(FormFailure msgs) -> forM_ msgs $ (addMessage "error") . toHtml
|
||||
_ -> runDB $ warnTermDays tid $ (join . (flip fmap template))
|
||||
<$> [sfVisibleFrom, Just . sfActiveFrom, Just . sfActiveTo, sfHintFrom, sfSolutionFrom]
|
||||
|
||||
let pageTitle = maybe (MsgSheetTitleNew tid ssh csh)
|
||||
(MsgSheetTitle tid ssh csh) mbshn
|
||||
-- let formTitle = pageTitle -- no longer used in template
|
||||
|
||||
@ -27,46 +27,50 @@ import Handler.Utils.Table.Cells
|
||||
|
||||
import Network.Mime
|
||||
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.State.Class
|
||||
import Control.Monad.Trans.State.Strict (StateT)
|
||||
-- import Control.Monad.Trans.Maybe
|
||||
-- import Control.Monad.State.Class
|
||||
-- import Control.Monad.Trans.State.Strict (StateT)
|
||||
|
||||
import Data.Monoid (Any(..))
|
||||
import Data.Maybe (fromJust)
|
||||
import qualified Data.Maybe
|
||||
-- import qualified Data.Maybe
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as Text
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
-- import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Internal.Sql as E (unsafeSqlFunction)
|
||||
|
||||
import qualified Data.Conduit.List as Conduit
|
||||
import Data.Conduit.ResumableSink
|
||||
-- import Data.Conduit.ResumableSink
|
||||
|
||||
import Data.Set (Set)
|
||||
-- import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Bifunctor
|
||||
-- import Data.Bifunctor
|
||||
|
||||
import System.FilePath
|
||||
|
||||
import Colonnade hiding (bool, fromMaybe)
|
||||
import qualified Yesod.Colonnade as Yesod
|
||||
import qualified Text.Blaze.Html5.Attributes as HA
|
||||
-- import Colonnade hiding (bool, fromMaybe)
|
||||
-- import qualified Yesod.Colonnade as Yesod
|
||||
-- import qualified Text.Blaze.Html5.Attributes as HA
|
||||
|
||||
-- DEPRECATED: We always show all edits!
|
||||
-- numberOfSubmissionEditDates :: Int64
|
||||
-- numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production.
|
||||
|
||||
|
||||
makeSubmissionForm :: Maybe SubmissionId -> Bool -> SheetGroup -> [UserEmail] -> Form (Maybe (Source Handler File), [UserEmail])
|
||||
makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $ \html -> do
|
||||
makeSubmissionForm :: Maybe SubmissionId -> UploadMode -> SheetGroup -> [UserEmail] -> Form (Maybe (Source Handler File), [UserEmail])
|
||||
makeSubmissionForm msmid uploadMode grouping buddies = identForm FIDsubmission $ \html -> do
|
||||
let
|
||||
fileUpload = case uploadMode of
|
||||
NoUpload -> pure Nothing
|
||||
(Upload unpackZips) -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
|
||||
flip (renderAForm FormStandard) html $ (,)
|
||||
<$> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
|
||||
<$> fileUpload
|
||||
<*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies (ciField textField) (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy
|
||||
| g <- [1..(max groupNr $ length buddies)] -- groupNr might have decreased meanwhile
|
||||
| buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies
|
||||
@ -113,7 +117,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
|
||||
maySubmit <- (== Authorized) <$> isAuthorized actionUrl True -- affects visibility of Edit-Dates, Submission-Button, etc.
|
||||
|
||||
(Entity shid Sheet{..}, buddies, lastEdits) <- runDB $ do
|
||||
sheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn
|
||||
csheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn
|
||||
case msmid of
|
||||
Nothing -> do
|
||||
submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
|
||||
@ -127,12 +131,12 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
|
||||
-- fetch buddies from previous submission in this course
|
||||
buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
|
||||
E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
|
||||
let oldids = E.subList_select . E.from $ \(sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser `E.InnerJoin` submissionEdit) -> do
|
||||
E.on (submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId)
|
||||
E.on (submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId)
|
||||
let oldids = E.subList_select . E.from $ \(sheet `E.InnerJoin` submission `E.InnerJoin` subUser `E.InnerJoin` submissionEdit) -> do
|
||||
E.on (submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId)
|
||||
E.on (subUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId)
|
||||
E.on (sheet E.^. SheetId E.==. submission E.^. SubmissionSheet)
|
||||
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
|
||||
E.&&. sheet E.^. SheetCourse E.==. E.val sheetCourse
|
||||
E.where_ $ subUser E.^. SubmissionUserUser E.==. E.val uid
|
||||
E.&&. sheet E.^. SheetCourse E.==. E.val sheetCourse
|
||||
E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
|
||||
E.limit 1
|
||||
return $ submission E.^. SubmissionId
|
||||
@ -140,7 +144,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
|
||||
E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid
|
||||
E.orderBy [E.asc $ user E.^. UserEmail]
|
||||
return $ user E.^. UserEmail
|
||||
return (sheet, map E.unValue buddies, [])
|
||||
return (csheet, map E.unValue buddies, [])
|
||||
(E.Value smid:_) -> do
|
||||
cID <- encrypt smid
|
||||
addMessageI "info" $ MsgSubmissionAlreadyExists
|
||||
@ -172,9 +176,8 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
|
||||
else E.nothing
|
||||
return $ (userName, submissionEdit E.^. SubmissionEditTime)
|
||||
forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
|
||||
return (sheet,buddies,lastEdits)
|
||||
let unpackZips = True -- undefined -- TODO
|
||||
((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid unpackZips sheetGrouping buddies
|
||||
return (csheet,buddies,lastEdits)
|
||||
((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping buddies
|
||||
mCID <- runDB $ do
|
||||
res' <- case res of
|
||||
(FormMissing ) -> return $ FormMissing
|
||||
@ -231,7 +234,14 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
|
||||
-> return smid
|
||||
(Just files, _) -- new files
|
||||
-> runConduit $ transPipe lift files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False
|
||||
_ -> error "Impossible, because of definition of `makeSubmissionForm`"
|
||||
(Nothing, Nothing) -- new submission, no file upload requested
|
||||
-> insert Submission
|
||||
{ submissionSheet = shid
|
||||
, submissionRatingPoints = Nothing
|
||||
, submissionRatingComment = Nothing
|
||||
, submissionRatingBy = Nothing
|
||||
, submissionRatingTime = Nothing
|
||||
}
|
||||
-- Determine members of pre-registered group
|
||||
groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do
|
||||
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup
|
||||
|
||||
@ -180,9 +180,9 @@ termEditHandler term = do
|
||||
|
||||
newTermForm :: Maybe Term -> Form Term
|
||||
newTermForm template html = do
|
||||
renderMessage <- getMessageRender
|
||||
mr <- getMessageRender
|
||||
(result, widget) <- flip (renderAForm FormStandard) html $ Term
|
||||
<$> areq termNewField (fslpI MsgTerm (renderMessage MsgTermPlaceholder)) (termName <$> template)
|
||||
<$> areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) (termName <$> template)
|
||||
<*> areq dayField (fsl ("Erster Tag" :: Text)) (termStart <$> template)
|
||||
<*> areq dayField (fsl ("Letzer Tag" :: Text)) (termEnd <$> template)
|
||||
<*> pure [] -- TODO: List of Day field required, must probably be done as its own form and then combined
|
||||
|
||||
@ -12,6 +12,8 @@ module Handler.Utils
|
||||
import Import
|
||||
|
||||
import qualified Data.Text as T
|
||||
-- import qualified Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Handler.Utils.DateTime as Handler.Utils
|
||||
import Handler.Utils.Form as Handler.Utils
|
||||
@ -34,6 +36,11 @@ downloadFiles = do
|
||||
AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings
|
||||
return userDefaultDownloadFiles
|
||||
|
||||
tidFromText :: Text -> Maybe TermId
|
||||
tidFromText = (fmap TermKey) . maybeRight . termFromText
|
||||
|
||||
simpleLink :: Widget -> Route UniWorX -> Widget
|
||||
simpleLink lbl url = [whamlet|<a href=@{url}>^{lbl}|]
|
||||
|
||||
nameWidget :: Text -> Text -> Widget
|
||||
nameWidget displayName surname
|
||||
@ -52,3 +59,17 @@ nameWidget displayName surname
|
||||
|]
|
||||
[] -> error "Data.Text.splitOn returned empty list in violation of specification."
|
||||
|
||||
|
||||
warnTermDays :: TermId -> [Maybe UTCTime] -> DB ()
|
||||
warnTermDays tid times = do
|
||||
Term{..} <- get404 tid
|
||||
let alldays = Set.map utctDay $ Set.fromList $ catMaybes times
|
||||
warnholidays = Set.intersection alldays $ Set.fromList termHolidays
|
||||
outoftermdays = Set.filter (\d -> d < termStart || d > termEnd ) alldays
|
||||
outoflecture = Set.filter (\d -> d < termLectureStart || d > termLectureEnd) alldays
|
||||
`Set.difference` outoftermdays -- out of term implies out of lecture-time
|
||||
warnI msg d = formatTime SelFormatDate d >>= \dt -> addMessageI "warning" $ msg tid dt
|
||||
forM_ warnholidays $ warnI MsgDayIsAHoliday
|
||||
forM_ outoflecture $ warnI MsgDayIsOutOfLecture
|
||||
forM_ outoftermdays $ warnI MsgDayIsOutOfTerm
|
||||
|
||||
|
||||
@ -111,7 +111,7 @@ instance Button UniWorX AdminHijackUserButton where
|
||||
-- instance PathPiece LinkButton where
|
||||
-- LinkButton route = ???
|
||||
|
||||
linkButton :: Widget -> ButtonCssClass UniWorX -> Route UniWorX -> Widget
|
||||
linkButton :: Widget -> ButtonCssClass UniWorX -> Route UniWorX -> Widget -- Alternative: Handler.Utils.simpleLink
|
||||
linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=button>^{lbl} |]
|
||||
-- [whamlet|
|
||||
-- <form method=post action=@{url}>
|
||||
@ -120,10 +120,6 @@ linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=butt
|
||||
-- |]
|
||||
-- <input .btn .#{bcc2txt cls} type="submit" value=^{lbl}>
|
||||
|
||||
simpleLink :: Widget -> Route UniWorX -> Widget
|
||||
simpleLink lbl url = [whamlet| <a href=@{url}>^{lbl} |]
|
||||
|
||||
|
||||
{-
|
||||
combinedButtonField :: Button a => [a] -> Form m -> Form (a,m)
|
||||
combinedButtonField btns inner csrf = do
|
||||
@ -190,6 +186,9 @@ buttonForm csrf = do
|
||||
ciField :: (Functor m, CI.FoldCase a) => Field m a -> Field m (CI a)
|
||||
ciField = convertField CI.mk CI.original
|
||||
|
||||
ciTextField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m (CI Text)
|
||||
ciTextField = ciField textField
|
||||
|
||||
natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
|
||||
natFieldI msg = checkBool (>= 0) msg intField
|
||||
|
||||
@ -219,11 +218,15 @@ pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..}
|
||||
return . fromRational $ round (sci * 100) % 100
|
||||
|
||||
|
||||
termActiveField :: Field Handler TermId
|
||||
termActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
|
||||
termsActiveField :: Field Handler TermId
|
||||
termsActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
|
||||
|
||||
termActiveOld :: Field Handler TermIdentifier
|
||||
termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
|
||||
termsSetField :: [TermId] -> Field Handler TermId
|
||||
-- termsSetField tids = selectField $ optionsPersistKey [TermId <-. tids] [Desc TermStart] termName
|
||||
termsSetField tids = selectFieldList [(unTermKey t, t)| t <- tids ]
|
||||
|
||||
-- termActiveOld :: Field Handler TermIdentifier
|
||||
-- termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
|
||||
|
||||
termNewField :: Field Handler TermIdentifier
|
||||
termNewField = checkMMap checkTerm termToText textField
|
||||
@ -249,6 +252,13 @@ schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName
|
||||
schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
|
||||
schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName
|
||||
|
||||
uploadModeField :: Field Handler UploadMode
|
||||
uploadModeField = selectFieldList
|
||||
[ (MsgUploadModeNone , NoUpload )
|
||||
, (MsgUploadModeNoUnpack, Upload False)
|
||||
, (MsgUploadModeUnpack , Upload True )
|
||||
]
|
||||
|
||||
zipFileField :: Bool -- ^ Unpack zips?
|
||||
-> Field Handler (Source Handler File)
|
||||
zipFileField doUnpack = Field{..}
|
||||
|
||||
@ -35,6 +35,12 @@ userCell displayName surname = cell $ nameWidget displayName surname
|
||||
maybeTimeCell :: IsDBTable m a => Maybe UTCTime -> DBCell m a
|
||||
maybeTimeCell = maybe mempty timeCell
|
||||
|
||||
numCell :: (IsDBTable m a, Num b, DisplayAble b) => b -> DBCell m a
|
||||
numCell = textCell . display
|
||||
|
||||
int64Cell :: (IsDBTable m a) => Int64-> DBCell m a
|
||||
int64Cell = numCell
|
||||
|
||||
termCell :: IsDBTable m a => TermId -> DBCell m a
|
||||
termCell tid = anchorCell link name
|
||||
where
|
||||
|
||||
@ -168,12 +168,18 @@ customMigrations = Map.fromListWith (>>)
|
||||
, whenM (tableExists "user") $ do
|
||||
userDisplayNames <- [sqlQQ| SELECT "id", "display_name" FROM "user"; |]
|
||||
[executeQQ|
|
||||
ALTER TABLE "user" ADD COLUMN "surname" text DEFAULT ' ';
|
||||
ALTER TABLE "user" ADD COLUMN "surname" text DEFAULT '';
|
||||
|]
|
||||
forM_ userDisplayNames $ \(uid, Single str) -> case lastMaybe $ words str of
|
||||
Just name -> update uid [UserSurname =. name]
|
||||
_other -> error $ "Empty userDisplayName found"
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|3.1.0|] [version|3.2.0|]
|
||||
, whenM (tableExists "sheet") $ do
|
||||
[executeQQ|
|
||||
ALTER TABLE "sheet" ADD COLUMN "upload_mode" json DEFAULT '{ "tag": "Upload", "unpackZips": true }';
|
||||
|]
|
||||
)
|
||||
]
|
||||
|
||||
|
||||
|
||||
@ -193,6 +193,12 @@ instance DisplayAble DA where
|
||||
-}
|
||||
|
||||
|
||||
data UploadMode = NoUpload | Upload { unpackZips :: Bool }
|
||||
deriving (Show, Read, Eq, Ord)
|
||||
|
||||
deriveJSON defaultOptions ''UploadMode
|
||||
derivePersistFieldJSON ''UploadMode
|
||||
|
||||
data ExamStatus = Attended | NoShow | Voided
|
||||
deriving (Show, Read, Eq, Ord, Enum, Bounded)
|
||||
derivePersistField "ExamStatus"
|
||||
@ -280,6 +286,7 @@ shortened = iso shorten expand
|
||||
termToText :: TermIdentifier -> Text
|
||||
termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show (year ^. shortened)
|
||||
|
||||
-- also see Hander.Utils.tidFromText
|
||||
termFromText :: Text -> Either Text TermIdentifier
|
||||
termFromText t
|
||||
| (s:ys) <- Text.unpack t
|
||||
@ -329,9 +336,9 @@ instance FromJSON TermIdentifier where
|
||||
parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText
|
||||
|
||||
{- Must be defined in a later module:
|
||||
termField :: Field (HandlerT UniWorX IO) TermIdentifier
|
||||
termField = checkMMap (return . termFromText) termToText textField
|
||||
-- TODO: this is too simple and inconvenient, use selector and year picker
|
||||
termField :: Field (HandlerT UniWorX IO) TermIdentifier
|
||||
termField = checkMMap (return . termFromText) termToText textField
|
||||
See Handler.Utils.Form.termsField and termActiveField
|
||||
-}
|
||||
|
||||
|
||||
|
||||
30
src/Utils.hs
30
src/Utils.hs
@ -130,7 +130,7 @@ withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >>
|
||||
|
||||
|
||||
-- Types that can be converted to Text for direct displayed to User! (Show for debugging, Display for Production)
|
||||
{-# DEPRECATED display "Create RenderMessage Instances instead!" #-}
|
||||
{- (not so sure we really want to get rid of display?!) DEPRECATED display "Create RenderMessage Instances instead!" -}
|
||||
class DisplayAble a where
|
||||
display :: a -> Text
|
||||
-- Default definitions for types belonging to Show (allows empty instance declarations)
|
||||
@ -300,6 +300,13 @@ whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
|
||||
whenIsJust (Just x) f = f x
|
||||
whenIsJust Nothing _ = return ()
|
||||
|
||||
ifMaybeM :: Monad m => Maybe a -> b -> (a -> m b) -> m b -- more convenient argument order as compared to maybeM
|
||||
ifMaybeM Nothing dft _ = return dft
|
||||
ifMaybeM (Just x) _ act = act x
|
||||
|
||||
maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
|
||||
maybeM dft act mb = mb >>= maybe dft act
|
||||
|
||||
maybeT :: Monad m => m a -> MaybeT m a -> m a
|
||||
maybeT x m = runMaybeT m >>= maybe x return
|
||||
|
||||
@ -323,6 +330,27 @@ instance Ord a => Ord (NTop (Maybe a)) where
|
||||
|
||||
|
||||
|
||||
------------
|
||||
-- Either --
|
||||
------------
|
||||
|
||||
maybeLeft :: Either a b -> Maybe a
|
||||
maybeLeft (Left a) = Just a
|
||||
maybeLeft _ = Nothing
|
||||
|
||||
maybeRight :: Either a b -> Maybe b
|
||||
maybeRight (Right b) = Just b
|
||||
maybeRight _ = Nothing
|
||||
|
||||
whenIsLeft :: Monad m => Either a b -> (a -> m ()) -> m ()
|
||||
whenIsLeft (Left x) f = f x
|
||||
whenIsLeft (Right _) _ = return ()
|
||||
|
||||
whenIsRight :: Monad m => Either a b -> (b -> m ()) -> m ()
|
||||
whenIsRight (Right x) f = f x
|
||||
whenIsRight (Left _) _ = return ()
|
||||
|
||||
|
||||
---------------
|
||||
-- Exception --
|
||||
---------------
|
||||
|
||||
@ -37,8 +37,11 @@ getKeyBy404 = (fmap entityKey) . getBy404 -- TODO optimize this, so that DB does
|
||||
|
||||
existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
|
||||
=> Unique record -> ReaderT backend m Bool
|
||||
existsBy = fmap isJust . getBy
|
||||
existsBy = fmap isJust . getBy -- TODO optimize, so that DB does not deliver entire record
|
||||
|
||||
existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistStoreRead backend, MonadIO m)
|
||||
=> Key record -> ReaderT backend m Bool
|
||||
existsKey = fmap isJust . get -- TODO optimize, so that DB does not deliver entire record
|
||||
|
||||
myReplaceUnique -- Identical to Database.Persist.Class, except for the better type signature (original requires Eq record which is not needed anyway)
|
||||
:: (MonadIO m
|
||||
|
||||
@ -3,8 +3,9 @@
|
||||
<dl .deflist.profile-dl>
|
||||
<dt .deflist__dt> _{MsgName}
|
||||
<dd .deflist__dd> ^{nameWidget userDisplayName userSurname}
|
||||
<dt .deflist__dt> _{MsgMatrikelNr}
|
||||
<dd .deflist__dd> #{display userMatrikelnummer}
|
||||
$maybe matnr <- userMatrikelnummer
|
||||
<dt .deflist__dt> _{MsgMatrikelNr}
|
||||
<dd .deflist__dd> #{matnr}
|
||||
<dt .deflist__dt> _{MsgEMail}
|
||||
<dd .deflist__dd> #{display userEmail}
|
||||
<dt .deflist__dt> _{MsgIdent}
|
||||
@ -15,21 +16,18 @@
|
||||
<dt .deflist__dt> Administrator
|
||||
<dd .deflist__dd>
|
||||
<ul .list-ul>
|
||||
$forall institute <- admin_rights
|
||||
<li .list-ul__item>#{display institute}
|
||||
$forall (E.Value institute) <- admin_rights
|
||||
<li .list-ul__item>
|
||||
<a href=@{SchoolShowR $ SchoolKey institute}>
|
||||
#{display institute}
|
||||
$if not $ null lecturer_rights
|
||||
<dt .deflist__dt> Lehrberechtigt
|
||||
<dd .deflist__dd>
|
||||
<ul .list-ul>
|
||||
$forall institute <- lecturer_rights
|
||||
<li .list-ul__item>#{display institute}
|
||||
$if not $ null lecture_owner
|
||||
<dt .deflist__dt> Eigene Kurse
|
||||
<dd .deflist__dd>
|
||||
<ul .list-ul>
|
||||
$forall (E.Value tid, E.Value ssh, E.Value csh) <- lecture_owner
|
||||
$forall (E.Value institute) <- lecturer_rights
|
||||
<li .list-ul__item>
|
||||
<a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
|
||||
<a href=@{SchoolShowR $ SchoolKey institute}>
|
||||
#{display institute}
|
||||
$if not $ null lecture_corrector
|
||||
<dt .deflist__dt> Korrektor
|
||||
<dd .deflist__dd>
|
||||
@ -48,21 +46,19 @@
|
||||
<th .table__th> Studienart
|
||||
<th .table__th> Semester
|
||||
|
||||
$forall (degree,field,fieldtype,semester) <- studies
|
||||
$forall ((degree, degreeKey),(field, fieldKey),fieldtype,semester) <- studies
|
||||
<tr.table__row>
|
||||
<td .table__td> #{display degree}
|
||||
<td .table__td> #{display field}
|
||||
<td .table__td> #{display fieldtype}
|
||||
<td .table__td> #{display semester}
|
||||
|
||||
$if not $ null participant
|
||||
<dt .deflist__dt> Teilnehmer
|
||||
<dd .deflist__dd>
|
||||
<dl .deflist>
|
||||
$forall (E.Value tid, E.Value ssh, E.Value csh, E.Value regSince) <- participant
|
||||
<dt .deflist__dt>
|
||||
<a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
|
||||
<dd .deflist__dd>
|
||||
seit ^{formatTimeW SelFormatDateTime regSince}
|
||||
<td .table__td>
|
||||
$maybe name <- E.unValue degree
|
||||
#{display name}
|
||||
$nothing
|
||||
#{display degreeKey}
|
||||
<td .table__td>
|
||||
$maybe name <- E.unValue field
|
||||
#{display name}
|
||||
$nothing
|
||||
#{display fieldKey}
|
||||
<td .table__td>_{E.unValue fieldtype}
|
||||
<td .table__td>#{display semester}
|
||||
|
||||
^{settingsForm}
|
||||
|
||||
@ -6,8 +6,6 @@
|
||||
und verlinkt werden
|
||||
(alle Abgaben, Klausurnoten, etc.)
|
||||
|
||||
<em> TODO: Hier alle Daten in Tabellen anzeigen!
|
||||
|
||||
$if hasRows
|
||||
<div .container>
|
||||
<h2> Eigene Kurse
|
||||
@ -24,6 +22,11 @@
|
||||
<div .container>
|
||||
^{examTable}
|
||||
|
||||
<div .container>
|
||||
<h2> Eigene Übungsgruppen
|
||||
<div .container>
|
||||
^{ownTutorialTable}
|
||||
|
||||
<div .container>
|
||||
<h2> Übungsgruppen
|
||||
<div .container>
|
||||
@ -47,6 +50,13 @@
|
||||
<div .container>
|
||||
^{correctionsTable}
|
||||
|
||||
<h4> Hinweis:
|
||||
Die oberhalb angezeigte Tabelle zeigt nur prinzipielle Einteilungen als Korrektor zu einem Übungsblatt;
|
||||
auch ohne Einteilung können Korrekturen einzeln zugewiesen werden, welche hier nicht aufgeführt werden.
|
||||
Hier finden Sie eine
|
||||
<a href=@{CorrectionsR}>Auflistung aller tatsächlich zugewiesenen Korrekturen
|
||||
.
|
||||
|
||||
<h2>
|
||||
<em> TODO: Knopf zum Löschen aller Daten erstellen
|
||||
|
||||
|
||||
@ -1,12 +1,17 @@
|
||||
$maybe cID <- mcid
|
||||
<section>
|
||||
<h2>
|
||||
<a href=@{urlArchive cID}>Archiv
|
||||
(<a href=@{urlOriginal cID}>Original</a>)
|
||||
$case sheetUploadMode
|
||||
$of Upload _
|
||||
<h2>
|
||||
<a href=@{urlArchive cID}>Archiv
|
||||
(<a href=@{urlOriginal cID}>Original</a>)
|
||||
|
||||
$maybe fileTable <- mFileTable
|
||||
<h3>_{MsgSubmissionFiles}
|
||||
^{fileTable}
|
||||
$maybe fileTable <- mFileTable
|
||||
<h3>_{MsgSubmissionFiles}
|
||||
^{fileTable}
|
||||
$of _
|
||||
<p>
|
||||
_{MsgSubmissionNoUploadExpected}
|
||||
|
||||
$if not (null lastEdits)
|
||||
<h3>_{MsgLastEdits}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user