feat(allocations): set up routes
This commit is contained in:
Gregor Kleen
parent
7b9ccf4ad9
commit
c2df01c2f7
@ -345,6 +345,7 @@ UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut e
|
||||
UnauthorizedAdminEscalation: Sie sind nicht Administrator für alle Institute, für die dieser Nutzer Administrator oder Veranstalter ist.
|
||||
UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen.
|
||||
UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen.
|
||||
UnauthorizedAllocationLecturer: Sie sind nicht als Veranstalter für eine Veranstaltung dieser Zentralanmeldung eingetragen.
|
||||
UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung eingetragen.
|
||||
UnauthorizedSheetCorrector: Sie sind nicht als Korrektor für dieses Übungsblatt eingetragen.
|
||||
UnauthorizedCorrectorAny: Sie sind nicht als Korrektor für eine Veranstaltung eingetragen.
|
||||
@ -352,6 +353,7 @@ UnauthorizedRegistered: Sie sind nicht als Teilnehmer für diese Veranstaltung r
|
||||
UnauthorizedExamResult: Sie haben keine Ergebnisse in dieser Prüfung.
|
||||
UnauthorizedParticipant: Angegebener Benutzer ist nicht als Teilnehmer dieser Veranstaltung registriert.
|
||||
UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen.
|
||||
UnauthorizedAllocationRegisterTime: Diese Zentralanmeldung erlaubt momentan keine Bewerbungen.
|
||||
UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben.
|
||||
UnauthorizedApplicationTime: Diese Bewerbung ist momentan nicht freigegeben.
|
||||
UnauthorizedMaterialTime: Dieses Material ist momentan nicht freigegeben.
|
||||
@ -1014,6 +1016,7 @@ AuthTagLecturer: Nutzer ist Dozent
|
||||
AuthTagCorrector: Nutzer ist Korrektor
|
||||
AuthTagTutor: Nutzer ist Tutor
|
||||
AuthTagTime: Zeitliche Einschränkungen sind erfüllt
|
||||
AuthTagStaffTime: Zeitliche Einschränkungen für Lehrbeteiligte sind erfüllt
|
||||
AuthTagAllocationTime: Zeitliche Einschränkungen durch Zentralanmeldung sind erfüllt
|
||||
AuthTagCourseRegistered: Nutzer ist Kursteilnehmer
|
||||
AuthTagTutorialRegistered: Nutzer ist Tutoriumsteilnehmer
|
||||
|
||||
@ -1,12 +1,10 @@
|
||||
Allocation -- attributes with prefix staff- affect lecturers only, but are invisble to students
|
||||
name (CI Text)
|
||||
shorthand (CI Text) -- practical shorthand
|
||||
name AllocationName
|
||||
shorthand AllocationShorthand -- practical shorthand
|
||||
term TermId
|
||||
school SchoolId -- school that manages this central allocation, not necessarily school of courses
|
||||
description Html Maybe -- description for prospective students
|
||||
staffDescription Html Maybe -- description seen by prospective lecturers only
|
||||
linkExternal Text Maybe -- arbitrary user-defined url for external course page
|
||||
capacity Int Maybe -- number of allowed enrolements, if restricte
|
||||
staffRegisterFrom UTCTime Maybe -- lectureres may register courses
|
||||
staffRegisterTo UTCTime Maybe -- course registration stops
|
||||
-- staffDeregisterUntil not needed: staff may make arbitrary changes until staffRegisterTo, always frozen afterwards
|
||||
@ -17,7 +15,6 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis
|
||||
registerFrom UTCTime Maybe -- student applications allowed from a given day onwwards or prohibited
|
||||
registerTo UTCTime Maybe -- student applications may be prohibited from a given date onwards
|
||||
-- deregisterUntil not needed: students may withdraw applicants until registerTo, but never after. Also see overrideDeregister
|
||||
registerSecret Text Maybe -- student application maybe protected by a simple common passphrase
|
||||
-- overrides
|
||||
registerByStaffFrom UTCTime Maybe -- lecturers may directly enrol/disenrol students after a given date or prohibited
|
||||
registerByStaffTo UTCTime Maybe
|
||||
@ -26,6 +23,7 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis
|
||||
-- overrideVisible not needed, since courses are always visible
|
||||
TermSchoolAllocationShort term school shorthand -- shorthand must be unique within school and semester
|
||||
TermSchoolAllocationName term school name -- name must be unique within school and semester
|
||||
deriving Show
|
||||
|
||||
AllocationCourse
|
||||
allocation AllocationId
|
||||
@ -41,7 +39,6 @@ AllocationUser
|
||||
|
||||
AllocationDeregister -- self-inflicted user-deregistrations from an allocated course
|
||||
user UserId
|
||||
allocation AllocationId Maybe
|
||||
course CourseId Maybe
|
||||
time UTCTime
|
||||
reason Text Maybe -- if this deregistration was done by proxy (e.g. the lecturer pressed the button)
|
||||
|
||||
6
routes
6
routes
@ -80,6 +80,11 @@
|
||||
/school SchoolListR GET !development
|
||||
/school/#SchoolId SchoolShowR GET !development
|
||||
|
||||
/allocation/#TermId/#SchoolId/#AllocationShorthand AllocationR:
|
||||
/ AShowR GET !free
|
||||
/course/#CryptoUUIDCourse/apply AApplyR POST !time
|
||||
/application/#CryptoFileNameCourseApplication AEditR GET POST !timeANDself !lecturerANDstaff-time
|
||||
|
||||
|
||||
-- For Pattern Synonyms see Foundation
|
||||
/course/ CourseListR GET !free
|
||||
@ -154,6 +159,7 @@
|
||||
/users/new EAddUserR GET POST
|
||||
/users/invite EInviteR GET POST
|
||||
/register ERegisterR POST !timeANDcourse-registeredAND¬exam-registered !timeANDexam-registeredAND¬exam-result
|
||||
/apps CApplicationsR GET POST
|
||||
/apps/#CryptoFileNameCourseApplication CourseApplicationR:
|
||||
/files CAFilesR GET !self !lecturerANDtime
|
||||
|
||||
|
||||
@ -112,6 +112,7 @@ import Handler.CryptoIDDispatch
|
||||
import Handler.SystemMessage
|
||||
import Handler.Health
|
||||
import Handler.Exam
|
||||
import Handler.Allocation
|
||||
|
||||
|
||||
-- This line actually creates our YesodDispatch instance. It is the second half
|
||||
|
||||
@ -49,6 +49,7 @@ decCryptoIDs [ ''SubmissionId
|
||||
, ''ExamPartId
|
||||
, ''AllocationId
|
||||
, ''CourseApplicationId
|
||||
, ''CourseId
|
||||
]
|
||||
|
||||
-- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission"
|
||||
|
||||
@ -13,8 +13,24 @@ import ClassyPrelude
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
instance {-# OVERLAPS #-} ToMarkup s => ToMarkup (CID.CryptoID c (CI s)) where
|
||||
toMarkup = toMarkup . CI.foldedCase . CID.ciphertext
|
||||
import Web.PathPieces
|
||||
import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..))
|
||||
|
||||
|
||||
instance ToMarkup s => ToMarkup (CID.CryptoID c s) where
|
||||
toMarkup = toMarkup . CID.ciphertext
|
||||
|
||||
instance {-# OVERLAPS #-} ToMarkup s => ToMarkup (CID.CryptoID c (CI s)) where
|
||||
toMarkup = toMarkup . CI.foldedCase . CID.ciphertext
|
||||
|
||||
instance {-# OVERLAPS #-} ToJSON s => ToJSON (CID.CryptoID c (CI s)) where
|
||||
toJSON = toJSON . CI.foldedCase . CID.ciphertext
|
||||
|
||||
instance {-# OVERLAPS #-} (ToJSON s, ToJSONKey s) => ToJSONKey (CID.CryptoID c (CI s)) where
|
||||
toJSONKey = case toJSONKey of
|
||||
ToJSONKeyText toT toE -> ToJSONKeyText (toT . CI.foldedCase . CID.ciphertext) (toE . CI.foldedCase . CID.ciphertext)
|
||||
ToJSONKeyValue toV toE -> ToJSONKeyValue (toV . CI.foldedCase . CID.ciphertext) (toE . CI.foldedCase . CID.ciphertext)
|
||||
|
||||
instance {-# OVERLAPS #-} (PathPiece s, CI.FoldCase s) => PathPiece (CID.CryptoID c (CI s)) where
|
||||
toPathPiece = toPathPiece . CI.foldedCase . CID.ciphertext
|
||||
fromPathPiece = fmap (CID.CryptoID . CI.mk) . fromPathPiece
|
||||
|
||||
12
src/Data/Void/Instances.hs
Normal file
12
src/Data/Void/Instances.hs
Normal file
@ -0,0 +1,12 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Data.Void.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
import Data.Void
|
||||
|
||||
instance ToContent Void where
|
||||
toContent = absurd
|
||||
instance ToTypedContent Void where
|
||||
toTypedContent = absurd
|
||||
@ -600,6 +600,17 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
|
||||
return Authorized
|
||||
-- Allocations: access only to school admins
|
||||
AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isAdmin <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` userAdmin) -> do
|
||||
E.on $ allocation E.^. AllocationSchool E.==. userAdmin E.^. UserAdminSchool
|
||||
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId
|
||||
E.&&. allocation E.^. AllocationTerm E.==. E.val tid
|
||||
E.&&. allocation E.^. AllocationSchool E.==. E.val ssh
|
||||
E.&&. allocation E.^. AllocationShorthand E.==. E.val ash
|
||||
guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
|
||||
return Authorized
|
||||
-- other routes: access to any admin is granted here
|
||||
_other -> $cachedHereBinary mAuthId . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
@ -641,6 +652,34 @@ tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer)
|
||||
return Authorized
|
||||
AllocationR tid ssh ash (AEditR cID) -> $cachedHereBinary (mAuthId, tid, ssh, ash, cID) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedLecturer) (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
isLecturer <- lift . E.selectExists . E.from $ \(courseApplication `E.InnerJoin` allocation `E.InnerJoin` allocationCourse `E.InnerJoin` course `E.InnerJoin` lecturer) -> do
|
||||
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
|
||||
E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse
|
||||
E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation
|
||||
E.on $ courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocation E.^. AllocationId)
|
||||
E.&&. courseApplication E.^. CourseApplicationCourse E.==. course E.^. CourseId
|
||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
|
||||
E.&&. allocation E.^. AllocationTerm E.==. E.val tid
|
||||
E.&&. allocation E.^. AllocationSchool E.==. E.val ssh
|
||||
E.&&. allocation E.^. AllocationShorthand E.==. E.val ash
|
||||
E.&&. courseApplication E.^. CourseApplicationId E.==. E.val appId
|
||||
guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer)
|
||||
return Authorized
|
||||
AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isLecturer <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` allocationCourse `E.InnerJoin` course `E.InnerJoin` lecturer) -> do
|
||||
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
|
||||
E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse
|
||||
E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation
|
||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
|
||||
E.&&. allocation E.^. AllocationTerm E.==. E.val tid
|
||||
E.&&. allocation E.^. AllocationSchool E.==. E.val ssh
|
||||
E.&&. allocation E.^. AllocationShorthand E.==. E.val ash
|
||||
guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedAllocationLecturer)
|
||||
return Authorized
|
||||
-- lecturer for any school will do
|
||||
_ -> $cachedHereBinary mAuthId . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
@ -712,8 +751,6 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
|
||||
return Authorized
|
||||
|
||||
|
||||
|
||||
CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do
|
||||
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn
|
||||
@ -823,8 +860,16 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
return Authorized
|
||||
_other -> unauthorizedI MsgUnauthorizedCourseTime
|
||||
|
||||
AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do
|
||||
-- Checks `registerFrom` and `registerTo`, override as further routes become available
|
||||
now <- liftIO getCurrentTime
|
||||
Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash
|
||||
guard $ NTop allocationRegisterFrom <= NTop (Just now)
|
||||
guard $ NTop (Just now) <= NTop allocationRegisterTo
|
||||
return Authorized
|
||||
|
||||
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
|
||||
smId <- decrypt cID
|
||||
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId
|
||||
cTime <- (NTop . Just) <$> liftIO getCurrentTime
|
||||
guard $ NTop systemMessageFrom <= cTime
|
||||
@ -832,6 +877,16 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
return Authorized
|
||||
|
||||
r -> $unsupportedAuthPredicate AuthTime r
|
||||
tagAccessPredicate AuthStaffTime = APDB $ \_ route _ -> case route of
|
||||
AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do
|
||||
-- Checks `registerFrom` and `registerTo`, override as further routes become available
|
||||
now <- liftIO getCurrentTime
|
||||
Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash
|
||||
guard $ NTop allocationStaffAllocationFrom <= NTop (Just now)
|
||||
guard $ NTop (Just now) <= NTop allocationStaffAllocationTo
|
||||
return Authorized
|
||||
|
||||
r -> $unsupportedAuthPredicate AuthStaffTime r
|
||||
tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of
|
||||
CourseR tid ssh csh CRegisterR -> do
|
||||
now <- liftIO getCurrentTime
|
||||
@ -974,7 +1029,7 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
|
||||
let authorizedIfExists f = do
|
||||
[E.Value ok] <- lift . E.select . return . E.exists $ E.from f
|
||||
whenExceptT ok Authorized
|
||||
participant <- decrypt cID
|
||||
participant <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedParticipant) (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
-- participant is currently registered
|
||||
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do
|
||||
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
|
||||
@ -1030,6 +1085,13 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
-- participant is applicant for this course
|
||||
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseApplication) -> do
|
||||
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
|
||||
E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val participant
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
unauthorizedI MsgUnauthorizedParticipant
|
||||
r -> $unsupportedAuthPredicate AuthParticipant r
|
||||
tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of
|
||||
@ -1105,20 +1167,21 @@ tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r
|
||||
tagAccessPredicate AuthSelf = APDB $ \mAuthId route _ -> exceptT return return $ do
|
||||
referencedUser <- case route of
|
||||
AdminUserR cID -> decrypt cID
|
||||
AdminUserDeleteR cID -> decrypt cID
|
||||
AdminHijackUserR cID -> decrypt cID
|
||||
UserNotificationR cID -> decrypt cID
|
||||
UserPasswordR cID -> decrypt cID
|
||||
CourseR _ _ _ (CUserR cID) -> decrypt cID
|
||||
referencedUser' <- case route of
|
||||
AdminUserR cID -> return $ Left cID
|
||||
AdminUserDeleteR cID -> return $ Left cID
|
||||
AdminHijackUserR cID -> return $ Left cID
|
||||
UserNotificationR cID -> return $ Left cID
|
||||
UserPasswordR cID -> return $ Left cID
|
||||
CourseR _ _ _ (CUserR cID) -> return $ Left cID
|
||||
CApplicationR _ _ _ cID _ -> do
|
||||
appId <- decrypt cID
|
||||
application <- $cachedHereBinary appId . lift $ get appId
|
||||
case application of
|
||||
Nothing -> throwError =<< unauthorizedI MsgUnauthorizedSelf
|
||||
Just CourseApplication{..} -> return courseApplicationUser
|
||||
appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
CourseApplication{..} <- maybeMExceptT (unauthorizedI MsgUnauthorizedSelf) . $cachedHereBinary appId $ get appId
|
||||
return $ Right courseApplicationUser
|
||||
_other -> throwError =<< $unsupportedAuthPredicate AuthSelf route
|
||||
referencedUser <- case referencedUser' of
|
||||
Right uid -> return uid
|
||||
Left cID -> catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
case mAuthId of
|
||||
Just uid
|
||||
| uid == referencedUser -> return Authorized
|
||||
@ -1133,7 +1196,7 @@ tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do
|
||||
UserPasswordR cID -> return cID
|
||||
CourseR _ _ _ (CUserR cID) -> return cID
|
||||
_other -> throwError =<< $unsupportedAuthPredicate AuthIsLDAP route
|
||||
referencedUser' <- decrypt referencedUser
|
||||
referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser
|
||||
maybeTMExceptT (unauthorizedI MsgUnauthorizedLDAP) $ do
|
||||
User{..} <- MaybeT $ get referencedUser'
|
||||
guard $ userAuthentication == AuthLDAP
|
||||
@ -1147,14 +1210,14 @@ tagAccessPredicate AuthIsPWHash = APDB $ \_ route _ -> exceptT return return $ d
|
||||
UserPasswordR cID -> return cID
|
||||
CourseR _ _ _ (CUserR cID) -> return cID
|
||||
_other -> throwError =<< $unsupportedAuthPredicate AuthIsPWHash route
|
||||
referencedUser' <- decrypt referencedUser
|
||||
referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser
|
||||
maybeTMExceptT (unauthorizedI MsgUnauthorizedPWHash) $ do
|
||||
User{..} <- MaybeT $ get referencedUser'
|
||||
guard $ is _AuthPWHash userAuthentication
|
||||
return Authorized
|
||||
tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of
|
||||
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
|
||||
smId <- decrypt cID
|
||||
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId
|
||||
let isAuthenticated = isJust mAuthId
|
||||
guard $ not systemMessageAuthenticatedOnly || isAuthenticated
|
||||
@ -1659,6 +1722,12 @@ instance YesodBreadcrumbs UniWorX where
|
||||
|
||||
breadcrumb (TermSchoolCourseListR tid ssh) = return (original $ unSchoolKey ssh, Just $ TermCourseListR tid)
|
||||
|
||||
breadcrumb (AllocationR tid ssh ash AShowR) = do
|
||||
mr <- getMessageRender
|
||||
Entity _ Allocation{allocationName} <- runDB . getBy404 $ TermSchoolAllocationShort tid ssh ash
|
||||
return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{original (unSchoolKey ssh)})|], Just $ HomeR)
|
||||
breadcrumb (AllocationR tid ssh ash (AEditR _)) = return ("Bewerbung", Just $ AllocationR tid ssh ash AShowR)
|
||||
|
||||
breadcrumb CourseListR = return ("Kurse" , Nothing)
|
||||
breadcrumb CourseNewR = return ("Neu" , Just CourseListR)
|
||||
breadcrumb (CourseR tid ssh csh CShowR) = return (original csh, Just $ TermSchoolCourseListR tid ssh)
|
||||
|
||||
6
src/Handler/Allocation.hs
Normal file
6
src/Handler/Allocation.hs
Normal file
@ -0,0 +1,6 @@
|
||||
module Handler.Allocation
|
||||
( module Handler.Allocation
|
||||
) where
|
||||
|
||||
import Handler.Allocation.Show as Handler.Allocation
|
||||
import Handler.Allocation.Edit as Handler.Allocation
|
||||
13
src/Handler/Allocation/Edit.hs
Normal file
13
src/Handler/Allocation/Edit.hs
Normal file
@ -0,0 +1,13 @@
|
||||
module Handler.Allocation.Edit
|
||||
( postAApplyR
|
||||
, getAEditR, postAEditR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
postAApplyR :: TermId -> SchoolId -> AllocationShorthand -> CryptoUUIDCourse -> Handler Void
|
||||
postAApplyR = fail "Not implemented"
|
||||
|
||||
getAEditR, postAEditR :: TermId -> SchoolId -> AllocationShorthand -> CryptoFileNameCourseApplication -> Handler Void
|
||||
getAEditR = postAEditR
|
||||
postAEditR = fail "Not implemented"
|
||||
15
src/Handler/Allocation/Show.hs
Normal file
15
src/Handler/Allocation/Show.hs
Normal file
@ -0,0 +1,15 @@
|
||||
module Handler.Allocation.Show
|
||||
( getAShowR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
getAShowR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
|
||||
getAShowR tid ssh ash = do
|
||||
Entity _ alloc <- runDB . getBy404 $ TermSchoolAllocationShort tid ssh ash
|
||||
|
||||
defaultLayout $ -- TODO
|
||||
[whamlet|
|
||||
<pre>
|
||||
#{tshow alloc}
|
||||
|]
|
||||
@ -1,5 +1,6 @@
|
||||
module Handler.Course.Application
|
||||
( getCAFilesR
|
||||
, getCApplicationsR, postCApplicationsR
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -24,6 +25,10 @@ getCAFilesR tid ssh csh cID = do
|
||||
, ssh == courseSchool
|
||||
, csh == courseShorthand
|
||||
]
|
||||
forM_ courseApplicationAllocation $ \aId -> do
|
||||
Allocation{..} <- get404 aId
|
||||
cCourse <- encrypt courseApplicationCourse :: DB CryptoUUIDCourse
|
||||
redirectWith movedPermanently301 $ AllocationR courseTerm courseSchool allocationShorthand AShowR :#: toPathPiece cCourse
|
||||
unless matches . redirectWith movedPermanently301 $ CApplicationR courseTerm courseSchool courseShorthand cID CAFilesR
|
||||
get404 courseApplicationUser
|
||||
|
||||
@ -35,3 +40,7 @@ getCAFilesR tid ssh csh cID = do
|
||||
return file
|
||||
|
||||
serveSomeFiles archiveName $ fsSource .| C.map entityVal
|
||||
|
||||
getCApplicationsR, postCApplicationsR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCApplicationsR = postCApplicationsR
|
||||
postCApplicationsR = fail "not implemented" -- dbtable of _all_ course applications
|
||||
|
||||
@ -218,8 +218,14 @@ postCRegisterR tid ssh csh = do
|
||||
Just _ -> addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
|
||||
BtnCourseDeregister -> runDB $ do
|
||||
deleteApplications
|
||||
deleteBy $ UniqueParticipant uid cid
|
||||
audit $ TransactionCourseParticipantDeleted cid uid
|
||||
part <- getBy $ UniqueParticipant uid cid
|
||||
forM_ part $ \(Entity partId CourseParticipant{..}) -> do
|
||||
delete $ partId
|
||||
audit $ TransactionCourseParticipantDeleted cid uid
|
||||
|
||||
when courseParticipantAllocated $ do
|
||||
now <- liftIO getCurrentTime
|
||||
insert_ $ AllocationDeregister courseParticipantUser (Just courseParticipantCourse) now Nothing
|
||||
|
||||
examRegistrations <- E.select . E.from $ \(examRegistration `E.InnerJoin` exam) -> do
|
||||
E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
|
||||
|
||||
@ -79,6 +79,10 @@ getCShowR tid ssh csh = do
|
||||
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
|
||||
mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
|
||||
mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration
|
||||
cID <- encrypt cid :: Handler CryptoUUIDCourse
|
||||
mAllocation' <- for mAllocation $ \Allocation{..} -> (,)
|
||||
<$> pure allocationName
|
||||
<*> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID)
|
||||
regForm <- if
|
||||
| is _Just mbAid -> do
|
||||
(courseRegisterForm', regButton) <- courseRegisterForm (Entity cid course)
|
||||
|
||||
@ -112,6 +112,7 @@ import Database.Persist.Types.Instances as Import ()
|
||||
import Data.UUID.Instances as Import ()
|
||||
import System.FilePath.Instances as Import ()
|
||||
import Net.IP.Instances as Import ()
|
||||
import Data.Void.Instances as Import ()
|
||||
|
||||
|
||||
import Control.Monad.Trans.RWS (RWST)
|
||||
|
||||
@ -445,6 +445,15 @@ customMigrations = Map.fromListWith (>>)
|
||||
whenM (tableExists "allocation_application_file") $
|
||||
tableDropEmpty "allocation_application_file"
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|17.0.0|] [version|18.0.0|]
|
||||
, do
|
||||
whenM (tableExists "allocation") $ do
|
||||
[executeQQ|ALTER TABLE allocation DROP COLUMN IF EXISTS capacity;|]
|
||||
[executeQQ|ALTER TABLE allocation DROP COLUMN IF EXISTS link_external;|]
|
||||
[executeQQ|ALTER TABLE allocation DROP COLUMN IF EXISTS register_secret;|]
|
||||
whenM (tableExists "allocation_deregister") $ do
|
||||
[executeQQ|ALTER TABLE allocation_deregister DROP COLUMN IF EXISTS allocation;|]
|
||||
)
|
||||
]
|
||||
|
||||
|
||||
|
||||
@ -13,26 +13,28 @@ import Import.NoModel
|
||||
import qualified Yesod.Auth.Util.PasswordStore as PWStore
|
||||
|
||||
|
||||
type Count = Sum Integer
|
||||
type Points = Centi
|
||||
type Count = Sum Integer
|
||||
type Points = Centi
|
||||
|
||||
type Email = Text
|
||||
type Email = Text
|
||||
|
||||
type SchoolName = CI Text
|
||||
type SchoolShorthand = CI Text
|
||||
type CourseName = CI Text
|
||||
type CourseShorthand = CI Text
|
||||
type SheetName = CI Text
|
||||
type MaterialName = CI Text
|
||||
type UserEmail = CI Email
|
||||
type UserIdent = CI Text
|
||||
type TutorialName = CI Text
|
||||
type ExamName = CI Text
|
||||
type ExamPartName = CI Text
|
||||
type ExamOccurrenceName = CI Text
|
||||
type SchoolName = CI Text
|
||||
type SchoolShorthand = CI Text
|
||||
type CourseName = CI Text
|
||||
type CourseShorthand = CI Text
|
||||
type SheetName = CI Text
|
||||
type MaterialName = CI Text
|
||||
type UserEmail = CI Email
|
||||
type UserIdent = CI Text
|
||||
type TutorialName = CI Text
|
||||
type ExamName = CI Text
|
||||
type ExamPartName = CI Text
|
||||
type ExamOccurrenceName = CI Text
|
||||
type AllocationName = CI Text
|
||||
type AllocationShorthand = CI Text
|
||||
|
||||
type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
|
||||
type InstanceId = UUID
|
||||
type ClusterId = UUID
|
||||
type TokenId = UUID
|
||||
type TermCandidateIncidence = UUID
|
||||
type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
|
||||
type InstanceId = UUID
|
||||
type ClusterId = UUID
|
||||
type TokenId = UUID
|
||||
type TermCandidateIncidence = UUID
|
||||
|
||||
@ -48,6 +48,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
|
||||
| AuthExamResult
|
||||
| AuthParticipant
|
||||
| AuthTime
|
||||
| AuthStaffTime
|
||||
| AuthAllocationTime
|
||||
| AuthMaterials
|
||||
| AuthOwner
|
||||
|
||||
@ -64,9 +64,11 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
|
||||
#{participants}
|
||||
$maybe capacity <- courseCapacity course
|
||||
\ von #{capacity}
|
||||
$maybe Allocation{allocationName} <- mAllocation
|
||||
$maybe (name, url) <- mAllocation'
|
||||
<dt .deflist__dt>_{MsgCourseAllocation}
|
||||
<dd .deflist__dd>#{allocationName}
|
||||
<dd .deflist__dd>
|
||||
<a href=#{url}>
|
||||
#{name}
|
||||
$nothing
|
||||
$maybe regFrom <- mRegFrom
|
||||
<dt .deflist__dt>Anmeldezeitraum
|
||||
|
||||
@ -703,3 +703,25 @@ fillDb = do
|
||||
void . insert $ SystemMessage (Just now) Nothing False Info "de" "System-Nachrichten können längeren Inhalt enthalten" (Just "System-Nachricht Zusammenfassung")
|
||||
void . insert $ SystemMessage (Just now) (Just now) False Info "de" "System-Nachrichten haben Ablaufdaten" Nothing
|
||||
void . insert $ SystemMessage Nothing Nothing False Error "de" "System-Nachrichten können Inaktiv sein" Nothing
|
||||
|
||||
|
||||
funAlloc <- insert' Allocation
|
||||
{ allocationName = "Funktionale Zentralanmeldung"
|
||||
, allocationShorthand = "fun"
|
||||
, allocationTerm = TermKey summer2018
|
||||
, allocationSchool = ifi
|
||||
, allocationDescription = Nothing
|
||||
, allocationStaffDescription = Nothing
|
||||
, allocationStaffRegisterFrom = Just now
|
||||
, allocationStaffRegisterTo = Nothing
|
||||
, allocationStaffAllocationFrom = Nothing
|
||||
, allocationStaffAllocationTo = Nothing
|
||||
, allocationRegisterFrom = Nothing
|
||||
, allocationRegisterTo = Nothing
|
||||
, allocationRegisterByStaffFrom = Nothing
|
||||
, allocationRegisterByStaffTo = Nothing
|
||||
, allocationRegisterByCourse = Nothing
|
||||
, allocationOverrideDeregister = Just now
|
||||
}
|
||||
insert_ $ AllocationCourse funAlloc pmo 100
|
||||
insert_ $ AllocationCourse funAlloc ffp 2
|
||||
|
||||
Loading…
Reference in New Issue
Block a user