Merge branch 'feat/nonCourseShorts' into 'master'
Feat/non course shorts See merge request !70
This commit is contained in:
Steffen Jost
commit
d4de1da4e5
@ -38,16 +38,18 @@ CourseRegisterOk: Sie wurden angemeldet
|
||||
CourseDeregisterOk: Sie wurden abgemeldet
|
||||
CourseSecretWrong: Falsches Kennwort
|
||||
CourseSecret: Zugangspasswort
|
||||
CourseNewOk tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich erstellt.
|
||||
CourseEditOk tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich geändert.
|
||||
CourseNewDupShort tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
|
||||
CourseEditDupShort tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{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 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.
|
||||
FFSheetName: Name
|
||||
TermCourseListHeading tid@TermId: Kursübersicht #{display tid}
|
||||
TermSchoolCourseListHeading tid@TermId school@SchoolName: Kursübersicht #{display tid} für #{display school}
|
||||
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 courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} editieren
|
||||
CourseEditHeading tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} editieren
|
||||
CourseEditTitle: Kurs editieren/anlegen
|
||||
CourseMembers: Teilnehmer
|
||||
CourseMembersCount num@Int64: #{display num}
|
||||
@ -68,17 +70,17 @@ CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein
|
||||
|
||||
|
||||
Sheet: Blatt
|
||||
SheetList tid@TermId courseShortHand@CourseShorthand: #{display tid}-#{courseShortHand} Übersicht Übungsblätter
|
||||
SheetNewHeading tid@TermId courseShortHand@CourseShorthand: #{display tid}-#{courseShortHand} Neues Übungsblatt anlegen
|
||||
SheetNewOk tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Neues Übungsblatt #{sheetName} wurde im Kurs #{display tid}-#{courseShortHand} erfolgreich erstellt.
|
||||
SheetTitle tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName}
|
||||
SheetTitleNew tid@TermId courseShortHand@CourseShorthand : #{display tid}-#{courseShortHand}: Neues Übungsblatt
|
||||
SheetEditHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName} editieren
|
||||
SheetEditOk tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{courseShortHand} wurde gespeichert.
|
||||
SheetNameDup tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{courseShortHand}.
|
||||
SheetDelHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} wirklich aus Kurs #{display tid}-#{courseShortHand} herauslöschen?
|
||||
SheetList tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: #{display tid}-#{display ssh}-#{courseShortHand} Übersicht Übungsblätter
|
||||
SheetNewHeading tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: #{display tid}-#{display ssh}-#{courseShortHand} Neues Übungsblatt anlegen
|
||||
SheetNewOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Neues Übungsblatt #{sheetName} wurde im Kurs #{display tid}-#{display ssh}-#{courseShortHand} erfolgreich erstellt.
|
||||
SheetTitle tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}
|
||||
SheetTitleNew tid@TermId ssh@SchoolId courseShortHand@CourseShorthand : #{display tid}-#{display ssh}-#{courseShortHand}: Neues Übungsblatt
|
||||
SheetEditHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName} editieren
|
||||
SheetEditOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde gespeichert.
|
||||
SheetNameDup tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{courseShortHand}.
|
||||
SheetDelHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} herauslöschen?
|
||||
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 courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht.
|
||||
SheetDelOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht.
|
||||
|
||||
SheetExercise: Aufgabenstellung
|
||||
SheetHint: Hinweis
|
||||
@ -111,12 +113,12 @@ Deadline: Abgabe
|
||||
Done: Eingereicht
|
||||
|
||||
Submission: Abgabenummer
|
||||
SubmissionsCourse tid@TermId courseShortHand@CourseShorthand: Alle Abgaben Kurs #{display tid}-#{courseShortHand}
|
||||
SubmissionsCourse tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Alle Abgaben Kurs #{display tid}-#{display ssh}-#{courseShortHand}
|
||||
SubmissionsSheet sheetName@SheetName: Abgaben für Blatt #{sheetName}
|
||||
SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
|
||||
SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.
|
||||
SubmissionEditHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen
|
||||
CorrectionHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{display tid}-#{courseShortHand} #{sheetName}: Korrektur
|
||||
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
|
||||
SubmissionMember g@Int: Mitabgebende(r) ##{display g}
|
||||
SubmissionArchive: Zip-Archiv der Abgabedatei(en)
|
||||
SubmissionFile: Datei zur Abgabe
|
||||
@ -156,7 +158,7 @@ TooManyParticipants: Es wurden zu viele Mitabgebende angegeben
|
||||
|
||||
AddCorrector: Zusätzlicher Korrektor
|
||||
CorrectorExists email@UserEmail: #{email} ist bereits als Korrektor eingetragen
|
||||
SheetCorrectorsTitle tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{courseShortHand} #{sheetName}
|
||||
SheetCorrectorsTitle tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}
|
||||
CountTutProp: Tutorien zählen gegen Proportion
|
||||
Corrector: Korrektor
|
||||
Correctors: Korrektoren
|
||||
@ -268,4 +270,4 @@ DummyLoginTitle: Development-Login
|
||||
|
||||
CorrectorNormal: Normal
|
||||
CorrectorMissing: Abwesend
|
||||
CorrectorExcused: Entschuldigt
|
||||
CorrectorExcused: Entschuldigt
|
||||
|
||||
7
models
7
models
@ -52,7 +52,8 @@ School json
|
||||
name (CI Text)
|
||||
shorthand (CI Text)
|
||||
UniqueSchool name
|
||||
UniqueSchoolShorthand shorthand
|
||||
UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text
|
||||
Primary shorthand -- newtype Key School = School { unSchoolKey :: SchoolShorthand }
|
||||
deriving Eq
|
||||
DegreeCourse json
|
||||
course CourseId
|
||||
@ -73,8 +74,8 @@ Course
|
||||
deregisterUntil UTCTime Maybe
|
||||
registerSecret Text Maybe -- Falls ein Passwort erforderlich ist
|
||||
materialFree Bool
|
||||
CourseTermShort term shorthand
|
||||
CourseTermName term name
|
||||
TermSchoolCourseShort term school shorthand
|
||||
TermSchoolCourseName term school name
|
||||
CourseEdit
|
||||
user UserId
|
||||
time UTCTime
|
||||
|
||||
4
routes
4
routes
@ -46,11 +46,13 @@
|
||||
/terms/edit TermEditR GET POST
|
||||
/terms/#TermId/edit TermEditExistR GET
|
||||
!/terms/#TermId TermCourseListR GET !free
|
||||
!/terms/#TermId/#SchoolId TermSchoolCourseListR GET !free
|
||||
|
||||
|
||||
-- For Pattern Synonyms see Foundation
|
||||
/course/ CourseListR GET !free
|
||||
!/course/new CourseNewR GET POST !lecturer
|
||||
/course/#TermId/#CourseShorthand CourseR !lecturer:
|
||||
/course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer:
|
||||
/ CShowR GET !free
|
||||
/register CRegisterR POST !timeANDcapacity
|
||||
/edit CEditR GET POST
|
||||
|
||||
@ -27,35 +27,17 @@ import System.FilePath.Cryptographic.ImplicitNamespace
|
||||
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import Data.UUID.Types
|
||||
-- import Data.UUID.Types
|
||||
import Web.PathPieces
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
|
||||
instance PathPiece UUID where
|
||||
fromPathPiece = fromString . unpack
|
||||
toPathPiece = pack . toString
|
||||
|
||||
instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where
|
||||
fromPathPiece = fmap CI.mk . fromPathPiece
|
||||
toPathPiece = toPathPiece . CI.original
|
||||
|
||||
instance {-# OVERLAPS #-} PathMultiPiece FilePath where
|
||||
fromPathMultiPiece = Just . unpack . intercalate "/"
|
||||
toPathMultiPiece = Text.splitOn "/" . pack
|
||||
|
||||
instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where
|
||||
fromPathMultiPiece = fmap CI.mk . fromPathMultiPiece
|
||||
toPathMultiPiece = toPathMultiPiece . CI.foldedCase
|
||||
|
||||
|
||||
-- Generates CryptoUUID... and CryptoFileName... Datatypes
|
||||
decCryptoIDs [ ''SubmissionId
|
||||
, ''FileId
|
||||
, ''UserId
|
||||
, ''SchoolId
|
||||
]
|
||||
|
||||
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where
|
||||
|
||||
@ -97,6 +97,8 @@ instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) Submission
|
||||
instance DisplayAble TermId where
|
||||
display = termToText . unTermKey
|
||||
|
||||
instance DisplayAble SchoolId where
|
||||
display = CI.original . unSchoolKey
|
||||
|
||||
-- infixl 9 :$:
|
||||
-- pattern a :$: b = a b
|
||||
@ -134,11 +136,11 @@ type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
|
||||
type MsgRenderer = MsgRendererS UniWorX -- see Utils
|
||||
|
||||
-- Pattern Synonyms for convenience
|
||||
pattern CSheetR tid csh shn ptn
|
||||
= CourseR tid csh (SheetR shn ptn)
|
||||
pattern CSheetR tid ssh csh shn ptn
|
||||
= CourseR tid ssh csh (SheetR shn ptn)
|
||||
|
||||
pattern CSubmissionR tid csh shn cid ptn
|
||||
= CSheetR tid csh shn (SubmissionR cid ptn)
|
||||
pattern CSubmissionR tid ssh csh shn cid ptn
|
||||
= CSheetR tid ssh csh shn (SubmissionR cid ptn)
|
||||
|
||||
-- Menus and Favourites
|
||||
data MenuItem = MenuItem
|
||||
@ -267,12 +269,13 @@ falseAP = APPure . const . const $ Unauthorized . ($ MsgUnauthorized) . render <
|
||||
adminAP :: AccessPredicate -- access for admins (of appropriate school in case of course-routes)
|
||||
adminAP = APDB $ \route _ -> case route of
|
||||
-- Courses: access only to school admins
|
||||
CourseR tid csh _ -> exceptT return return $ do
|
||||
CourseR tid ssh csh _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do
|
||||
E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool
|
||||
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
return (E.countRows :: E.SqlExpr (E.Value Int64))
|
||||
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedSchoolAdmin)
|
||||
@ -295,12 +298,13 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
|
||||
return $ bool (Unauthorized "Deprecated Route") Authorized allow
|
||||
)
|
||||
,("lecturer", APDB $ \route _ -> case route of
|
||||
CourseR tid csh _ -> exceptT return return $ do
|
||||
CourseR tid ssh csh _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do
|
||||
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
|
||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
return (E.countRows :: E.SqlExpr (E.Value Int64))
|
||||
guardMExceptT (c>0) (unauthorizedI MsgUnauthorizedLecturer)
|
||||
@ -321,18 +325,18 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
|
||||
resMap :: Map CourseId (Set SheetId)
|
||||
resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ]
|
||||
case route of
|
||||
CSubmissionR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
|
||||
CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
|
||||
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
Submission{..} <- MaybeT . lift $ get sid
|
||||
guard $ maybe False (== authId) submissionRatingBy
|
||||
return Authorized
|
||||
CSheetR tid csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
|
||||
Entity cid _ <- MaybeT . lift . getBy $ CourseTermShort tid csh
|
||||
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
|
||||
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn
|
||||
guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid)
|
||||
return Authorized
|
||||
CourseR tid csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do
|
||||
Entity cid _ <- MaybeT . lift . getBy $ CourseTermShort tid csh
|
||||
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do
|
||||
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
guard $ cid `Set.member` Map.keysSet resMap
|
||||
return Authorized
|
||||
_ -> do
|
||||
@ -340,8 +344,8 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
|
||||
return Authorized
|
||||
)
|
||||
,("time", APDB $ \route _ -> case route of
|
||||
CSheetR tid csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
|
||||
Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh
|
||||
CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
|
||||
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
|
||||
cTime <- liftIO getCurrentTime
|
||||
let
|
||||
@ -360,8 +364,8 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
|
||||
|
||||
return Authorized
|
||||
|
||||
CourseR tid csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do
|
||||
Entity cid Course{..} <- MaybeT . getBy $ CourseTermShort tid csh
|
||||
CourseR tid ssh csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do
|
||||
Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
cTime <- (NTop . Just) <$> liftIO getCurrentTime
|
||||
guard $ NTop courseRegisterFrom <= cTime
|
||||
&& NTop courseRegisterTo >= cTime
|
||||
@ -370,12 +374,13 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
|
||||
r -> $unsupportedAuthPredicate "time" r
|
||||
)
|
||||
,("registered", APDB $ \route _ -> case route of
|
||||
CourseR tid csh _ -> exceptT return return $ do
|
||||
CourseR tid ssh csh _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
|
||||
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
|
||||
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
return (E.countRows :: E.SqlExpr (E.Value Int64))
|
||||
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant)
|
||||
@ -383,22 +388,22 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
|
||||
r -> $unsupportedAuthPredicate "registered" r
|
||||
)
|
||||
,("capacity", APDB $ \route _ -> case route of
|
||||
CourseR tid csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do
|
||||
Entity cid Course{..} <- MaybeT . getBy $ CourseTermShort tid csh
|
||||
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do
|
||||
Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
|
||||
guard $ NTop courseCapacity > NTop (Just registered)
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate "capacity" r
|
||||
)
|
||||
,("materials", APDB $ \route _ -> case route of
|
||||
CourseR tid csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
|
||||
Entity _ Course{..} <- MaybeT . getBy $ CourseTermShort tid csh
|
||||
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
|
||||
Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
guard courseMaterialFree
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate "materials" r
|
||||
)
|
||||
,("owner", APDB $ \route _ -> case route of
|
||||
CSubmissionR _ _ _ cID _ -> exceptT return return $ do
|
||||
CSubmissionR _ _ _ _ cID _ -> exceptT return return $ do
|
||||
sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
|
||||
@ -406,7 +411,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
|
||||
r -> $unsupportedAuthPredicate "owner" r
|
||||
)
|
||||
,("rated", APDB $ \route _ -> case route of
|
||||
CSubmissionR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
|
||||
CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
|
||||
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
sub <- MaybeT $ get sid
|
||||
guard $ submissionRatingDone sub
|
||||
@ -476,14 +481,14 @@ instance Yesod UniWorX where
|
||||
updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do
|
||||
route <- MaybeT getCurrentRoute
|
||||
case route of -- update Course Favourites here
|
||||
CourseR tid csh _ -> do
|
||||
CourseR tid ssh csh _ -> do
|
||||
void . lift . runDB . runMaybeT $ do
|
||||
guardM . lift $ (== Authorized) <$> evalAccessDB (CourseR tid csh CShowR) False
|
||||
guardM . lift $ (== Authorized) <$> evalAccessDB (CourseR tid ssh csh CShowR) False
|
||||
$logDebugS "updateFavourites" "Updating favourites"
|
||||
|
||||
now <- liftIO $ getCurrentTime
|
||||
uid <- MaybeT $ liftHandlerT maybeAuthId
|
||||
cid <- MaybeT . getKeyBy $ CourseTermShort tid csh
|
||||
cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
user <- MaybeT $ get uid
|
||||
let courseFavourite = CourseFavourite uid now cid
|
||||
|
||||
@ -546,7 +551,7 @@ instance Yesod UniWorX where
|
||||
return (favs, userTheme user)
|
||||
favourites <- forM favourites' $ \(Entity _ c@Course{..})
|
||||
-> let
|
||||
courseRoute = CourseR courseTerm courseShorthand CShowR
|
||||
courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR
|
||||
in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute)
|
||||
|
||||
let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority
|
||||
@ -666,27 +671,29 @@ instance YesodBreadcrumbs UniWorX where
|
||||
breadcrumb (TermEditExistR tid) = return ("Editieren" , Just $ TermCourseListR tid)
|
||||
breadcrumb (TermCourseListR (unTermKey -> tid)) = getMessageRender <&> \mr -> (mr $ ShortTermIdentifier tid, Just TermShowR)
|
||||
|
||||
breadcrumb (TermSchoolCourseListR tid ssh) = return (CI.original $ unSchoolKey ssh, Just $ TermCourseListR tid)
|
||||
|
||||
breadcrumb CourseListR = return ("Kurse" , Just HomeR)
|
||||
breadcrumb CourseNewR = return ("Neu" , Just CourseListR)
|
||||
breadcrumb (CourseR tid csh CShowR) = return (CI.original csh, Just $ TermCourseListR tid)
|
||||
-- (CourseR tid csh CRegisterR) -- is POST only
|
||||
breadcrumb (CourseR tid csh CEditR) = return ("Editieren", Just $ CourseR tid csh CShowR)
|
||||
breadcrumb (CourseR tid csh CCorrectionsR) = return ("Abgaben",Just $ CourseR tid csh CShowR)
|
||||
breadcrumb (CourseR tid csh SheetListR) = return ("Übungen" , Just $ CourseR tid csh CShowR)
|
||||
breadcrumb (CourseR tid csh SheetNewR ) = return ("Neu", Just $ CourseR tid csh SheetListR)
|
||||
breadcrumb (CourseR tid ssh csh CShowR) = return (CI.original csh, Just $ TermSchoolCourseListR tid ssh)
|
||||
-- (CourseR tid ssh csh CRegisterR) -- is POST only
|
||||
breadcrumb (CourseR tid ssh csh CEditR) = return ("Editieren", Just $ CourseR tid ssh csh CShowR)
|
||||
breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben",Just $ CourseR tid ssh csh CShowR)
|
||||
breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen" , Just $ CourseR tid ssh csh CShowR)
|
||||
breadcrumb (CourseR tid ssh csh SheetNewR ) = return ("Neu", Just $ CourseR tid ssh csh SheetListR)
|
||||
|
||||
breadcrumb (CSheetR tid csh shn SShowR) = return (CI.original shn, Just $ CourseR tid csh SheetListR)
|
||||
breadcrumb (CSheetR tid csh shn SEditR) = return ("Edit", Just $ CSheetR tid csh shn SShowR)
|
||||
breadcrumb (CSheetR tid csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid csh shn SShowR)
|
||||
breadcrumb (CSheetR tid csh shn SSubsR) = return ("Abgaben", Just $ CSheetR tid csh shn SShowR)
|
||||
breadcrumb (CSheetR tid csh shn SubmissionNewR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR)
|
||||
breadcrumb (CSheetR tid csh shn SubmissionOwnR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR)
|
||||
breadcrumb (CSubmissionR tid csh shn _ SubShowR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR)
|
||||
-- (CSubmissionR tid csh shn _ SubArchiveR) -- just for Download
|
||||
breadcrumb (CSubmissionR tid csh shn cid CorrectionR) = return ("Korrektur", Just $ CSubmissionR tid csh shn cid SubShowR)
|
||||
-- (CSubmissionR tid csh shn _ SubDownloadR) -- just for Download
|
||||
breadcrumb (CSheetR tid csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid csh shn SShowR)
|
||||
-- (CSheetR tid csh shn SFileR) -- just for Downloads
|
||||
breadcrumb (CSheetR tid ssh csh shn SShowR) = return (CI.original shn, Just $ CourseR tid ssh csh SheetListR)
|
||||
breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Edit", Just $ CSheetR tid ssh csh shn SShowR)
|
||||
breadcrumb (CSheetR tid ssh csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid ssh csh shn SShowR)
|
||||
breadcrumb (CSheetR tid ssh csh shn SSubsR) = return ("Abgaben", Just $ CSheetR tid ssh csh shn SShowR)
|
||||
breadcrumb (CSheetR tid ssh csh shn SubmissionNewR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR)
|
||||
breadcrumb (CSheetR tid ssh csh shn SubmissionOwnR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR)
|
||||
breadcrumb (CSubmissionR tid ssh csh shn _ SubShowR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR)
|
||||
-- (CSubmissionR tid ssh csh shn _ SubArchiveR) -- just for Download
|
||||
breadcrumb (CSubmissionR tid ssh csh shn cid CorrectionR) = return ("Korrektur", Just $ CSubmissionR tid ssh csh shn cid SubShowR)
|
||||
-- (CSubmissionR tid ssh csh shn _ SubDownloadR) -- just for Download
|
||||
breadcrumb (CSheetR tid ssh csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid ssh csh shn SShowR)
|
||||
-- (CSheetR tid ssh csh shn SFileR) -- just for Downloads
|
||||
-- Others
|
||||
breadcrumb (CorrectionsR) = return ("Korrekturen", Just HomeR)
|
||||
breadcrumb (CorrectionsUploadR) = return ("Hochladen", Just CorrectionsR)
|
||||
@ -826,22 +833,22 @@ pageActions (CourseListR) =
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CourseR tid csh CShowR) =
|
||||
pageActions (CourseR tid ssh csh CShowR) =
|
||||
[ PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Kurs Editieren"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CourseR tid csh CEditR
|
||||
, menuItemRoute = CourseR tid ssh csh CEditR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Übungsblätter"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CourseR tid csh SheetListR
|
||||
, menuItemRoute = CourseR tid ssh csh SheetListR
|
||||
, menuItemAccessCallback' = do --TODO always show for lecturer
|
||||
let sheetRouteAccess shn = (== Authorized) <$> (isAuthorized (CSheetR tid csh shn SShowR) False)
|
||||
let sheetRouteAccess shn = (== Authorized) <$> (isAuthorized (CSheetR tid ssh csh shn SShowR) False)
|
||||
muid <- maybeAuthId
|
||||
(sheets,lecturer) <- runDB $ do
|
||||
cid <- getKeyBy404 $ CourseTermShort tid csh
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
sheets <- map (sheetName.entityVal) <$> selectList [SheetCourse ==. cid] [Desc SheetActiveFrom]
|
||||
lecturer <- case muid of
|
||||
Nothing -> return False
|
||||
@ -852,29 +859,29 @@ pageActions (CourseR tid csh CShowR) =
|
||||
, PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Abgaben"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CourseR tid csh CCorrectionsR
|
||||
, menuItemRoute = CourseR tid ssh csh CCorrectionsR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, PageActionSecondary $ MenuItem
|
||||
{ menuItemLabel = "Neues Übungsblatt anlegen"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CourseR tid csh SheetNewR
|
||||
, menuItemRoute = CourseR tid ssh csh SheetNewR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CourseR tid csh SheetListR) =
|
||||
pageActions (CourseR tid ssh csh SheetListR) =
|
||||
[ PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Neues Übungsblatt anlegen"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CourseR tid csh SheetNewR
|
||||
, menuItemRoute = CourseR tid ssh csh SheetNewR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CSheetR tid csh shn SShowR) =
|
||||
pageActions (CSheetR tid ssh csh shn SShowR) =
|
||||
[ PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Abgabe anlegen"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CSheetR tid csh shn SubmissionNewR
|
||||
, menuItemRoute = CSheetR tid ssh csh shn SubmissionNewR
|
||||
, menuItemAccessCallback' = runDB . maybeT (return False) $ do
|
||||
uid <- MaybeT $ liftHandlerT maybeAuthId
|
||||
submissions <- lift $ submissionList tid csh shn uid
|
||||
@ -884,7 +891,7 @@ pageActions (CSheetR tid csh shn SShowR) =
|
||||
, PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Abgabe ansehen"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CSheetR tid csh shn SubmissionOwnR
|
||||
, menuItemRoute = CSheetR tid ssh csh shn SubmissionOwnR
|
||||
, menuItemAccessCallback' = runDB . maybeT (return False) $ do
|
||||
uid <- MaybeT $ liftHandlerT maybeAuthId
|
||||
submissions <- lift $ submissionList tid csh shn uid
|
||||
@ -894,43 +901,43 @@ pageActions (CSheetR tid csh shn SShowR) =
|
||||
, PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Korrektoren"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CSheetR tid csh shn SCorrR
|
||||
, menuItemRoute = CSheetR tid ssh csh shn SCorrR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Abgaben"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CSheetR tid csh shn SSubsR
|
||||
, menuItemRoute = CSheetR tid ssh csh shn SSubsR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Blatt Editieren"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CSheetR tid csh shn SEditR
|
||||
, menuItemRoute = CSheetR tid ssh csh shn SEditR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CSheetR tid csh shn SSubsR) =
|
||||
pageActions (CSheetR tid ssh csh shn SSubsR) =
|
||||
[ PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Korrektoren"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CSheetR tid csh shn SCorrR
|
||||
, menuItemRoute = CSheetR tid ssh csh shn SCorrR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CSubmissionR tid csh shn cid SubShowR) =
|
||||
pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
|
||||
[ PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Korrektur"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CSubmissionR tid csh shn cid CorrectionR
|
||||
, menuItemRoute = CSubmissionR tid ssh csh shn cid CorrectionR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CSheetR tid csh shn SCorrR) =
|
||||
pageActions (CSheetR tid ssh csh shn SCorrR) =
|
||||
[ PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Abgaben"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CSheetR tid csh shn SSubsR
|
||||
, menuItemRoute = CSheetR tid ssh csh shn SSubsR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
@ -977,45 +984,49 @@ pageHeading (TermEditExistR tid)
|
||||
= Just $ i18nHeading $ MsgTermEditTid tid
|
||||
pageHeading (TermCourseListR tid)
|
||||
= Just . i18nHeading . MsgTermCourseListHeading $ tid
|
||||
pageHeading (TermSchoolCourseListR tid ssh)
|
||||
= Just $ do
|
||||
School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh
|
||||
i18nHeading $ MsgTermSchoolCourseListHeading tid school
|
||||
|
||||
pageHeading (CourseListR)
|
||||
= Just $ i18nHeading $ MsgCourseListTitle
|
||||
pageHeading CourseNewR
|
||||
= Just $ i18nHeading MsgCourseNewHeading
|
||||
pageHeading (CourseR tid csh CShowR)
|
||||
pageHeading (CourseR tid ssh csh CShowR)
|
||||
= Just $ do
|
||||
Entity _ Course{..} <- handlerToWidget . runDB . getBy404 $ CourseTermShort tid csh
|
||||
Entity _ Course{..} <- handlerToWidget . runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
toWidget courseName
|
||||
-- (CourseR tid csh CRegisterR) -- just for POST
|
||||
pageHeading (CourseR tid csh CEditR)
|
||||
= Just $ i18nHeading $ MsgCourseEditHeading tid csh
|
||||
pageHeading (CourseR tid csh CCorrectionsR)
|
||||
= Just $ i18nHeading $ MsgSubmissionsCourse tid csh
|
||||
pageHeading (CourseR tid csh SheetListR)
|
||||
= Just $ i18nHeading $ MsgSheetList tid csh
|
||||
pageHeading (CourseR tid csh SheetNewR)
|
||||
= Just $ i18nHeading $ MsgSheetNewHeading tid csh
|
||||
pageHeading (CSheetR tid csh shn SShowR)
|
||||
= Just $ i18nHeading $ MsgSheetTitle tid csh shn
|
||||
pageHeading (CSheetR tid csh shn SEditR)
|
||||
= Just $ i18nHeading $ MsgSheetEditHead tid csh shn
|
||||
pageHeading (CSheetR tid csh shn SDelR)
|
||||
= Just $ i18nHeading $ MsgSheetDelHead tid csh shn
|
||||
pageHeading (CSheetR tid csh shn SSubsR)
|
||||
pageHeading (CourseR tid ssh csh CEditR)
|
||||
= Just $ i18nHeading $ MsgCourseEditHeading tid ssh csh
|
||||
pageHeading (CourseR tid ssh csh CCorrectionsR)
|
||||
= Just $ i18nHeading $ MsgSubmissionsCourse tid ssh csh
|
||||
pageHeading (CourseR tid ssh csh SheetListR)
|
||||
= Just $ i18nHeading $ MsgSheetList tid ssh csh
|
||||
pageHeading (CourseR tid ssh csh SheetNewR)
|
||||
= Just $ i18nHeading $ MsgSheetNewHeading tid ssh csh
|
||||
pageHeading (CSheetR tid ssh csh shn SShowR)
|
||||
= Just $ i18nHeading $ MsgSheetTitle tid ssh csh shn
|
||||
pageHeading (CSheetR tid ssh csh shn SEditR)
|
||||
= Just $ i18nHeading $ MsgSheetEditHead tid ssh csh shn
|
||||
pageHeading (CSheetR tid ssh csh shn SDelR)
|
||||
= Just $ i18nHeading $ MsgSheetDelHead tid ssh csh shn
|
||||
pageHeading (CSheetR tid ssh csh shn SSubsR)
|
||||
= Just $ i18nHeading $ MsgSubmissionsSheet shn
|
||||
pageHeading (CSheetR tid csh shn SubmissionNewR)
|
||||
= Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn
|
||||
pageHeading (CSheetR tid csh shn SubmissionOwnR)
|
||||
= Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn
|
||||
pageHeading (CSubmissionR tid csh shn _ SubShowR) -- TODO: Rethink this one!
|
||||
= Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn
|
||||
pageHeading (CSheetR tid ssh csh shn SubmissionNewR)
|
||||
= Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn
|
||||
pageHeading (CSheetR tid ssh csh shn SubmissionOwnR)
|
||||
= Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn
|
||||
pageHeading (CSubmissionR tid ssh csh shn _ SubShowR) -- TODO: Rethink this one!
|
||||
= Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn
|
||||
-- (CSubmissionR tid csh shn cid SubArchiveR) -- just a download
|
||||
pageHeading (CSubmissionR tid csh shn cid CorrectionR)
|
||||
= Just $ i18nHeading $ MsgCorrectionHead tid csh shn cid
|
||||
pageHeading (CSubmissionR tid ssh csh shn cid CorrectionR)
|
||||
= Just $ i18nHeading $ MsgCorrectionHead tid ssh csh shn cid
|
||||
-- (CSubmissionR tid csh shn cid SubDownloadR) -- just a download
|
||||
pageHeading (CSheetR tid csh shn SCorrR)
|
||||
pageHeading (CSheetR tid ssh csh shn SCorrR)
|
||||
= Just $ i18nHeading $ MsgCorrectorsHead shn
|
||||
-- (CSheetR tid csh shn SFileR) -- just for Downloads
|
||||
-- (CSheetR tid ssh csh shn SFileR) -- just for Downloads
|
||||
|
||||
pageHeading CorrectionsR
|
||||
= Just $ i18nHeading MsgCorrectionsTitle
|
||||
@ -1030,6 +1041,7 @@ pageHeading _
|
||||
routeNormalizers :: [Route UniWorX -> WriterT Any (ReaderT (YesodPersistBackend UniWorX) (HandlerT UniWorX IO)) (Route UniWorX)]
|
||||
routeNormalizers =
|
||||
[ normalizeRender
|
||||
, ncSchool
|
||||
, ncCourse
|
||||
, ncSheet
|
||||
]
|
||||
@ -1050,17 +1062,25 @@ routeNormalizers =
|
||||
$logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|]
|
||||
tell $ Any True
|
||||
| otherwise = return ()
|
||||
ncSchool = maybeOrig $ \route -> do
|
||||
TermSchoolCourseListR tid ssh <- return route
|
||||
let schoolShort :: SchoolShorthand
|
||||
schoolShort = unSchoolKey ssh
|
||||
Entity ssh' _ <- MaybeT . lift . getBy $ UniqueSchoolShorthand schoolShort
|
||||
(hasChanged `on` unSchoolKey)ssh ssh'
|
||||
return $ TermSchoolCourseListR tid ssh'
|
||||
ncCourse = maybeOrig $ \route -> do
|
||||
CourseR tid csh subRoute <- return route
|
||||
Entity _ Course{..} <- MaybeT . lift . getBy $ CourseTermShort tid csh
|
||||
CourseR tid ssh csh subRoute <- return route
|
||||
Entity _ Course{..} <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
hasChanged csh courseShorthand
|
||||
return $ CourseR tid courseShorthand subRoute
|
||||
(hasChanged `on` unSchoolKey) ssh courseSchool
|
||||
return $ CourseR tid courseSchool courseShorthand subRoute
|
||||
ncSheet = maybeOrig $ \route -> do
|
||||
CSheetR tid csh shn subRoute <- return route
|
||||
Entity cid _ <- MaybeT . lift . getBy $ CourseTermShort tid csh
|
||||
CSheetR tid ssh csh shn subRoute <- return route
|
||||
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Sheet{..} <- MaybeT . lift . getBy $ CourseSheet cid shn
|
||||
hasChanged shn sheetName
|
||||
return $ CSheetR tid csh sheetName subRoute
|
||||
return $ CSheetR tid ssh csh sheetName subRoute
|
||||
|
||||
|
||||
-- How to run database actions.
|
||||
|
||||
@ -86,17 +86,19 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm)
|
||||
colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colCourse = sortable (Just "course") (i18nCell MsgCourse)
|
||||
$ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
|
||||
let tid = course ^. _3
|
||||
csh = course ^. _2
|
||||
in anchorCell (CourseR tid csh CShowR) [whamlet|#{display csh}|]
|
||||
let csh = course ^. _2
|
||||
tid = course ^. _3
|
||||
ssh = course ^. _4
|
||||
in anchorCell (CourseR tid ssh csh CShowR) [whamlet|#{display csh}|]
|
||||
|
||||
colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
|
||||
$ \DBRow{ dbrOutput=(_, sheet, course, _, _) } ->
|
||||
let tid = course ^. _3
|
||||
csh = course ^. _2
|
||||
let csh = course ^. _2
|
||||
tid = course ^. _3
|
||||
ssh = course ^. _4
|
||||
shn = sheetName $ entityVal sheet
|
||||
in anchorCell (CSheetR tid csh shn SShowR) [whamlet|#{display shn}|]
|
||||
in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|#{display shn}|]
|
||||
|
||||
colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
|
||||
@ -106,13 +108,14 @@ colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
|
||||
colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
|
||||
$ \DBRow{ dbrOutput=(submission, sheet, course, _, _) } ->
|
||||
let tid = course ^. _3
|
||||
csh = course ^. _2
|
||||
let csh = course ^. _2
|
||||
tid = course ^. _3
|
||||
ssh = course ^. _4
|
||||
shn = sheetName $ entityVal sheet
|
||||
mkCid = encrypt (entityKey submission :: SubmissionId) -- TODO: executed twice
|
||||
mkRoute = do
|
||||
cid <- mkCid
|
||||
return $ CSubmissionR tid csh shn cid SubShowR
|
||||
return $ CSubmissionR tid ssh csh shn cid SubShowR
|
||||
in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|])
|
||||
|
||||
colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool)))
|
||||
@ -125,12 +128,13 @@ colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutp
|
||||
|
||||
colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId Submission{..}, Entity _ Sheet{..}, course, _, _) } ->
|
||||
let tid = course ^. _3
|
||||
csh = course ^. _2
|
||||
let csh = course ^. _2
|
||||
tid = course ^. _3
|
||||
ssh = course ^. _4
|
||||
-- shn = sheetName
|
||||
mkRoute = do
|
||||
cid <- encrypt subId
|
||||
return $ CSubmissionR tid csh sheetName cid CorrectionR
|
||||
return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
|
||||
in anchorCellM mkRoute $(widgetFile "widgets/rating")
|
||||
|
||||
type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
|
||||
@ -340,10 +344,10 @@ postCorrectionsR = do
|
||||
[ downloadAction
|
||||
]
|
||||
|
||||
getCCorrectionsR, postCCorrectionsR :: TermId -> CourseShorthand -> Handler TypedContent
|
||||
getCCorrectionsR, postCCorrectionsR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
|
||||
getCCorrectionsR = postCCorrectionsR
|
||||
postCCorrectionsR tid csh = do
|
||||
Entity cid _ <- runDB $ getBy404 $ CourseTermShort tid csh
|
||||
postCCorrectionsR tid ssh csh = do
|
||||
Entity cid _ <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
let whereClause = courseIs cid
|
||||
colonnade = mconcat
|
||||
[ colSelect
|
||||
@ -360,10 +364,10 @@ postCCorrectionsR tid csh = do
|
||||
, assignAction (Left cid)
|
||||
]
|
||||
|
||||
getSSubsR, postSSubsR :: TermId -> CourseShorthand -> SheetName -> Handler TypedContent
|
||||
getSSubsR, postSSubsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
|
||||
getSSubsR = postSSubsR
|
||||
postSSubsR tid csh shn = do
|
||||
shid <- runDB $ fetchSheetId tid csh shn
|
||||
postSSubsR tid ssh csh shn = do
|
||||
shid <- runDB $ fetchSheetId tid ssh csh shn
|
||||
let whereClause = sheetIs shid
|
||||
colonnade = mconcat
|
||||
[ colSelect
|
||||
@ -380,26 +384,26 @@ postSSubsR tid csh shn = do
|
||||
, autoAssignAction shid
|
||||
]
|
||||
|
||||
correctionData tid csh shn sub = E.select . E.from $ \((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> do
|
||||
correctionData :: TermId -> SchoolId -> CourseShorthand -> SheetName -> _ -- CryptoFileNameSubmission -> _
|
||||
correctionData tid ssh csh shn sub = E.select . E.from $ \((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> do
|
||||
E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
|
||||
E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
||||
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
||||
|
||||
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
E.&&. sheet E.^. SheetName E.==. E.val shn
|
||||
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.&&. sheet E.^. SheetName E.==. E.val shn
|
||||
E.&&. submission E.^. SubmissionId E.==. E.val sub
|
||||
|
||||
return (course, sheet, submission, corrector)
|
||||
|
||||
getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
|
||||
getCorrectionR tid csh shn cid = do
|
||||
mayPost <- isAuthorized (CSubmissionR tid csh shn cid CorrectionR) True
|
||||
bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid csh shn cid
|
||||
postCorrectionR tid csh shn cid = do
|
||||
getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
|
||||
getCorrectionR tid ssh csh shn cid = do
|
||||
mayPost <- isAuthorized (CSubmissionR tid ssh csh shn cid CorrectionR) True
|
||||
bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid ssh csh shn cid
|
||||
postCorrectionR tid ssh csh shn cid = do
|
||||
sub <- decrypt cid
|
||||
|
||||
results <- runDB $ correctionData tid csh shn sub
|
||||
results <- runDB $ correctionData tid ssh csh shn sub
|
||||
|
||||
case results of
|
||||
[(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector)] -> do
|
||||
@ -424,14 +428,14 @@ postCorrectionR tid csh shn cid = do
|
||||
|
||||
let rated = isJust $ void ratingPoints <|> void ratingComment
|
||||
|
||||
update sub [ SubmissionRatingBy =. (uid <$ guard rated)
|
||||
, SubmissionRatingTime =. (now <$ guard rated)
|
||||
, SubmissionRatingPoints =. ratingPoints
|
||||
update sub [ SubmissionRatingBy =. (uid <$ guard rated)
|
||||
, SubmissionRatingTime =. (now <$ guard rated)
|
||||
, SubmissionRatingPoints =. ratingPoints
|
||||
, SubmissionRatingComment =. ratingComment
|
||||
]
|
||||
|
||||
addMessageI "success" $ bool MsgRatingDeleted MsgRatingUpdated rated
|
||||
redirect $ CSubmissionR tid csh shn cid CorrectionR
|
||||
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
|
||||
|
||||
case uploadResult of
|
||||
FormMissing -> return ()
|
||||
@ -442,16 +446,16 @@ postCorrectionR tid csh shn cid = do
|
||||
runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
|
||||
|
||||
addMessageI "success" MsgRatingFilesUpdated
|
||||
redirect $ CSubmissionR tid csh shn cid CorrectionR
|
||||
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
|
||||
|
||||
defaultLayout $ do
|
||||
let userCorrection = $(widgetFile "correction-user")
|
||||
$(widgetFile "correction")
|
||||
_ -> notFound
|
||||
getCorrectionUserR tid csh shn cid = do
|
||||
getCorrectionUserR tid ssh csh shn cid = do
|
||||
sub <- decrypt cid
|
||||
|
||||
results <- runDB $ correctionData tid csh shn sub
|
||||
results <- runDB $ correctionData tid ssh csh shn sub
|
||||
|
||||
case results of
|
||||
[(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _))] -> do
|
||||
|
||||
@ -39,13 +39,13 @@ type CourseTableData = DBRow (Entity Course, Int64, Bool, Entity School)
|
||||
colCourse :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
||||
colCourse = sortable (Just "course") (i18nCell MsgCourse)
|
||||
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
|
||||
anchorCell (CourseR courseTerm courseShorthand CShowR)
|
||||
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
|
||||
[whamlet|#{display courseName}|]
|
||||
|
||||
colCourseDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
||||
colCourseDescr = sortable (Just "course") (i18nCell MsgCourse)
|
||||
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> mappend
|
||||
( anchorCell (CourseR courseTerm courseShorthand CShowR) [whamlet|#{display courseName}|] )
|
||||
( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseName}|] )
|
||||
( case courseDescription of
|
||||
Nothing -> mempty
|
||||
(Just descr) -> cell [whamlet| <span style="float:right"> ^{modalStatic descr} |]
|
||||
@ -61,12 +61,12 @@ colDescription = sortable Nothing (i18nCell MsgCourseDescription)
|
||||
colCShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
||||
colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
|
||||
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
|
||||
anchorCell (CourseR courseTerm courseShorthand CShowR) [whamlet|#{display courseShorthand}|]
|
||||
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|]
|
||||
|
||||
colCShortDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
||||
colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort)
|
||||
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> mappend
|
||||
( anchorCell (CourseR courseTerm courseShorthand CShowR) [whamlet|#{display courseShorthand}|] )
|
||||
( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] )
|
||||
( case courseDescription of
|
||||
Nothing -> mempty
|
||||
(Just descr) -> cell
|
||||
@ -80,13 +80,13 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm)
|
||||
|
||||
colSchool :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
||||
colSchool = sortable (Just "school") (i18nCell MsgCourseSchool)
|
||||
$ \DBRow{ dbrOutput=(_, _, _, Entity _ School{..}) } ->
|
||||
cell [whamlet|#{display schoolName}|]
|
||||
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } ->
|
||||
anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolName}|]
|
||||
|
||||
colSchoolShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
||||
colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
|
||||
$ \DBRow{ dbrOutput=(_, _, _, Entity _ School{..}) } ->
|
||||
cell [whamlet|#{display schoolShorthand}|]
|
||||
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } ->
|
||||
anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolShorthand}|]
|
||||
|
||||
colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
|
||||
colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom)
|
||||
@ -201,6 +201,30 @@ getTermCurrentR = do
|
||||
(Just (maximum -> tid)) -> -- getTermCourseListR tid
|
||||
redirect $ TermCourseListR tid -- redirect avoids problematic breadcrumbs, headings, etc.
|
||||
|
||||
getTermSchoolCourseListR :: TermId -> SchoolId -> Handler Html
|
||||
getTermSchoolCourseListR tid ssh = do
|
||||
void . runDB $ get404 tid -- Just ensure the term exists
|
||||
School{schoolName=school} <- runDB $ get404 ssh -- Just ensure the term exists
|
||||
muid <- maybeAuthId
|
||||
let colonnade = widgetColonnade $ mconcat
|
||||
[ dbRow
|
||||
, colCShortDescr
|
||||
, colRegFrom
|
||||
, colRegTo
|
||||
, colParticipants
|
||||
, maybe mempty (const colRegistered) muid
|
||||
]
|
||||
whereClause = \(course, _, _) ->
|
||||
course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
validator = def
|
||||
& defaultSorting [("cshort", SortAsc)]
|
||||
((), coursesTable) <- makeCourseTable whereClause colonnade validator
|
||||
defaultLayout $ do
|
||||
setTitleI $ MsgTermSchoolCourseListTitle tid school
|
||||
$(widgetFile "courses")
|
||||
|
||||
|
||||
getTermCourseListR :: TermId -> Handler Html
|
||||
getTermCourseListR tid = do
|
||||
void . runDB $ get404 tid -- Just ensure the term exists
|
||||
@ -222,13 +246,13 @@ getTermCourseListR tid = do
|
||||
setTitleI . MsgTermCourseListTitle $ tid
|
||||
$(widgetFile "courses")
|
||||
|
||||
getCShowR :: TermId -> CourseShorthand -> Handler Html
|
||||
getCShowR tid csh = do
|
||||
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCShowR tid ssh csh = do
|
||||
mbAid <- maybeAuthId
|
||||
(courseEnt,(schoolMB,participants,registered)) <- runDB $ do
|
||||
courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort tid csh
|
||||
courseEnt@(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
dependent <- (,,)
|
||||
<$> get (courseSchool course) -- join
|
||||
<$> get (courseSchool course) -- join -- just fetch full school name here
|
||||
<*> count [CourseParticipantCourse ==. cid] -- join
|
||||
<*> (case mbAid of -- TODO: Someone please refactor this late-night mess here!
|
||||
Nothing -> return False
|
||||
@ -238,7 +262,7 @@ getCShowR tid csh = do
|
||||
return $ (courseEnt,dependent)
|
||||
let course = entityVal courseEnt
|
||||
(regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
|
||||
registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid csh CRegisterR) True
|
||||
registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
|
||||
mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
|
||||
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
|
||||
defaultLayout $ do
|
||||
@ -258,11 +282,11 @@ registerForm registered msecret extra = do
|
||||
return (btnRes *> ((==msecret) <$> msecretRes), widget) -- checks that correct button was pressed, and ignores result of btnRes
|
||||
|
||||
|
||||
postCRegisterR :: TermId -> CourseShorthand -> Handler Html
|
||||
postCRegisterR tid csh = do
|
||||
postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
postCRegisterR tid ssh csh = do
|
||||
aid <- requireAuthId
|
||||
(cid, course, registered) <- runDB $ do
|
||||
(Entity cid course) <- getBy404 $ CourseTermShort tid csh
|
||||
(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
registered <- isJust <$> (getBy $ UniqueParticipant aid cid)
|
||||
return (cid, course, registered)
|
||||
((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
|
||||
@ -277,7 +301,7 @@ postCRegisterR tid csh = do
|
||||
when (isJust regOk) $ addMessageI "success" MsgCourseRegisterOk
|
||||
| otherwise -> addMessageI "danger" MsgCourseSecretWrong
|
||||
(_other) -> return () -- TODO check this!
|
||||
redirect $ CourseR tid csh CShowR
|
||||
redirect $ CourseR tid ssh csh CShowR
|
||||
|
||||
getCourseNewR :: Handler Html
|
||||
getCourseNewR = do
|
||||
@ -287,14 +311,14 @@ getCourseNewR = do
|
||||
postCourseNewR :: Handler Html
|
||||
postCourseNewR = courseEditHandler False Nothing
|
||||
|
||||
getCEditR :: TermId -> CourseShorthand -> Handler Html
|
||||
getCEditR tid csh = do
|
||||
course <- runDB $ getBy $ CourseTermShort tid csh
|
||||
getCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCEditR tid ssh csh = do
|
||||
course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh
|
||||
courseEditHandler True course
|
||||
|
||||
postCEditR :: TermId -> CourseShorthand -> Handler Html
|
||||
postCEditR tid csh = do
|
||||
course <- runDB $ getBy $ CourseTermShort tid csh
|
||||
postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
postCEditR tid ssh csh = do
|
||||
course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh
|
||||
courseEditHandler False course
|
||||
|
||||
|
||||
@ -317,6 +341,7 @@ courseEditHandler isGet course = do
|
||||
(FormSuccess res@(
|
||||
CourseForm { cfCourseId = Nothing
|
||||
, cfShort = csh
|
||||
, cfSchool = ssh
|
||||
, cfTerm = tid
|
||||
})) -> do -- create new course
|
||||
now <- liftIO getCurrentTime
|
||||
@ -339,14 +364,15 @@ courseEditHandler isGet course = do
|
||||
runDB $ do
|
||||
insert_ $ CourseEdit aid now cid
|
||||
insert_ $ Lecturer aid cid
|
||||
addMessageI "info" $ MsgCourseNewOk tid csh
|
||||
addMessageI "info" $ MsgCourseNewOk tid ssh csh
|
||||
redirect $ TermCourseListR tid
|
||||
Nothing ->
|
||||
addMessageI "danger" $ MsgCourseNewDupShort tid csh
|
||||
addMessageI "danger" $ MsgCourseNewDupShort tid ssh csh
|
||||
|
||||
(FormSuccess res@(
|
||||
CourseForm { cfCourseId = Just cid
|
||||
, cfShort = csh
|
||||
, cfSchool = ssh
|
||||
, cfTerm = tid
|
||||
})) -> do -- edit existing course
|
||||
now <- liftIO getCurrentTime
|
||||
@ -372,12 +398,12 @@ courseEditHandler isGet course = do
|
||||
}
|
||||
)
|
||||
case updOkay of
|
||||
(Just _) -> addMessageI "danger" (MsgCourseEditDupShort tid csh) $> False
|
||||
(Just _) -> addMessageI "danger" (MsgCourseEditDupShort tid ssh csh) $> False
|
||||
Nothing -> do
|
||||
insert_ $ CourseEdit aid now cid
|
||||
addMessageI "success" $ MsgCourseEditOk tid csh
|
||||
addMessageI "success" $ MsgCourseEditOk tid ssh csh
|
||||
return True
|
||||
when success $ redirect $ CourseR tid csh CShowR
|
||||
when success $ redirect $ CourseR tid ssh csh CShowR
|
||||
|
||||
(FormFailure _) -> addMessageI "warning" MsgInvalidInput
|
||||
(FormMissing) -> return ()
|
||||
@ -429,7 +455,6 @@ newCourseForm template = identForm FIDcourse $ \html -> do
|
||||
[ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] []
|
||||
, map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. userId] []
|
||||
]
|
||||
let schoolField = selectField $ fmap entityKey <$> optionsPersistCryptoId [SchoolId <-. userSchools] [Asc SchoolName] schoolName
|
||||
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
|
||||
<$> pure (cfCourseId =<< template)
|
||||
<*> areq (ciField textField) (fslI MsgCourseName) (cfName <$> template)
|
||||
@ -440,24 +465,19 @@ newCourseForm template = identForm FIDcourse $ \html -> do
|
||||
-- & addAttr "disabled" "disabled"
|
||||
& setTooltip MsgCourseShorthandUnique)
|
||||
(cfShort <$> template)
|
||||
<*> areq termActiveField (fslI MsgCourseSemester) (cfTerm <$> template)
|
||||
<*> areq schoolField (fslI MsgCourseSchool) (cfSchool <$> template)
|
||||
<*> aopt (natField "Kapazität") (fslI MsgCourseCapacity
|
||||
& setTooltip MsgCourseCapacityTip
|
||||
) (cfCapacity <$> template)
|
||||
<*> aopt textField (fslpI MsgCourseSecret "beliebige Zeichenkette"
|
||||
& setTooltip MsgCourseSecretTip)
|
||||
(cfSecret <$> template)
|
||||
<*> areq checkBoxField (fslI MsgMaterialFree)(cfMatFree <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgRegisterFrom "Datum"
|
||||
& setTooltip MsgCourseRegisterFromTip)
|
||||
(cfRegFrom <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgRegisterTo "Datum"
|
||||
& setTooltip MsgCourseRegisterToTip)
|
||||
(cfRegTo <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgDeRegUntil "Datum"
|
||||
& setTooltip MsgCourseDeregisterUntilTip)
|
||||
(cfDeRegUntil <$> template)
|
||||
<*> areq termActiveField (fslI MsgCourseSemester) (cfTerm <$> template)
|
||||
<*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template)
|
||||
<*> aopt (natField "Kapazität") (fslI MsgCourseCapacity
|
||||
& setTooltip MsgCourseCapacityTip) (cfCapacity <$> template)
|
||||
<*> aopt textField (fslpI MsgCourseSecret "beliebige Zeichenkette"
|
||||
& setTooltip MsgCourseSecretTip) (cfSecret <$> template)
|
||||
<*> areq checkBoxField (fslI MsgMaterialFree) (cfMatFree <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgRegisterFrom "Datum"
|
||||
& setTooltip MsgCourseRegisterFromTip) (cfRegFrom <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgRegisterTo "Datum"
|
||||
& setTooltip MsgCourseRegisterToTip) (cfRegTo <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgDeRegUntil "Datum"
|
||||
& setTooltip MsgCourseDeregisterUntilTip) (cfDeRegUntil <$> template)
|
||||
<* submitButton
|
||||
return $ case result of
|
||||
FormSuccess courseResult
|
||||
|
||||
@ -38,23 +38,23 @@ instance CryptoRoute UUID SubmissionId where
|
||||
cryptoIDRoute _ (CryptoID -> cID) = do
|
||||
(smid :: SubmissionId) <- decrypt cID
|
||||
cID' <- encrypt smid
|
||||
(tid,csh,shn) <- runDB $ do
|
||||
(tid,ssh,csh,shn) <- runDB $ do
|
||||
shid <- submissionSheet <$> get404 smid
|
||||
Sheet{..} <- get404 shid
|
||||
Course{..} <- get404 sheetCourse
|
||||
return (courseTerm, courseShorthand, sheetName)
|
||||
return $ CSubmissionR tid csh shn cID' SubShowR
|
||||
return (courseTerm, courseSchool, courseShorthand, sheetName)
|
||||
return $ CSubmissionR tid ssh csh shn cID' SubShowR
|
||||
|
||||
instance CryptoRoute (CI FilePath) SubmissionId where
|
||||
cryptoIDRoute _ ciphertext
|
||||
| Just cID <- fromPathPiece . Text.pack $ CI.original ciphertext = do
|
||||
smid <- decrypt cID
|
||||
(tid,csh,shn) <- runDB $ do
|
||||
(tid,ssh,csh,shn) <- runDB $ do
|
||||
shid <- submissionSheet <$> get404 smid
|
||||
Sheet{..} <- get404 shid
|
||||
Course{..} <- get404 sheetCourse
|
||||
return (courseTerm, courseShorthand, sheetName)
|
||||
return $ CSubmissionR tid csh shn cID SubShowR
|
||||
return (courseTerm, courseSchool, courseShorthand, sheetName)
|
||||
return $ CSubmissionR tid ssh csh shn cID SubShowR
|
||||
| otherwise = notFound
|
||||
|
||||
instance CryptoRoute UUID UserId where
|
||||
|
||||
@ -22,12 +22,12 @@ import Data.Time hiding (formatTime)
|
||||
|
||||
-- import Web.PathPieces (showToPathPiece, readFromPathPiece)
|
||||
|
||||
import Control.Lens
|
||||
import Colonnade hiding (fromMaybe, singleton)
|
||||
-- import Control.Lens
|
||||
-- import Colonnade hiding (fromMaybe, singleton)
|
||||
-- import Yesod.Colonnade
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Text.Shakespeare.Text
|
||||
-- import Text.Shakespeare.Text
|
||||
|
||||
import Development.GitRev
|
||||
|
||||
@ -55,7 +55,6 @@ getHomeR = do
|
||||
homeAnonymous :: Handler Html
|
||||
homeAnonymous = do
|
||||
cTime <- liftIO getCurrentTime
|
||||
let fTime = addUTCTime (offCourseDeadlines * nominalDay) cTime
|
||||
let tableData :: E.SqlExpr (Entity Course)
|
||||
-> E.SqlQuery (E.SqlExpr (Entity Course))
|
||||
tableData course = do
|
||||
@ -68,12 +67,15 @@ homeAnonymous = do
|
||||
colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (HandlerT UniWorX IO) ())
|
||||
colonnade = mconcat
|
||||
[ -- dbRow
|
||||
sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do
|
||||
let tid = courseTerm course
|
||||
csh = courseShorthand course
|
||||
cell [whamlet|<a href=@{CourseR tid csh CShowR}>#{display csh}|]
|
||||
, sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
|
||||
sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
|
||||
textCell $ display $ courseTerm course
|
||||
, sortable (Just "school") (textCell MsgCourseSchool) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do
|
||||
textCell $ display $ courseSchool course
|
||||
, sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do
|
||||
let tid = courseTerm course
|
||||
ssh = courseSchool course
|
||||
csh = courseShorthand course
|
||||
anchorCell (CourseR tid ssh csh CShowR) (toWidget $ display csh)
|
||||
, sortable (Just "deadline") (textCell MsgRegisterTo) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
|
||||
cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget
|
||||
]
|
||||
@ -85,6 +87,9 @@ homeAnonymous = do
|
||||
[ ( "term"
|
||||
, SortColumn $ \(course) -> course E.^. CourseTerm
|
||||
)
|
||||
, ( "school"
|
||||
, SortColumn $ \(course) -> course E.^. CourseSchool
|
||||
)
|
||||
, ( "course"
|
||||
, SortColumn $ \(course) -> course E.^. CourseShorthand
|
||||
)
|
||||
@ -116,6 +121,7 @@ homeUser uid = do
|
||||
-- (E.SqlExpr (Entity Course )))
|
||||
-- (E.SqlExpr (Entity Sheet ))
|
||||
_ -> E.SqlQuery ( E.SqlExpr (E.Value (Key Term))
|
||||
, E.SqlExpr (E.Value SchoolId)
|
||||
, E.SqlExpr (E.Value CourseShorthand)
|
||||
, E.SqlExpr (E.Value SheetName)
|
||||
, E.SqlExpr (E.Value UTCTime)
|
||||
@ -132,6 +138,7 @@ homeUser uid = do
|
||||
-- E.limit nrSheetDeadlines -- arbitrary limits are not intuitive
|
||||
return
|
||||
( course E.^. CourseTerm
|
||||
, course E.^. CourseSchool
|
||||
, course E.^. CourseShorthand
|
||||
, sheet E.^. SheetName
|
||||
, sheet E.^. SheetActiveTo
|
||||
@ -139,6 +146,7 @@ homeUser uid = do
|
||||
)
|
||||
|
||||
colonnade :: Colonnade Sortable (DBRow ( E.Value (Key Term)
|
||||
, E.Value SchoolId
|
||||
, E.Value CourseShorthand
|
||||
, E.Value SheetName
|
||||
, E.Value UTCTime
|
||||
@ -147,30 +155,36 @@ homeUser uid = do
|
||||
(DBCell (HandlerT UniWorX IO) ())
|
||||
colonnade = mconcat
|
||||
[ -- dbRow
|
||||
sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, _, _, _) } ->
|
||||
anchorCell (CourseR tid csh CShowR) (toWidget $ display csh)
|
||||
, sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(E.Value tid, _,_,_,_) } ->
|
||||
-- TOOD: sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(view _1 -> E.Value tid) } ->
|
||||
sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(E.Value tid,_,_,_,_,_) } ->
|
||||
textCell $ display tid
|
||||
, sortable (Just "sheet") (textCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _, _) } ->
|
||||
anchorCell (CSheetR tid csh shn SShowR) (toWidget $ display shn)
|
||||
, sortable (Just "deadline") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, E.Value deadline, _) } ->
|
||||
, sortable (Just "school") (textCell MsgCourseSchool) $ \DBRow{ dbrOutput=(_,E.Value ssh,_,_,_,_) } ->
|
||||
textCell $ display ssh
|
||||
, sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, _, _, _) } ->
|
||||
anchorCell (CourseR tid ssh csh CShowR) (toWidget $ display csh)
|
||||
, sortable (Just "sheet") (textCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) } ->
|
||||
anchorCell (CSheetR tid ssh csh shn SShowR) (toWidget $ display shn)
|
||||
, sortable (Just "deadline") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } ->
|
||||
cell $ formatTime SelFormatDateTime deadline >>= toWidget
|
||||
, sortable (Just "done") (textCell MsgDone) $ \(DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _, E.Value mbsid) }) ->
|
||||
, sortable (Just "done") (textCell MsgDone) $ \(DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) }) ->
|
||||
case mbsid of
|
||||
Nothing -> mempty
|
||||
(Just sid) -> anchorCellM (CSubmissionR tid csh shn <$> encrypt sid <*> pure SubShowR)
|
||||
(Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR)
|
||||
tickmark
|
||||
]
|
||||
let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)]
|
||||
((), sheetTable) <- dbTable validator $ DBTable
|
||||
{ dbtSQLQuery = tableData
|
||||
, dbtColonnade = colonnade
|
||||
, dbtProj = \dbRow@DBRow{ dbrOutput = (E.Value tid, E.Value csh, E.Value shn, _, _) }
|
||||
-> dbRow <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid csh shn SShowR) False)
|
||||
, dbtProj = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) }
|
||||
-> row <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SShowR) False)
|
||||
, dbtSorting = Map.fromList
|
||||
[ ( "term"
|
||||
, SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseTerm
|
||||
)
|
||||
, ( "school"
|
||||
, SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseSchool
|
||||
)
|
||||
, ( "course"
|
||||
, SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseShorthand
|
||||
)
|
||||
|
||||
@ -99,7 +99,7 @@ getProfileR = do
|
||||
(E.select $ E.from $ \(lecturer `E.InnerJoin` course) -> do
|
||||
E.where_ $ lecturer ^. LecturerUser E.==. E.val uid
|
||||
E.on $ lecturer ^. LecturerCourse E.==. course ^. CourseId
|
||||
return (course ^. CourseShorthand, course ^. CourseTerm)
|
||||
return (course ^. CourseTerm, course ^.CourseSchool, course ^. CourseShorthand)
|
||||
)
|
||||
<*>
|
||||
(E.select $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
|
||||
@ -107,13 +107,13 @@ getProfileR = do
|
||||
E.on $ sheet ^. SheetId E.==. corrector ^. SheetCorrectorSheet
|
||||
E.where_ $ corrector ^. SheetCorrectorUser E.==. E.val uid
|
||||
|
||||
return (course ^. CourseShorthand, course ^. CourseTerm)
|
||||
return (course ^. CourseTerm, course ^. CourseSchool, course ^. CourseShorthand)
|
||||
)
|
||||
<*>
|
||||
(E.select $ E.from $ \(participant `E.InnerJoin` course) -> do
|
||||
E.where_ $ participant ^. CourseParticipantUser E.==. E.val uid
|
||||
E.on $ participant ^. CourseParticipantCourse E.==. course ^. CourseId
|
||||
return (course ^. CourseShorthand, course ^. CourseTerm, participant ^. CourseParticipantRegistration)
|
||||
return (course ^. CourseTerm, course ^. CourseSchool, course ^. CourseShorthand, participant ^. CourseParticipantRegistration)
|
||||
)
|
||||
<*>
|
||||
(E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
|
||||
@ -141,7 +141,7 @@ postProfileR = do
|
||||
|
||||
getProfileDataR :: Handler Html
|
||||
getProfileDataR = do
|
||||
(uid, User{..}) <- requireAuthPair
|
||||
(_uid, User{..}) <- requireAuthPair
|
||||
-- mr <- getMessageRender
|
||||
|
||||
defaultLayout $ do
|
||||
|
||||
@ -21,31 +21,31 @@ import Import
|
||||
import System.FilePath (takeFileName)
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Zip
|
||||
-- import Handler.Utils.Zip
|
||||
|
||||
-- import Data.Time
|
||||
import qualified Data.Text as T
|
||||
-- import qualified Data.Text as T
|
||||
-- import Data.Function ((&))
|
||||
--
|
||||
import Colonnade hiding (fromMaybe, singleton, bool)
|
||||
-- import Colonnade hiding (fromMaybe, singleton, bool)
|
||||
import qualified Yesod.Colonnade as Yesod
|
||||
import Text.Blaze (text)
|
||||
--
|
||||
import qualified Data.UUID.Cryptographic as UUID
|
||||
-- import qualified Data.UUID.Cryptographic as UUID
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
-- import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Internal.Sql as E
|
||||
-- import qualified Database.Esqueleto.Internal.Sql as E
|
||||
|
||||
import Control.Monad.Writer (MonadWriter(..), execWriterT)
|
||||
import Control.Monad.Trans.RWS.Lazy (RWST, local)
|
||||
-- import Control.Monad.Trans.RWS.Lazy (RWST, local)
|
||||
|
||||
import qualified Text.Email.Validate as Email
|
||||
-- import qualified Text.Email.Validate as Email
|
||||
|
||||
import qualified Data.List as List
|
||||
-- import qualified Data.List as List
|
||||
|
||||
import Network.Mime
|
||||
|
||||
@ -59,7 +59,7 @@ import qualified Data.Map as Map
|
||||
import Data.Monoid (Sum(..))
|
||||
|
||||
import Control.Lens
|
||||
import Utils.Lens
|
||||
-- import Utils.Lens
|
||||
|
||||
|
||||
instance Eq (Unique Sheet) where
|
||||
@ -146,24 +146,24 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
|
||||
, ( NTop sfSolutionFrom >= NTop (Just sfActiveTo) , render MsgSheetErrSolutionEarly)
|
||||
] ]
|
||||
|
||||
getSheetListR :: TermId -> CourseShorthand -> Handler Html
|
||||
getSheetListR tid csh = do
|
||||
getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getSheetListR tid ssh csh = do
|
||||
muid <- maybeAuthId
|
||||
Entity cid _ <- runDB . getBy404 $ CourseTermShort tid csh
|
||||
Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
let
|
||||
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
|
||||
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)
|
||||
sheetCol = widgetColonnade . mconcat $
|
||||
[ sortable (Just "name") (i18nCell MsgSheet)
|
||||
$ \(Entity _ Sheet{..}, _, _) -> anchorCell (CSheetR tid csh sheetName SShowR) (toWidget sheetName)
|
||||
$ \(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
|
||||
@ -180,9 +180,9 @@ getSheetListR tid csh = do
|
||||
(Just (Entity sid Submission{..})) ->
|
||||
let mkCid = encrypt sid -- TODO: executed twice
|
||||
mkRoute = do
|
||||
cid <- mkCid
|
||||
return $ CSubmissionR tid csh sheetName cid SubShowR
|
||||
in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|])
|
||||
cid' <- mkCid
|
||||
return $ CSubmissionR tid ssh csh sheetName cid' SubShowR
|
||||
in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{display cid2}|])
|
||||
, sortable (Just "rating") (i18nCell MsgRating)
|
||||
$ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of
|
||||
Nothing -> mempty
|
||||
@ -190,7 +190,7 @@ getSheetListR tid csh = do
|
||||
let mkCid = encrypt sid
|
||||
mkRoute = do
|
||||
cid <- mkCid
|
||||
return $ CSubmissionR tid csh sheetName cid CorrectionR
|
||||
return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
|
||||
protoCell = anchorCellM mkRoute $(widgetFile "widgets/rating")
|
||||
in protoCell & cellContents %~ (<* tell (sheetTypeSum (sheetType, submissionRatingPoints)))
|
||||
, sortable Nothing -- (Just "percent")
|
||||
@ -211,7 +211,7 @@ getSheetListR tid csh = do
|
||||
{ dbtSQLQuery = sheetData
|
||||
, dbtColonnade = sheetCol
|
||||
, dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _, _) }
|
||||
-> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid csh sheetName SShowR) False)
|
||||
-> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False)
|
||||
, dbtSorting = Map.fromList
|
||||
[ ( "name"
|
||||
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
|
||||
@ -246,9 +246,9 @@ getSheetListR tid csh = do
|
||||
$(widgetFile "widgets/sheetTypeSummary")
|
||||
|
||||
-- Show single sheet
|
||||
getSShowR :: TermId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSShowR tid csh shn = do
|
||||
entSheet <- runDB $ fetchSheet tid csh shn
|
||||
getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSShowR tid ssh csh shn = do
|
||||
entSheet <- runDB $ fetchSheet tid ssh csh shn
|
||||
let sheet = entityVal entSheet
|
||||
sid = entityKey entSheet
|
||||
-- without Colonnade
|
||||
@ -261,7 +261,7 @@ getSShowR tid csh shn = do
|
||||
-- E.where_ (sheet E.^. SheetId E.==. E.val sid )
|
||||
-- -- return desired columns
|
||||
-- return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
|
||||
-- let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid csh (SheetFileR shn fType fName),modified)) fileNameTypes
|
||||
-- let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid ssh csh (SheetFileR shn fType fName),modified)) fileNameTypes
|
||||
-- with Colonnade
|
||||
|
||||
let fileData (sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) = do
|
||||
@ -275,7 +275,7 @@ getSShowR tid csh shn = do
|
||||
return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
|
||||
let colonnadeFiles = widgetColonnade $ mconcat
|
||||
[ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> stringCell ftype
|
||||
, sortable (Just "path") "Dateiname" $ anchorCell' (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh shn (SFileR fType fName))
|
||||
, sortable (Just "path") "Dateiname" $ anchorCell' (\(E.Value fName,_,E.Value fType) -> CSheetR tid ssh csh shn (SFileR fType fName))
|
||||
(\(E.Value fName,_,_) -> str2widget fName)
|
||||
, sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget
|
||||
]
|
||||
@ -285,7 +285,7 @@ getSShowR tid csh shn = do
|
||||
{ dbtSQLQuery = fileData
|
||||
, dbtColonnade = colonnadeFiles
|
||||
, dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }
|
||||
-> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid csh shn $ SFileR fType fName) False)
|
||||
-> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn $ SFileR fType fName) False)
|
||||
, dbtStyle = def
|
||||
, dbtFilter = Map.empty
|
||||
, dbtIdent = "files" :: Text
|
||||
@ -309,19 +309,19 @@ getSShowR tid csh shn = do
|
||||
when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI "warning" $
|
||||
maybe MsgSheetInvisible MsgSheetInvisibleUntil visibleFrom
|
||||
defaultLayout $ do
|
||||
setTitleI $ MsgSheetTitle tid csh shn
|
||||
setTitleI $ MsgSheetTitle tid ssh csh shn
|
||||
sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet
|
||||
sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet
|
||||
hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet
|
||||
solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet
|
||||
$(widgetFile "sheetShow")
|
||||
|
||||
getSFileR :: TermId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent
|
||||
getSFileR tid csh shn typ title = do
|
||||
getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent
|
||||
getSFileR tid ssh csh shn typ title = do
|
||||
results <- runDB $ E.select $ E.from $
|
||||
\(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
|
||||
-- Restrict to consistent rows that correspond to each other
|
||||
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile)
|
||||
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile)
|
||||
E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
|
||||
E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId)
|
||||
-- filter to requested file
|
||||
@ -329,7 +329,8 @@ getSFileR tid csh shn typ title = do
|
||||
E.&&. (sheetFile E.^. SheetFileType E.==. E.val typ )
|
||||
E.&&. (sheet E.^. SheetName E.==. E.val shn )
|
||||
E.&&. (course E.^. CourseShorthand E.==. E.val csh )
|
||||
E.&&. (course E.^. CourseTerm E.==. E.val tid )
|
||||
E.&&. (course E.^. CourseSchool E.==. E.val ssh )
|
||||
E.&&. (course E.^. CourseTerm E.==. E.val tid )
|
||||
)
|
||||
-- return desired columns
|
||||
return $ (file E.^. FileTitle, file E.^. FileContent)
|
||||
@ -346,21 +347,21 @@ getSFileR tid csh shn typ title = do
|
||||
$logErrorS "SFileR" $ "Multiple matching files: " <> tshow other
|
||||
error "Multiple matching files found."
|
||||
|
||||
getSheetNewR :: TermId -> CourseShorthand -> Handler Html
|
||||
getSheetNewR tid csh = do
|
||||
getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getSheetNewR tid ssh csh = do
|
||||
let template = Nothing -- TODO: provide convenience by interpolating name/nr/dates+7days
|
||||
let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing
|
||||
insertUnique $ newSheet
|
||||
handleSheetEdit tid csh Nothing template action
|
||||
handleSheetEdit tid ssh csh Nothing template action
|
||||
|
||||
postSheetNewR :: TermId -> CourseShorthand -> Handler Html
|
||||
postSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
postSheetNewR = getSheetNewR
|
||||
|
||||
|
||||
getSEditR :: TermId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSEditR tid csh shn = do
|
||||
getSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSEditR tid ssh csh shn = do
|
||||
(sheetEnt, sheetFileIds) <- runDB $ do
|
||||
ent <- fetchSheet tid csh shn
|
||||
ent <- fetchSheet tid ssh csh shn
|
||||
fti <- getFtIdMap $ entityKey ent
|
||||
return (ent, fti)
|
||||
let sid = entityKey sheetEnt
|
||||
@ -386,13 +387,13 @@ getSEditR tid csh shn = do
|
||||
case replaceRes of
|
||||
Nothing -> return $ Just sid
|
||||
(Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here
|
||||
handleSheetEdit tid csh (Just sid) template action
|
||||
handleSheetEdit tid ssh csh (Just sid) template action
|
||||
|
||||
postSEditR :: TermId -> CourseShorthand -> SheetName -> Handler Html
|
||||
postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
postSEditR = getSEditR
|
||||
|
||||
handleSheetEdit :: TermId -> CourseShorthand -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html
|
||||
handleSheetEdit tid csh msId template dbAction = do
|
||||
handleSheetEdit :: TermId -> SchoolId -> CourseShorthand -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html
|
||||
handleSheetEdit tid ssh csh msId template dbAction = do
|
||||
let mbshn = sfName <$> template
|
||||
aid <- requireAuthId
|
||||
((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm msId template
|
||||
@ -400,7 +401,7 @@ handleSheetEdit tid csh msId template dbAction = do
|
||||
(FormSuccess SheetForm{..}) -> do
|
||||
saveOkay <- runDB $ do
|
||||
actTime <- liftIO getCurrentTime
|
||||
cid <- getKeyBy404 $ CourseTermShort tid csh
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
let newSheet = Sheet
|
||||
{ sheetCourse = cid
|
||||
, sheetName = sfName
|
||||
@ -416,51 +417,51 @@ handleSheetEdit tid csh msId template dbAction = do
|
||||
}
|
||||
mbsid <- dbAction newSheet
|
||||
case mbsid of
|
||||
Nothing -> False <$ addMessageI "danger" (MsgSheetNameDup tid csh sfName)
|
||||
Nothing -> False <$ addMessageI "danger" (MsgSheetNameDup tid ssh csh sfName)
|
||||
(Just sid) -> do -- save files in DB:
|
||||
whenIsJust sfSheetF $ insertSheetFile' sid SheetExercise
|
||||
whenIsJust sfHintF $ insertSheetFile' sid SheetHint
|
||||
whenIsJust sfSolutionF $ insertSheetFile' sid SheetSolution
|
||||
whenIsJust sfMarkingF $ insertSheetFile' sid SheetMarking
|
||||
insert_ $ SheetEdit aid actTime sid
|
||||
addMessageI "info" $ MsgSheetEditOk tid csh sfName
|
||||
addMessageI "info" $ MsgSheetEditOk tid ssh csh sfName
|
||||
return True
|
||||
when saveOkay $ redirect $ CSheetR tid csh sfName SShowR -- redirect must happen outside of runDB
|
||||
when saveOkay $ redirect $ CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB
|
||||
(FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
|
||||
_ -> return ()
|
||||
let pageTitle = maybe (MsgSheetTitleNew tid csh)
|
||||
(MsgSheetTitle tid csh) mbshn
|
||||
let pageTitle = maybe (MsgSheetTitleNew tid ssh csh)
|
||||
(MsgSheetTitle tid ssh csh) mbshn
|
||||
-- let formTitle = pageTitle -- no longer used in template
|
||||
let formText = Nothing :: Maybe UniWorXMessage
|
||||
actionUrl <- fromMaybe (CourseR tid csh SheetNewR) <$> getCurrentRoute
|
||||
actionUrl <- fromMaybe (CourseR tid ssh csh SheetNewR) <$> getCurrentRoute
|
||||
defaultLayout $ do
|
||||
setTitleI pageTitle
|
||||
$(widgetFile "formPageI18n")
|
||||
|
||||
|
||||
|
||||
getSDelR :: TermId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSDelR tid csh shn = do
|
||||
getSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSDelR tid ssh csh shn = do
|
||||
((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete)
|
||||
case result of
|
||||
(FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid csh shn SShowR
|
||||
(FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid ssh csh shn SShowR
|
||||
(FormSuccess BtnDelete) -> do
|
||||
runDB $ fetchSheetId tid csh shn >>= deleteCascade
|
||||
runDB $ fetchSheetId tid ssh csh shn >>= deleteCascade
|
||||
-- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!!
|
||||
addMessageI "info" $ MsgSheetDelOk tid csh shn
|
||||
redirect $ CourseR tid csh SheetListR
|
||||
addMessageI "info" $ MsgSheetDelOk tid ssh csh shn
|
||||
redirect $ CourseR tid ssh csh SheetListR
|
||||
_other -> do
|
||||
submissionno <- runDB $ do
|
||||
sid <- fetchSheetId tid csh shn
|
||||
sid <- fetchSheetId tid ssh csh shn
|
||||
count [SubmissionSheet ==. sid]
|
||||
let formTitle = MsgSheetDelHead tid csh shn
|
||||
let formTitle = MsgSheetDelHead tid ssh csh shn
|
||||
let formText = Just $ MsgSheetDelText submissionno
|
||||
let actionUrl = CSheetR tid csh shn SDelR
|
||||
let actionUrl = CSheetR tid ssh csh shn SDelR
|
||||
defaultLayout $ do
|
||||
setTitleI $ MsgSheetTitle tid csh shn
|
||||
setTitleI $ MsgSheetTitle tid ssh csh shn
|
||||
$(widgetFile "formPageI18n")
|
||||
|
||||
postSDelR :: TermId -> CourseShorthand -> SheetName -> Handler Html
|
||||
postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
postSDelR = getSDelR
|
||||
|
||||
|
||||
@ -661,10 +662,10 @@ correctorForm shid = do
|
||||
-- Eingabebox für Korrektor hinzufügen
|
||||
-- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
|
||||
|
||||
getSCorrR, postSCorrR :: TermId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSCorrR, postSCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
postSCorrR = getSCorrR
|
||||
getSCorrR tid csh shn = do
|
||||
Entity shid Sheet{..} <- runDB $ fetchSheet tid csh shn
|
||||
getSCorrR tid ssh csh shn = do
|
||||
Entity shid Sheet{..} <- runDB $ fetchSheet tid ssh csh shn
|
||||
|
||||
((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
|
||||
|
||||
@ -677,10 +678,10 @@ getSCorrR tid csh shn = do
|
||||
FormMissing -> return ()
|
||||
|
||||
let
|
||||
-- formTitle = MsgSheetCorrectorsTitle tid csh shn
|
||||
-- formTitle = MsgSheetCorrectorsTitle tid ssh csh shn
|
||||
formText = Nothing :: Maybe (SomeMessage UniWorX)
|
||||
actionUrl = CSheetR tid csh shn SCorrR
|
||||
-- actionUrl = CSheetR tid csh shn SShowR
|
||||
actionUrl = CSheetR tid ssh csh shn SCorrR
|
||||
-- actionUrl = CSheetR tid ssh csh shn SShowR
|
||||
defaultLayout $ do
|
||||
setTitleI $ MsgSheetCorrectorsTitle tid csh shn
|
||||
setTitleI $ MsgSheetCorrectorsTitle tid ssh csh shn
|
||||
$(widgetFile "formPageI18n")
|
||||
|
||||
@ -78,20 +78,20 @@ makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $
|
||||
aforced' f fs (Just (Just v)) = Just <$> aforced f fs v
|
||||
aforced' _ _ _ = error "Cannot happen since groupNr==0 if grouping/=Arbitrary"
|
||||
|
||||
getSubmissionNewR, postSubmissionNewR :: TermId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSubmissionNewR, postSubmissionNewR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSubmissionNewR = postSubmissionNewR
|
||||
postSubmissionNewR tid csh shn = submissionHelper tid csh shn NewSubmission
|
||||
postSubmissionNewR tid ssh csh shn = submissionHelper tid ssh csh shn NewSubmission
|
||||
|
||||
|
||||
getSubShowR, postSubShowR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
|
||||
getSubShowR, postSubShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
|
||||
getSubShowR = postSubShowR
|
||||
postSubShowR tid csh shn cid = submissionHelper tid csh shn $ ExistingSubmission cid
|
||||
postSubShowR tid ssh csh shn cid = submissionHelper tid ssh csh shn $ ExistingSubmission cid
|
||||
|
||||
getSubmissionOwnR :: TermId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSubmissionOwnR tid csh shn = do
|
||||
getSubmissionOwnR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSubmissionOwnR tid ssh csh shn = do
|
||||
authId <- requireAuthId
|
||||
sid <- runDB $ do
|
||||
shid <- fetchSheetId tid csh shn
|
||||
shid <- fetchSheetId tid ssh csh shn
|
||||
submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
|
||||
E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission)
|
||||
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val authId
|
||||
@ -101,14 +101,14 @@ getSubmissionOwnR tid csh shn = do
|
||||
((E.Value sid):_) -> return sid
|
||||
[] -> notFound
|
||||
cID <- encrypt sid
|
||||
redirect $ CSubmissionR tid csh shn cID SubShowR
|
||||
redirect $ CSubmissionR tid ssh csh shn cID SubShowR
|
||||
|
||||
submissionHelper :: TermId -> CourseShorthand -> SheetName -> SubmissionMode -> Handler Html
|
||||
submissionHelper tid csh shn (SubmissionMode mcid) = do
|
||||
submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SubmissionMode -> Handler Html
|
||||
submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
|
||||
uid <- requireAuthId
|
||||
msmid <- traverse decrypt mcid
|
||||
(Entity shid Sheet{..}, buddies, lastEdits) <- runDB $ do
|
||||
sheet@(Entity shid Sheet{..}) <- fetchSheet tid csh shn
|
||||
sheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn
|
||||
case msmid of
|
||||
Nothing -> do
|
||||
submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
|
||||
@ -139,9 +139,9 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
|
||||
(E.Value smid:_) -> do
|
||||
cID <- encrypt smid
|
||||
addMessageI "info" $ MsgSubmissionAlreadyExists
|
||||
redirect $ CSubmissionR tid csh shn cID SubShowR
|
||||
redirect $ CSubmissionR tid ssh csh shn cID SubShowR
|
||||
(Just smid) -> do
|
||||
void $ submissionMatchesSheet tid csh shn (fromJust mcid)
|
||||
void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid)
|
||||
|
||||
shid' <- submissionSheet <$> get404 smid
|
||||
-- fetch buddies from current submission
|
||||
@ -239,7 +239,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
|
||||
_other -> return Nothing
|
||||
|
||||
case mCID of
|
||||
Just cID -> redirect $ CSubmissionR tid csh shn cID SubShowR
|
||||
Just cID -> redirect $ CSubmissionR tid ssh csh shn cID SubShowR
|
||||
Nothing -> return ()
|
||||
|
||||
actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
|
||||
@ -254,13 +254,13 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
|
||||
corrIsFile = fmap (isJust . fileContent . entityVal . snd) mCorr
|
||||
Just isFile = origIsFile <|> corrIsFile
|
||||
in if
|
||||
| Just True <- origIsFile -> anchorCell (CSubmissionR tid csh shn cid $ SubDownloadR SubmissionOriginal fileTitle')
|
||||
| Just True <- origIsFile -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionOriginal fileTitle')
|
||||
([whamlet|#{fileTitle'}|])
|
||||
| otherwise -> textCell $ bool (<> "/") id isFile fileTitle'
|
||||
, sortable Nothing (cell mempty) $ \(coalesce -> (_, mCorr)) -> case mCorr of
|
||||
Nothing -> cell mempty
|
||||
Just (_, Entity _ File{..})
|
||||
| isJust fileContent -> anchorCell (CSubmissionR tid csh shn cid $ SubDownloadR SubmissionCorrected fileTitle)
|
||||
| isJust fileContent -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionCorrected fileTitle)
|
||||
([whamlet|_{MsgFileCorrected}|])
|
||||
| otherwise -> textCell MsgFileCorrected
|
||||
, sortable (Just "time") (textCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let
|
||||
@ -302,19 +302,19 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
|
||||
mFileTable <- traverse (fmap snd . dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
|
||||
|
||||
defaultLayout $ do
|
||||
setTitleI $ MsgSubmissionEditHead tid csh shn
|
||||
setTitleI $ MsgSubmissionEditHead tid ssh csh shn
|
||||
$(widgetFile "submission")
|
||||
|
||||
|
||||
getSubDownloadR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent
|
||||
getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do
|
||||
getSubDownloadR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent
|
||||
getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do
|
||||
runDB $ do
|
||||
submissionID <- submissionMatchesSheet tid csh shn cID
|
||||
submissionID <- submissionMatchesSheet tid ssh csh shn cID
|
||||
|
||||
isRating <- maybe False (== submissionID) <$> isRatingFile path
|
||||
|
||||
when (isUpdate || isRating) $
|
||||
guardAuthResult =<< evalAccessDB (CSubmissionR tid csh shn cID CorrectionR) False
|
||||
guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False
|
||||
|
||||
case isRating of
|
||||
True
|
||||
@ -343,10 +343,10 @@ getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path =
|
||||
$logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other
|
||||
error "Multiple matching files found."
|
||||
|
||||
getSubArchiveR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent
|
||||
getSubArchiveR tid csh shn cID (ZIPArchiveName sfType) = do
|
||||
getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent
|
||||
getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do
|
||||
when (sfType == SubmissionCorrected) $
|
||||
guardAuthResult =<< evalAccess (CSubmissionR tid csh shn cID CorrectionR) False
|
||||
guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False
|
||||
|
||||
let filename
|
||||
| SubmissionOriginal <- sfType = ZIPArchiveName $ toPathPiece cID <> "-" <> toPathPiece sfType
|
||||
@ -354,7 +354,7 @@ getSubArchiveR tid csh shn cID (ZIPArchiveName sfType) = do
|
||||
|
||||
addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|]
|
||||
respondSourceDB "application/zip" $ do
|
||||
submissionID <- lift $ submissionMatchesSheet tid csh shn cID
|
||||
submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID
|
||||
rating <- lift $ getRating submissionID
|
||||
|
||||
let
|
||||
|
||||
@ -17,8 +17,7 @@ import Handler.Utils
|
||||
|
||||
-- import qualified Data.Text as T
|
||||
import Yesod.Form.Bootstrap3
|
||||
|
||||
import Colonnade hiding (bool)
|
||||
-- import Colonnade hiding (bool)
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
|
||||
@ -219,7 +219,15 @@ pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..}
|
||||
return . fromRational $ round (sci * 100) % 100
|
||||
|
||||
--termField: see Utils.Term
|
||||
--schoolField: see Handler.Course
|
||||
|
||||
schoolField :: Field Handler SchoolId
|
||||
schoolField = selectField $ optionsPersistKey [] [Asc SchoolName] schoolName
|
||||
|
||||
schoolFieldEnt :: Field Handler (Entity School)
|
||||
schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName
|
||||
|
||||
schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
|
||||
schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolId <-. userSchools] [Asc SchoolName] schoolName
|
||||
|
||||
zipFileField :: Bool -- ^ Unpack zips?
|
||||
-> Field Handler (Source Handler File)
|
||||
|
||||
@ -24,29 +24,30 @@ fetchSheetAux :: ( BaseBackend backend ~ SqlBackend
|
||||
, PersistQueryRead backend, PersistUniqueRead backend
|
||||
)
|
||||
=> (E.SqlExpr (Entity Sheet) -> b)
|
||||
-> TermId -> CourseShorthand -> SheetName -> ReaderT backend m a
|
||||
fetchSheetAux prj tid csh shn =
|
||||
let cachId = encodeUtf8 $ tshow (tid,csh,shn)
|
||||
-> TermId -> SchoolId -> CourseShorthand -> SheetName -> ReaderT backend m a
|
||||
fetchSheetAux prj tid ssh csh shn =
|
||||
let cachId = encodeUtf8 $ tshow (tid,ssh,csh,shn)
|
||||
in cachedBy cachId $ do
|
||||
-- Mit Yesod:
|
||||
-- cid <- getKeyBy404 $ CourseTermShort tid csh
|
||||
-- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
-- getBy404 $ CourseSheet cid shn
|
||||
-- Mit Esqueleto:
|
||||
sheetList <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
E.&&. sheet E.^. SheetName E.==. E.val shn
|
||||
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.&&. sheet E.^. SheetName E.==. E.val shn
|
||||
return $ prj sheet
|
||||
case sheetList of
|
||||
[sheet] -> return sheet
|
||||
_other -> notFound
|
||||
|
||||
fetchSheet :: TermId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Entity Sheet)
|
||||
fetchSheet :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Entity Sheet)
|
||||
fetchSheet = fetchSheetAux id
|
||||
|
||||
fetchSheetId :: TermId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet)
|
||||
fetchSheetId tid cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid cid shn
|
||||
fetchSheetId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet)
|
||||
fetchSheetId tid ssh cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid ssh cid shn
|
||||
|
||||
fetchSheetIdCourseId :: TermId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet, Key Course)
|
||||
fetchSheetIdCourseId tid cid shn = bimap E.unValue E.unValue <$> fetchSheetAux ((,) <$> (E.^. SheetId) <*> (E.^. SheetCourse)) tid cid shn
|
||||
fetchSheetIdCourseId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet, Key Course)
|
||||
fetchSheetIdCourseId tid ssh cid shn = bimap E.unValue E.unValue <$> fetchSheetAux ((,) <$> (E.^. SheetId) <*> (E.^. SheetCourse)) tid ssh cid shn
|
||||
|
||||
@ -551,7 +551,7 @@ sinkMultiSubmission userId isUpdate = do
|
||||
Submission{..} <- get404 sId
|
||||
Sheet{..} <- get404 submissionSheet
|
||||
Course{..} <- get404 sheetCourse
|
||||
guardAuthResult =<< evalAccessDB (CSubmissionR courseTerm courseShorthand sheetName cID CorrectionR) True
|
||||
guardAuthResult =<< evalAccessDB (CSubmissionR courseTerm courseSchool courseShorthand sheetName cID CorrectionR) True
|
||||
return . newResumableSink $ sinkSubmission userId (Right sId) isUpdate
|
||||
sink' <- lift $ yield val ++$$ sink
|
||||
case sink' of
|
||||
@ -599,10 +599,10 @@ sinkMultiSubmission userId isUpdate = do
|
||||
handleCryptoID _ = return Nothing
|
||||
|
||||
|
||||
submissionMatchesSheet :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> DB SubmissionId
|
||||
submissionMatchesSheet tid csh shn cid = do
|
||||
submissionMatchesSheet :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> DB SubmissionId
|
||||
submissionMatchesSheet tid ssh csh shn cid = do
|
||||
sid <- decrypt cid
|
||||
shid <- fetchSheetId tid csh shn
|
||||
shid <- fetchSheetId tid ssh csh shn
|
||||
Submission{..} <- get404 sid
|
||||
when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
|
||||
return sid
|
||||
|
||||
@ -17,12 +17,13 @@ import Model.Migration.Version
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Data.Set (Set)
|
||||
import Data.Set ()
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Database.Persist.Sql
|
||||
import Database.Persist.Postgresql
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
|
||||
-- Database versions must follow https://pvp.haskell.org:
|
||||
-- - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format)
|
||||
@ -67,13 +68,21 @@ migrateAll = do
|
||||
doCustomMigration acc desc migration = acc <* do
|
||||
let AppliedMigrationKey appliedMigrationFrom appliedMigrationTo = desc
|
||||
appliedMigrationTime <- liftIO getCurrentTime
|
||||
migration
|
||||
_ <- migration
|
||||
insert AppliedMigration{..}
|
||||
-- Map.foldlWithKey traverses migrations in ascending order of AppliedMigrationKey
|
||||
Map.foldlWithKey doCustomMigration (return ()) missingMigrations
|
||||
|
||||
runMigration migrateAll'
|
||||
|
||||
{-
|
||||
Confusion about quotes, from the PostgreSQL Manual:
|
||||
Single quotes for string constants, double quotes for table/column names.
|
||||
|
||||
QuasiQuoter: ^{TableName} @{ColumnName} (includes Escaping);
|
||||
#{anything} (no escaping);
|
||||
-}
|
||||
|
||||
|
||||
customMigrations :: MonadIO m => Map (Key AppliedMigration) (ReaderT SqlBackend m ())
|
||||
customMigrations = Map.fromListWith (>>)
|
||||
@ -92,6 +101,7 @@ customMigrations = Map.fromListWith (>>)
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|0.0.0|] [version|1.0.0|]
|
||||
, do -- Better JSON encoding
|
||||
|
||||
haveSheetTable <- [sqlQQ| SELECT to_regclass('sheet'); |]
|
||||
|
||||
case haveSheetTable :: [Maybe (Single Text)] of
|
||||
@ -102,4 +112,63 @@ customMigrations = Map.fromListWith (>>)
|
||||
|]
|
||||
_other -> return ()
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|1.0.0|] [version|2.0.0|]
|
||||
, whenM (tableExists "school") $ do -- SchoolId is the Shorthand CI Text now
|
||||
-- Read old table into memory
|
||||
schoolTable <- [sqlQQ| SELECT "id", "shorthand" FROM "school"; |]
|
||||
let _sT = schoolTable :: [(Single Int64, Single (CI Text))] -- Types needed
|
||||
-- Convert columns containing SchoolId
|
||||
whenM (tableExists "user_admin") $ do
|
||||
[executeQQ|
|
||||
ALTER TABLE "user_admin" DROP CONSTRAINT user_admin_school_fkey;
|
||||
ALTER TABLE "user_admin" ALTER COLUMN school TYPE citext USING school::citext;
|
||||
|]
|
||||
forM_ schoolTable $ \(Single idnr, Single ssh) ->
|
||||
[executeQQ|
|
||||
UPDATE "user_admin" SET "school" = #{ssh} WHERE school = #{tshow idnr};
|
||||
|]
|
||||
[executeQQ|
|
||||
ALTER TABLE "user_admin" ADD CONSTRAINT "user_admin_school_fkey"
|
||||
FOREIGN KEY (school) REFERENCES school(shorthand);
|
||||
|]
|
||||
whenM (tableExists "user_lecturer") $ do
|
||||
[executeQQ|
|
||||
ALTER TABLE "user_lecturer" DROP CONSTRAINT user_lecturer_school_fkey;
|
||||
ALTER TABLE "user_lecturer" ALTER COLUMN school TYPE citext USING school::citext;
|
||||
|]
|
||||
forM_ schoolTable $ \(Single idnr, Single ssh) ->
|
||||
[executeQQ|
|
||||
UPDATE "user_lecturer" SET "school" = #{ssh} WHERE school = #{tshow idnr};
|
||||
|]
|
||||
[executeQQ|
|
||||
ALTER TABLE "user_lecturer" ADD CONSTRAINT "user_lecturer_school_fkey"
|
||||
FOREIGN KEY (school) REFERENCES school(shorthand);;
|
||||
|]
|
||||
whenM (tableExists "course") $ do
|
||||
[executeQQ|
|
||||
ALTER TABLE "course" DROP CONSTRAINT course_school_fkey;
|
||||
ALTER TABLE "course" ALTER COLUMN school TYPE citext USING school::citext;
|
||||
|]
|
||||
forM_ schoolTable $ \(Single idnr, Single ssh) ->
|
||||
[executeQQ|
|
||||
UPDATE "course" SET "school" = #{ssh} WHERE school = #{tshow idnr};
|
||||
|]
|
||||
[executeQQ|
|
||||
ALTER TABLE "course" ADD CONSTRAINT "course_school_fkey"
|
||||
FOREIGN KEY (school) REFERENCES school(shorthand);
|
||||
|]
|
||||
[executeQQ|
|
||||
ALTER TABLE "school" DROP COLUMN "id";
|
||||
ALTER TABLE "school" ADD PRIMARY KEY (shorthand);
|
||||
|]
|
||||
)
|
||||
]
|
||||
|
||||
|
||||
|
||||
tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool
|
||||
tableExists table = do
|
||||
haveSchoolTable <- [sqlQQ| SELECT to_regclass(#{table}); |]
|
||||
case haveSchoolTable :: [Maybe (Single Text)] of
|
||||
[Just _] -> return True
|
||||
_other -> return False
|
||||
|
||||
@ -8,6 +8,7 @@
|
||||
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-- # LANGUAGE ExistentialQuantification #-} -- for DA type
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
|
||||
|
||||
module Model.Types where
|
||||
|
||||
@ -23,6 +24,7 @@ import Data.Monoid (Sum(..))
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Universe
|
||||
import Data.Universe.Helpers
|
||||
import Data.UUID.Types
|
||||
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
@ -32,6 +34,7 @@ import Database.Persist.Class
|
||||
import Database.Persist.Sql
|
||||
|
||||
import Web.HttpApiData
|
||||
import Web.PathPieces
|
||||
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
@ -50,6 +53,30 @@ import Generics.Deriving.Monoid (gmemptydefault, gmappenddefault)
|
||||
import Data.Typeable (Typeable)
|
||||
|
||||
|
||||
instance PathPiece UUID where
|
||||
fromPathPiece = Data.UUID.Types.fromString . unpack
|
||||
toPathPiece = pack . toString
|
||||
|
||||
instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where
|
||||
fromPathPiece = fmap CI.mk . fromPathPiece
|
||||
toPathPiece = toPathPiece . CI.original
|
||||
|
||||
instance {-# OVERLAPS #-} PathMultiPiece FilePath where
|
||||
fromPathMultiPiece = Just . unpack . intercalate "/"
|
||||
toPathMultiPiece = Text.splitOn "/" . pack
|
||||
|
||||
instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where
|
||||
fromPathMultiPiece = fmap CI.mk . fromPathMultiPiece
|
||||
toPathMultiPiece = toPathMultiPiece . CI.foldedCase
|
||||
|
||||
instance ToHttpApiData (CI Text) where
|
||||
toUrlPiece = CI.original
|
||||
|
||||
instance FromHttpApiData (CI Text) where
|
||||
parseUrlPiece = return . CI.mk
|
||||
|
||||
|
||||
|
||||
type Points = Centi
|
||||
|
||||
toPoints :: Integral a => a -> Points -- deprecated
|
||||
@ -368,7 +395,9 @@ derivePersistField "CorrectorState"
|
||||
|
||||
-- Type synonyms
|
||||
|
||||
type SheetName = CI Text
|
||||
type SchoolName = CI Text
|
||||
type SchoolShorthand = CI Text
|
||||
type CourseName = CI Text
|
||||
type CourseShorthand = CI Text
|
||||
type CourseName = CI Text
|
||||
type UserEmail = CI Text
|
||||
type SheetName = CI Text
|
||||
type UserEmail = CI Text
|
||||
|
||||
@ -86,6 +86,11 @@ unsupportedAuthPredicate = do
|
||||
|
||||
tickmark :: IsString a => a
|
||||
tickmark = fromString "✔"
|
||||
-- Avoid annoying warnings:
|
||||
tickmarkS :: String
|
||||
tickmarkS = tickmark
|
||||
tickmarkT :: Text
|
||||
tickmarkT = tickmark
|
||||
|
||||
text2Html :: Text -> Html
|
||||
text2Html = toHtml -- prevents ambiguous types
|
||||
|
||||
@ -33,7 +33,7 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
|
||||
<dt .deflist__dt>
|
||||
<dd .deflist__dd>
|
||||
<div .course__registration>
|
||||
<form method=post action=@{CourseR tid csh CRegisterR} enctype=#{regEnctype}>
|
||||
<form method=post action=@{CourseR tid ssh csh CRegisterR} enctype=#{regEnctype}>
|
||||
$# regWidget is defined through templates/widgets/registerForm
|
||||
^{regWidget}
|
||||
<dt .deflist__dt>
|
||||
|
||||
@ -27,16 +27,16 @@
|
||||
<dt .deflist__dt> Eigene Kurse
|
||||
<dd .deflist__dd>
|
||||
<ul .list-ul>
|
||||
$forall (E.Value csh, E.Value tid) <- lecture_owner
|
||||
$forall (E.Value tid, E.Value ssh, E.Value csh) <- lecture_owner
|
||||
<li .list-ul__item>
|
||||
<a href=@{CourseR tid csh CShowR}>#{display tid} - #{csh}
|
||||
<a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
|
||||
$if not $ null lecture_corrector
|
||||
<dt .deflist__dt> Korrektor
|
||||
<dd .deflist__dd>
|
||||
<ul .list-ul>
|
||||
$forall (E.Value csh, E.Value tid) <- lecture_corrector
|
||||
$forall (E.Value tid, E.Value ssh, E.Value csh) <- lecture_corrector
|
||||
<li .list-ul__item>
|
||||
<a href=@{CourseR tid csh CShowR}>#{display tid} - #{csh}
|
||||
<a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
|
||||
$if not $ null studies
|
||||
<dt .deflist__dt> Studiengänge
|
||||
<dd .deflist__dd>
|
||||
@ -59,10 +59,10 @@
|
||||
<dt .deflist__dt> Teilnehmer
|
||||
<dd .deflist__dd>
|
||||
<dl .deflist>
|
||||
$forall (E.Value csh, E.Value tid, regSince) <- participant
|
||||
$forall (E.Value tid, E.Value ssh, E.Value csh, regSince) <- participant
|
||||
<dt .deflist__dt>
|
||||
<a href=@{CourseR tid csh CShowR}>#{display tid} - #{csh}
|
||||
<a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
|
||||
<dd .deflist__dd>
|
||||
seit #{display regSince}
|
||||
seit #{display regSince}
|
||||
|
||||
^{settingsForm}
|
||||
|
||||
@ -1,8 +1,8 @@
|
||||
$maybe cID <- mcid
|
||||
<section>
|
||||
<h2>
|
||||
<a href=@{CSubmissionR tid csh shn cID (SubArchiveR (ZIPArchiveName SubmissionCorrected))}>Archiv
|
||||
(<a href=@{CSubmissionR tid csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal))}>Original</a>)
|
||||
<a href=@{CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionCorrected))}>Archiv
|
||||
(<a href=@{CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal))}>Original</a>)
|
||||
$if not (null lastEdits)
|
||||
<h3>_{MsgLastEdits}
|
||||
<ul>
|
||||
|
||||
@ -13,4 +13,4 @@ $maybe points <- submissionRatingPoints
|
||||
$else
|
||||
_{MsgNotPassed}
|
||||
$of NotGraded
|
||||
#{show tickmark}
|
||||
#{display tickmarkS}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user